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.

Utility/DebugLocks.hs

@@ -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

Utility/LockPool/LockHandle.hs

@@ -20,6 +20,7 @@ module Utility.LockPool.LockHandle (
 
 import qualified Utility.LockPool.STM as P
 import Utility.LockPool.STM (LockFile)
+import Utility.DebugLocks
 
 import Control.Concurrent.STM
 import Control.Exception
@@ -49,8 +50,8 @@ checkSaneLock lockfile (LockHandle _ flo) = fCheckSaneLock flo lockfile
 makeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM P.LockHandle) -> (LockFile -> IO FileLockOps) -> IO LockHandle
 makeLockHandle pool file pa fa = bracketOnError setup cleanup go
   where
-	setup = atomically (pa pool file)
-	cleanup ph = P.releaseLock ph
+	setup = debugLocks $ atomically (pa pool file)
+	cleanup ph = debugLocks $ P.releaseLock ph
 	go ph = mkLockHandle pool file ph =<< fa file
 
 tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle)