9127fe4821Using 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.
43 lines
1.1 KiB
Haskell
43 lines
1.1 KiB
Haskell
{- 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
|