Implement MonadLabelledMVar

Author: jasagredo

io-classes/CHANGELOG.md

@@ -5,6 +5,7 @@
 ### Breaking changes
 
 * Added `threadLabel` to `MonadThread`
+* Added `MonadLabelledMVar` class.
 
 ### 1.7.0.0
 

io-classes/src/Control/Concurrent/Class/MonadMVar.hs

@@ -5,7 +5,9 @@
 
 module Control.Concurrent.Class.MonadMVar
   ( MonadMVar (..)
+    -- * non-standard extensions
   , MonadInspectMVar (..)
+  , MonadLabelledMVar (..)
   ) where
 
 import Control.Concurrent.MVar qualified as IO
@@ -153,7 +155,6 @@ instance MonadMVar IO where
     modifyMVarMasked_ = IO.modifyMVarMasked_
     modifyMVarMasked  = IO.modifyMVarMasked
 
-
 --
 -- ReaderT instance
 --
@@ -204,6 +205,18 @@ instance MonadInspectMVar IO where
   type InspectMVarMonad IO = IO
   inspectMVar _ = tryReadMVar
 
+-- | Labelled `MVar`s
+--
+-- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace.
+-- This is very useful when analysing low lever concurrency issues (e.g.
+-- deadlocks, livelocks etc).
+class MonadMVar m
+   => MonadLabelledMVar m where
+  -- | Name an `MVar`
+  labelMVar :: MVar m a -> String -> m ()
+
+instance MonadLabelledMVar IO where
+  labelMVar = \_ _ -> pure ()
 --
 -- Utilities
 --

io-sim/CHANGELOG.md

@@ -7,6 +7,7 @@
   `TVars`.
 - `Show` instance for `ScheduleMod` now prints `ThreadId`s in a slightly nicer
   way, matching the way those steps would be traced in the `SimTrace`.
+- Implement `MonadLabelledMVar` instance for `(IOSim s)`
 
 ## 1.6.0.0
 

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

@@ -261,13 +261,17 @@ data MVarState m a = MVarEmpty   !(Deque (TVar m (Maybe a))) -- blocked on take
 newEmptyMVarDefault :: MonadSTM m => m (MVarDefault m a)
 newEmptyMVarDefault = MVar <$> newTVarIO (MVarEmpty mempty mempty)
 
+labelMVarDefault
+  :: MonadLabelledSTM m
+  => MVarDefault m a -> String -> m ()
+labelMVarDefault (MVar tvar) = atomically . labelTVar tvar . (<> "-MVar")
 
 newMVarDefault :: MonadSTM m => a -> m (MVarDefault m a)
 newMVarDefault a = MVar <$> newTVarIO (MVarFull a mempty)
 
 
 putMVarDefault :: ( MonadMask  m
-                  , MonadSTM   m
+                  , MonadLabelledSTM m
                   , forall x tvar. tvar ~ TVar m x => Eq tvar
                   )
                => MVarDefault m a -> a -> m ()
@@ -278,6 +282,7 @@ putMVarDefault (MVar tv) x = mask_ $ do
         -- It's full, add ourselves to the end of the 'put' blocked queue.
         MVarFull x' putq -> do
           putvar <- newTVar False
+          labelTVar putvar "internal-putvar"
           writeTVar tv (MVarFull x' (Deque.snoc (x, putvar) putq))
           return (Just putvar)
 
@@ -350,7 +355,7 @@ tryPutMVarDefault (MVar tv) x =
 
 
 takeMVarDefault :: ( MonadMask m
-                   , MonadSTM  m
+                   , MonadLabelledSTM m
                    , forall x tvar. tvar ~ TVar m x => Eq tvar
                    )
                 => MVarDefault m a
@@ -362,6 +367,7 @@ takeMVarDefault (MVar tv) = mask_ $ do
         -- It's empty, add ourselves to the end of the 'take' blocked queue.
         MVarEmpty takeq readq -> do
           takevar <- newTVar Nothing
+          labelTVar takevar "internal-takevar"
           writeTVar tv (MVarEmpty (Deque.snoc takevar takeq) readq)
           return (Left takevar)
 
@@ -433,7 +439,7 @@ tryTakeMVarDefault (MVar tv) = do
 -- 'putMVar' value.  It will also not block if the 'MVar' is full, even if there
 -- are other threads attempting to 'putMVar'.
 --
-readMVarDefault :: ( MonadSTM m
+readMVarDefault :: ( MonadLabelledSTM m
                    , MonadMask m
                    , forall x tvar. tvar ~ TVar m x => Eq tvar
                    )
@@ -446,6 +452,7 @@ readMVarDefault (MVar tv) = do
         -- It's empty, add ourselves to the 'read' blocked queue.
         MVarEmpty takeq readq -> do
           readvar <- newTVar Nothing
+          labelTVar readvar "internal-readvar"
           writeTVar tv (MVarEmpty takeq (Deque.snoc readvar readq))
           return (Left readvar)
 

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

@@ -606,6 +606,9 @@ instance MonadInspectMVar (IOSim s) where
         MVarEmpty _ _ -> pure Nothing
         MVarFull x _  -> pure (Just x)
 
+instance MonadLabelledMVar (IOSim s) where
+  labelMVar = labelMVarDefault
+
 data Async s a = Async !IOSimThreadId (STM s (Either SomeException a))
 
 instance Eq (Async s a) where