add DebugLocks build flag
Using the method described in https://www.fpcomplete.com/blog/2018/05/pinpointing-deadlocks-in-haskell but my own code to implement it, and with callstacks added. This work is supported by the NIH-funded NICEMAN (ReproNim TR&D3) project.
This commit is contained in:
parent
953856df5f
commit
9127fe4821
13 changed files with 88 additions and 13 deletions
43
Utility/DebugLocks.hs
Normal file
43
Utility/DebugLocks.hs
Normal file
|
@ -0,0 +1,43 @@
|
|||
{- Pinpointing location of MVar/STM deadlocks
|
||||
-
|
||||
- Copyright 2018 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Utility.DebugLocks where
|
||||
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.IO.Class
|
||||
#ifdef DEBUGLOCKS
|
||||
import Control.Exception (BlockedIndefinitelyOnSTM, BlockedIndefinitelyOnMVar)
|
||||
import GHC.Stack
|
||||
import System.IO
|
||||
#endif
|
||||
|
||||
{- Wrap around any action, and if it dies due to deadlock, will display
|
||||
- a call stack on stderr when DEBUGLOCKS is defined.
|
||||
-
|
||||
- Should be zero cost to call when DEBUGLOCKS is not defined.
|
||||
-}
|
||||
#ifdef DEBUGLOCKS
|
||||
debugLocks :: HasCallStack => (MonadCatch m, MonadIO m) => m a -> m a
|
||||
debugLocks a = a `catches`
|
||||
[ Handler (\ (e :: BlockedIndefinitelyOnMVar) -> go "MVar" e callStack)
|
||||
, Handler (\ (e :: BlockedIndefinitelyOnSTM) -> go "STM" e callStack)
|
||||
]
|
||||
where
|
||||
go ty e cs = do
|
||||
liftIO $ do
|
||||
hPutStrLn stderr $
|
||||
ty ++ " deadlock detected " ++ prettyCallStack cs
|
||||
hFlush stderr
|
||||
throwM e
|
||||
#else
|
||||
-- No HasCallStack constraint.
|
||||
debugLocks :: (MonadCatch m, MonadIO m) => m a -> m a
|
||||
debugLocks a = a
|
||||
#endif
|
Loading…
Add table
Add a link
Reference in a new issue