diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index 8842dafb..f410e2f4 100644 --- a/lib/Echidna/Campaign.hs +++ b/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) diff --git a/lib/Echidna/CatchMVar.hs b/lib/Echidna/CatchMVar.hs new file mode 100644 index 00000000..b842ed63 --- /dev/null +++ b/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 |] diff --git a/lib/Echidna/Server.hs b/lib/Echidna/Server.hs index 6827f790..e16461df 100644 --- a/lib/Echidna/Server.hs +++ b/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) diff --git a/lib/Echidna/SymExec.hs b/lib/Echidna/SymExec.hs index 2c192abc..7879e887 100644 --- a/lib/Echidna/SymExec.hs +++ b/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 diff --git a/package.yaml b/package.yaml index 191eff52..8d8a899b 100644 --- a/package.yaml +++ b/package.yaml @@ -44,6 +44,7 @@ dependencies: - rosezipper - semver - split + - template-haskell - text - transformers - time