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:
Joey Hess 2018-11-19 15:00:24 -04:00
parent 953856df5f
commit 9127fe4821
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
13 changed files with 88 additions and 13 deletions

43
Utility/DebugLocks.hs Normal file
View 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