Merge #2791

2791: Labelled TVars & friends r=coot a=coot

This series of patches allows to label TVars, TMVars, TQueues, TBQueues.  It
also provides an api to consistently name thread & 'TVar' hidden in 'Async'.

- io-sim: include threads in 'FailureDeadlock'
- io-sim: derive LabelThread instance using Quiet
- io-sim-classes: MonadLabeledSTM and MonadLabeledAsync
- io-sim: MonadLabeledSTM and MonadLabeledAsync IOSim instances
- io-sim: more labeled threads & tvars ids


Co-authored-by: Marcin Szamotulski <[email protected]>

Author: iohk-bors[bot]

io-sim-classes/src/Control/Monad/Class/MonadSTM.hs

@@ -1,10 +1,13 @@
+{-# LANGUAGE DefaultSignatures      #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 module Control.Monad.Class.MonadSTM
   ( MonadSTM (..)
   , MonadSTMTx (..)
+  , MonadLabelledSTM (..)
+  , MonadLabelledSTMTx (..)
   , LazyTVar
   , LazyTMVar
   , TVar
@@ -14,6 +17,7 @@ module Control.Monad.Class.MonadSTM
 
   -- * Default 'TMVar' implementation
   , TMVarDefault (..)
+  , labelTMVarDefault
   , newTMVarDefault
   , newTMVarIODefault
   , newEmptyTMVarDefault
@@ -29,6 +33,7 @@ module Control.Monad.Class.MonadSTM
 
   -- * Default 'TBQueue' implementation
   , TQueueDefault (..)
+  , labelTQueueDefault
   , newTQueueDefault
   , readTQueueDefault
   , tryReadTQueueDefault
@@ -37,6 +42,7 @@ module Control.Monad.Class.MonadSTM
 
   -- * Default 'TBQueue' implementation
   , TBQueueDefault (..)
+  , labelTBQueueDefault
   , newTBQueueDefault
   , readTBQueueDefault
   , tryReadTBQueueDefault
@@ -184,6 +190,37 @@ newEmptyTMVarM  :: MonadSTM m => m (TMVar m a)
 newEmptyTMVarM = newEmptyTMVarIO
 {-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-}
 
+
+-- | Labelled 'TVar's, 'TMVar's, 'TQueue's and 'TBQueue's.
+--
+class MonadSTMTx stm => MonadLabelledSTMTx stm where
+  labelTVar    :: TVar_    stm a -> String -> stm ()
+  labelTMVar   :: TMVar_   stm a -> String -> stm ()
+  labelTQueue  :: TQueue_  stm a -> String -> stm ()
+  labelTBQueue :: TBQueue_ stm a -> String -> stm ()
+
+-- | A convenience class which provides 'MonadSTM' and 'MonadLabelledSTMTx'
+-- constraints.
+--
+class (MonadSTM m, MonadLabelledSTMTx (STM m))
+   => MonadLabelledSTM m where
+  labelTVarIO    :: TVar    m a -> String -> m ()
+  labelTMVarIO   :: TMVar   m a -> String -> m ()
+  labelTQueueIO  :: TQueue  m a -> String -> m ()
+  labelTBQueueIO :: TBQueue m a -> String -> m ()
+
+  default labelTVarIO :: TVar m a -> String -> m ()
+  labelTVarIO = \v l -> atomically (labelTVar v l)
+
+  default labelTMVarIO :: TMVar m a -> String -> m ()
+  labelTMVarIO = \v l -> atomically (labelTMVar v l)
+
+  default labelTQueueIO :: TQueue m a -> String -> m ()
+  labelTQueueIO = \v l -> atomically (labelTQueue v l)
+
+  default labelTBQueueIO :: TBQueue m a -> String -> m ()
+  labelTBQueueIO = \v l -> atomically (labelTBQueue v l)
+
 --
 -- Instance for IO uses the existing STM library implementations
 --
@@ -237,12 +274,28 @@ instance MonadSTM IO where
   newTMVarIO      = STM.newTMVarIO
   newEmptyTMVarIO = STM.newEmptyTMVarIO
 
+-- | noop instance
+--
+instance MonadLabelledSTMTx STM.STM where
+  labelTVar    = \_  _ -> return ()
+  labelTMVar   = \_  _ -> return ()
+  labelTQueue  = \_  _ -> return ()
+  labelTBQueue = \_  _ -> return ()
+
+-- | noop instance
+--
+instance MonadLabelledSTM IO where
+  labelTVarIO    = \_  _ -> return ()
+  labelTMVarIO   = \_  _ -> return ()
+  labelTQueueIO  = \_  _ -> return ()
+  labelTBQueueIO = \_  _ -> return ()
+
 -- | Wrapper around 'BlockedIndefinitelyOnSTM' that stores a call stack
 data BlockedIndefinitely = BlockedIndefinitely {
       blockedIndefinitelyCallStack :: CallStack
     , blockedIndefinitelyException :: BlockedIndefinitelyOnSTM
     }
-  deriving (Show)
+  deriving Show
 
 instance Exception BlockedIndefinitely where
   displayException (BlockedIndefinitely cs e) = unlines [
@@ -270,6 +323,11 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
 
 newtype TMVarDefault m a = TMVar (TVar m (Maybe a))
 
+labelTMVarDefault
+  :: MonadLabelledSTM m
+  => TMVarDefault m a -> String -> STM m ()
+labelTMVarDefault (TMVar tvar) = labelTVar tvar
+
 newTMVarDefault :: MonadSTM m => a -> STM m (TMVarDefault m a)
 newTMVarDefault a = do
   t <- newTVar (Just a)
@@ -291,7 +349,7 @@ newEmptyTMVarDefault = do
 
 newEmptyTMVarIODefault :: MonadSTM m => m (TMVarDefault m a)
 newEmptyTMVarIODefault = do
-  t <- newTVarM Nothing
+  t <- newTVarIO Nothing
   return (TMVar t)
 
 newEmptyTMVarMDefault :: MonadSTM m => m (TMVarDefault m a)
@@ -357,6 +415,13 @@ isEmptyTMVarDefault (TMVar t) = do
 data TQueueDefault m a = TQueue !(TVar m [a])
                                 !(TVar m [a])
 
+labelTQueueDefault
+  :: MonadLabelledSTM m
+  => TQueueDefault m a -> String -> STM m ()
+labelTQueueDefault (TQueue read write) label = do
+  labelTVar read (label ++ "-read")
+  labelTVar write (label ++ "-write")
+
 newTQueueDefault :: MonadSTM m => STM m (TQueueDefault m a)
 newTQueueDefault = do
   read  <- newTVar []
@@ -408,6 +473,15 @@ data TBQueueDefault m a = TBQueue
   !(TVar m [a])     -- written elements
   !Natural
 
+labelTBQueueDefault
+  :: MonadLabelledSTM m
+  => TBQueueDefault m a -> String -> STM m ()
+labelTBQueueDefault (TBQueue rsize read wsize write _size) label = do
+  labelTVar rsize (label ++ "-rsize")
+  labelTVar read (label ++ "-read")
+  labelTVar wsize (label ++ "-wsize")
+  labelTVar write (label ++ "-write")
+
 newTBQueueDefault :: MonadSTM m => Natural -> STM m (TBQueueDefault m a)
 newTBQueueDefault size = do
   rsize <- newTVar 0

io-sim-classes/src/Control/Monad/Class/MonadSTM/Strict.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE TypeFamilies          #-}
 
@@ -13,6 +14,8 @@ module Control.Monad.Class.MonadSTM.Strict
   , LazyTMVar
     -- * 'StrictTVar'
   , StrictTVar
+  , labelTVar
+  , labelTVarIO
   , castStrictTVar
   , toLazyTVar
   , newTVar
@@ -24,11 +27,13 @@ module Control.Monad.Class.MonadSTM.Strict
   , stateTVar
     -- * 'StrictTMVar'
   , StrictTMVar
+  , labelTMVar
+  , labelTMVarIO
   , castStrictTMVar
   , newTMVar
   , newTMVarIO
-  , newEmptyTMVarIO
   , newEmptyTMVar
+  , newEmptyTMVarIO
   , takeTMVar
   , tryTakeTMVar
   , putTMVar
@@ -48,7 +53,8 @@ module Control.Monad.Class.MonadSTM.Strict
   ) where
 
 import           Control.Monad.Class.MonadSTM as X hiding (LazyTMVar, LazyTVar,
-                     TMVar, TVar, isEmptyTMVar, modifyTVar, newEmptyTMVar,
+                     TMVar, TVar, isEmptyTMVar, labelTVar, labelTVarIO,
+                     labelTMVar, labelTMVarIO, modifyTVar, newEmptyTMVar,
                      newEmptyTMVarIO, newEmptyTMVarM, newTMVar, newTMVarIO,
                      newTMVarM, newTVar, newTVarIO, newTVarM, putTMVar,
                      readTMVar, readTVar, stateTVar, swapTMVar, takeTMVar,
@@ -73,6 +79,12 @@ data StrictTVar m a = StrictTVar
    , tvar      :: !(LazyTVar m a)
    }
 
+labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m ()
+labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar
+
+labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m ()
+labelTVarIO v = atomically . labelTVar v
+
 castStrictTVar :: LazyTVar m ~ LazyTVar n
                => StrictTVar m a -> StrictTVar n a
 castStrictTVar StrictTVar{invariant, tvar} = StrictTVar{invariant, tvar}
@@ -86,7 +98,6 @@ toLazyTVar StrictTVar { tvar } = tvar
 
 newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)
 newTVar !a = StrictTVar (const Nothing) <$> Lazy.newTVar a
-
 newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)
 newTVarIO = newTVarWithInvariantIO (const Nothing)
 
@@ -142,6 +153,12 @@ updateTVar = stateTVar
 -- to very hard to debug bugs where code is blocked indefinitely.
 newtype StrictTMVar m a = StrictTMVar (LazyTMVar m a)
 
+labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m ()
+labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar
+
+labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m ()
+labelTMVarIO v = atomically . labelTMVar v
+
 castStrictTMVar :: LazyTMVar m ~ LazyTMVar n
                 => StrictTMVar m a -> StrictTMVar n a
 castStrictTMVar (StrictTMVar var) = StrictTMVar var

io-sim/io-sim.cabal

@@ -44,7 +44,8 @@ library
                        exceptions        >=0.10,
                        containers,
                        psqueues          >=0.2 && <0.3,
-                       time              >=1.6 && <1.11
+                       time              >=1.6 && <1.11,
+                       quiet
 
   ghc-options:         -Wall
                        -Wcompat

io-sim/src/Control/Monad/IOSim.hs

@@ -21,7 +21,7 @@ module Control.Monad.IOSim (
   Trace(..),
   TraceEvent(..),
   ThreadLabel,
-  LabeledThread (..),
+  Labelled (..),
   traceEvents,
   traceResult,
   selectTraceEvents,
@@ -63,9 +63,9 @@ selectTraceEvents fn = go
     go (Trace _ _ _ ev trace) = case fn ev of
       Just x  -> x : go trace
       Nothing ->     go trace
-    go (TraceMainException _ e _) = throw (FailureException e)
-    go (TraceDeadlock      _   _) = throw FailureDeadlock
-    go (TraceMainReturn    _ _ _) = []
+    go (TraceMainException _ e _)       = throw (FailureException e)
+    go (TraceDeadlock      _   threads) = throw (FailureDeadlock threads)
+    go (TraceMainReturn    _ _ _)       = []
 
 -- | Select all the traced values matching the expected type. This relies on
 -- the sim's dynamic trace facility.
@@ -104,20 +104,24 @@ data Failure =
        FailureException SomeException
 
        -- | The threads all deadlocked
-     | FailureDeadlock
+     | FailureDeadlock ![Labelled ThreadId]
 
        -- | The main thread terminated normally but other threads were still
        -- alive, and strict shutdown checking was requested.
        -- See 'runSimStrictShutdown'
-     | FailureSloppyShutdown [LabeledThread]
+     | FailureSloppyShutdown [Labelled ThreadId]
   deriving Show
 
 instance Exception Failure where
     displayException (FailureException err) = displayException  err
-    displayException FailureDeadlock = "<<io-sim deadlock>>"
+    displayException (FailureDeadlock threads) =
+      concat [ "<<io-sim deadlock: "
+             , intercalate ", " (show `map` threads)
+             , ">>"
+             ]
     displayException (FailureSloppyShutdown threads) =
       concat [ "<<io-sim sloppy shutdown: "
-             , intercalate "," (show `map` threads)
+             , intercalate ", " (show `map` threads)
              , ">>"
              ]
 
@@ -150,7 +154,7 @@ traceResult strict = go
                                | strict = Left (FailureSloppyShutdown tids)
     go (TraceMainReturn _ x _)          = Right x
     go (TraceMainException _ e _)       = Left (FailureException e)
-    go (TraceDeadlock   _   _)          = Left FailureDeadlock
+    go (TraceDeadlock   _   threads)    = Left (FailureDeadlock threads)
 
 traceEvents :: Trace a -> [(Time, ThreadId, Maybe ThreadLabel, TraceEvent)]
 traceEvents (Trace time tid tlbl event t) = (time, tid, tlbl, event)