catch some (not all) mvar errors

lib/Echidna/Campaign.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Echidna.Campaign where
 
+import Echidna.CatchMVar
+
 import Control.Concurrent
 import Control.DeepSeq (force)
 import Control.Monad (replicateM, when, unless, void, forM_)
@@ -178,7 +181,7 @@ runSymWorker callback vm dict workerId initialCorpus name = do
     modify' (\ws -> ws { runningThreads = [threadId] })
     lift callback
 
-    symTxs <- liftIO $ takeMVar symTxsChan
+    symTxs <- liftIO $ $takeMVar_ symTxsChan
 
     modify' (\ws -> ws { runningThreads = [] })
     lift callback
@@ -558,7 +561,7 @@ pushWorkerEvent event = do
 pushCampaignEvent :: Env -> CampaignEvent -> IO ()
 pushCampaignEvent env event = do
   time <- liftIO getTimestamp
-  writeChan env.eventQueue (time, event)
+  $writeChan_ env.eventQueue (time, event)
 
 -- | Listener reads events and runs the given 'handler' function. It exits after
 -- receiving all 'WorkerStopped' events and sets the returned 'MVar' so the
@@ -579,7 +582,7 @@ spawnListener handler = do
   eventQueue <- asks (.eventQueue)
   chan <- liftIO $ dupChan eventQueue
   stopVar <- liftIO newEmptyMVar
-  liftIO $ void $ forkFinally (listenerLoop handler chan nworkers) (const $ putMVar stopVar ())
+  liftIO $ void $ forkFinally (listenerLoop handler chan nworkers) (const $ $putMVar_ stopVar ())
   pure stopVar
 
 -- | Repeatedly run 'handler' on events from 'chan'.
@@ -595,7 +598,7 @@ listenerLoop
   -> m ()
 listenerLoop handler chan !workersAlive =
   when (workersAlive > 0) $ do
-    event <- liftIO $ readChan chan
+    event <- liftIO $ $readChan_ chan
     handler event
     case event of
       (_, WorkerEvent _ _ (WorkerStopped _)) -> listenerLoop handler chan (workersAlive - 1)

lib/Echidna/CatchMVar.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Echidna.CatchMVar (catchMVar, putMVar_, takeMVar_, writeChan_, readChan_) where
+
+import Control.Exception
+import Language.Haskell.TH
+
+-- https://tech.fpcomplete.com/blog/2018/05/pinpointing-deadlocks-in-haskell/
+catchMVar :: String -> IO a -> IO a
+catchMVar msg action =
+  action `catches`
+  [ Handler (\exc@BlockedIndefinitelyOnMVar -> putStrLn ("[MVar]: Error at " ++ msg) >> throwIO exc)
+  , Handler (\exc@BlockedIndefinitelyOnSTM -> putStrLn ("[STM]: Error at " ++ msg) >> throwIO exc)
+  ]
+
+printLocation :: Q Exp
+printLocation = do
+  loc <- location
+  let
+    fname = loc_filename loc
+    line = fst $ loc_start loc
+    msg = fname ++ ":" ++ show line
+  litE $ stringL msg
+
+catchMVarTempl :: Q Exp
+catchMVarTempl = [| catchMVar $printLocation |]
+
+putMVar_ :: Q Exp
+putMVar_ = [| ($catchMVarTempl .) . putMVar |]
+
+takeMVar_ :: Q Exp
+takeMVar_ = [| $catchMVarTempl . takeMVar |]
+
+writeChan_ :: Q Exp
+writeChan_ = [| ($catchMVarTempl .) . writeChan |]
+
+readChan_ :: Q Exp
+readChan_ = [| $catchMVarTempl . readChan |]

lib/Echidna/Server.hs

@@ -1,5 +1,9 @@
+{-#LANGUAGE TemplateHaskell #-}
+
 module Echidna.Server where
 
+import Echidna.CatchMVar
+
 import Control.Concurrent
 import Control.Monad (when, void)
 import Data.Aeson
@@ -45,7 +49,7 @@ runSSEServer serverStopVar env port nworkers = do
         if aliveNow == 0 then
           pure CloseEvent
         else do
-          event@(_, campaignEvent) <- readChan sseChan
+          event@(_, campaignEvent) <- $readChan_ sseChan
           let eventName = \case
                 WorkerEvent _ _ workerEvent ->
                   case workerEvent of
@@ -61,7 +65,7 @@ runSSEServer serverStopVar env port nworkers = do
           case campaignEvent of
             WorkerEvent _ _ (WorkerStopped _) -> do
               aliveAfter <- atomicModifyIORef' aliveRef (\n -> (n-1, n-1))
-              when (aliveAfter == 0) $ putMVar serverStopVar ()
+              when (aliveAfter == 0) $ $putMVar_ serverStopVar ()
             _ -> pure ()
           pure $ ServerEvent
             { eventName = Just (eventName campaignEvent)

lib/Echidna/SymExec.hs

@@ -1,7 +1,10 @@
 {-# OPTIONS_GHC -Wno-gadt-mono-local-binds #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Echidna.SymExec (createSymTx) where
 
+import Echidna.CatchMVar
+
 import Control.Applicative ((<|>))
 import Control.Concurrent.Async (mapConcurrently)
 import Control.Concurrent (ThreadId, forkIO)
@@ -99,12 +102,12 @@ exploreContract conf contract tx vm = do
         exprInter <- interpret fetcher maxIters askSmtIters Naive vm' runExpr
         models <- liftIO $ mapConcurrently (checkSat solvers) $ manipulateExprInter isConc exprInter
         pure $ mapMaybe (modelToTx dst method conf.solConf.sender defaultSender) models
-      liftIO $ putMVar resultChan $ concat res
-      liftIO $ putMVar doneChan ()
-    liftIO $ putMVar threadIdChan threadId
-    liftIO $ takeMVar doneChan
+      liftIO $ $putMVar_ resultChan $ concat res
+      liftIO $ $putMVar_ doneChan ()
+    liftIO $ $putMVar_ threadIdChan threadId
+    liftIO $ $takeMVar_ doneChan
 
-  threadId <- takeMVar threadIdChan
+  threadId <- $takeMVar_ threadIdChan
   pure (threadId, resultChan)
 
 -- | Turn the expression returned by `interpret` into into SMT2 values to feed into the solver

package.yaml

@@ -44,6 +44,7 @@ dependencies:
   - rosezipper
   - semver
   - split
+  - template-haskell
   - text
   - transformers
   - time