hunting random freezes

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -335,6 +335,11 @@ sweep = do
 
   liftIO $ atomically $ modifyTVar' sw (<> HashMap.fromList (mconcat alive))
 
+addJobIO :: IO () -> PeerM e IO ()
+addJobIO m = do
+  PeerEnv{..} <- ask
+  addJob _envDeferred m
+
 instance ( Typeable (EventKey e p)
          , Typeable (Event e p)
          , Hashable (EventKey e p)
@@ -507,6 +512,7 @@ runProto hh = do
                           }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg)
 
 
+
 instance (Monad m, HasProtocol e p) => HasThatPeer p e (ResponseM e m) where
   thatPeer = asks (view answTo)
 

hbs2-peer/app/PeerMain.hs

@@ -1338,7 +1338,7 @@ runPeer opts = respawnOnError opts $ do
                            , rpcMailboxAdapter  = AnyMailboxAdapter @s mailboxWorker
                            }
 
-  m1 <- async $ runMessagingUnix rpcmsg
+  m1 <- asyncLinked $ runMessagingUnix rpcmsg
 
   rpcProto <- async $ flip runReaderT rpcctx do
     env <- newNotifyEnvServer @(RefChanEvents L4Proto) refChanNotifySource

hbs2-peer/app/RPC2.hs

@@ -219,6 +219,14 @@ instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) =>
             pure nil
 
 
+        entry $ bindMatch "test:explode" $ const do
+
+          liftIO $ withPeerM rpcPeerEnv do
+            forever do
+              addJobIO $ forever none
+
+          pure $ mkSym "text:explode"
+
         entry $ bindMatch "reset" $ const do
           throwTo rpcSelf GoAgainException
           pure $ mkSym "reset"

hbs2-peer/app/Watchdogs.hs

@@ -20,6 +20,9 @@ runRpcWatchDog :: MonadIO m => ThreadId -> FilePath -> m ()
 runRpcWatchDog peer soname = do
     liftIO $ flip runContT pure do
 
+      ContT $ bracket none $ const $ do
+        err "bracket in runRpcWatchDog"
+
       api <- ContT $ withRPC2 @PeerAPI soname
 
       flip fix WIdle $ \next -> \case
@@ -30,7 +33,6 @@ runRpcWatchDog peer soname = do
 
         WCall n | n > 2 -> do
           err $ red "RpcWatchDog fired"
-          throwTo peer GoAgainException
 
         WCall n -> do
           debug $ "RpcWatchDog" <+> pretty n
@@ -38,6 +40,5 @@ runRpcWatchDog peer soname = do
             Just _ -> next WIdle
             Nothing -> next (WCall (succ n))
 
-    throwTo peer GoAgainException
 
 

hbs2-peer/hbs2-peer.cabal

@@ -85,6 +85,7 @@ common shared-properties
         -Wall
         -O2
         -fno-warn-type-defaults
+        -fno-omit-yields
         -- -fno-warn-unused-matches
         -- -fno-warn-unused-do-bind
         -- -Werror=missing-methods