Attach label to TVars mentioned in Effects

io-sim/CHANGELOG.md

@@ -3,6 +3,8 @@
 ## next version
 
 - Support `threadLabel` (`io-classes-1.8`)
+- `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written
+  `TVars`.
 
 ## 1.6.0.0
 

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE DerivingVia                #-}
@@ -25,9 +26,12 @@ module Control.Monad.IOSim.CommonTypes
   , TVarLabel
   , TVar (..)
   , SomeTVar (..)
+  , someTVarToLabelled
   , Deschedule (..)
   , ThreadStatus (..)
   , BlockedReason (..)
+  , Labelled (..)
+  , ppLabelled
     -- * Utils
   , ppList
   ) where
@@ -145,6 +149,11 @@ instance Eq (TVar s a) where
 data SomeTVar s where
   SomeTVar :: !(TVar s a) -> SomeTVar s
 
+someTVarToLabelled :: SomeTVar s -> ST s (Labelled (SomeTVar s))
+someTVarToLabelled tv@(SomeTVar var) = do
+  lbl <- readSTRef (tvarLabel var)
+  pure (Labelled tv lbl)
+
 data Deschedule = Yield
                 | Interruptable
                 | Blocked BlockedReason
@@ -162,6 +171,21 @@ data BlockedReason = BlockedOnSTM
                    | BlockedOnThrowTo
   deriving (Eq, Show)
 
+-- | A labelled value.
+--
+-- For example 'labelThread' or `labelTVar' will insert a label to `IOSimThreadId`
+-- (or `TVarId`).
+data Labelled a = Labelled {
+    l_labelled :: !a,
+    l_label    :: !(Maybe String)
+  }
+  deriving (Eq, Ord, Generic, Functor)
+  deriving Show via Quiet (Labelled a)
+
+ppLabelled :: (a -> String) -> Labelled a -> String
+ppLabelled pp Labelled { l_labelled = a, l_label = Nothing  } = pp a
+ppLabelled pp Labelled { l_labelled = a, l_label = Just lbl } = concat ["Labelled ", pp a, " ", lbl]
+
 --
 -- Utils
 --

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

@@ -58,7 +58,6 @@ module Control.Monad.IOSim.Types
   , ppTrace_
   , ppSimEvent
   , ppDebug
-  , Labelled (..)
   , module Control.Monad.IOSim.CommonTypes
   , Thrower (..)
   , Time (..)
@@ -1207,21 +1206,6 @@ ppSimEventType = \case
              ppEffect eff ]
   EventRaces a -> show a
 
--- | A labelled value.
---
--- For example 'labelThread' or `labelTVar' will insert a label to `IOSimThreadId`
--- (or `TVarId`).
-data Labelled a = Labelled {
-    l_labelled :: !a,
-    l_label    :: !(Maybe String)
-  }
-  deriving (Eq, Ord, Generic)
-  deriving Show via Quiet (Labelled a)
-
-ppLabelled :: (a -> String) -> Labelled a -> String
-ppLabelled pp Labelled { l_labelled = a, l_label = Nothing  } = pp a
-ppLabelled pp Labelled { l_labelled = a, l_label = Just lbl } = concat ["Labelled ", pp a, " ", lbl]
-
 --
 -- Executing STM Transactions
 --

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -568,10 +568,11 @@ schedule thread@Thread{
     CancelTimeout (Timeout tvar tmid) k -> do
       let timers' = PSQ.delete tmid timers
       written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)
+      written' <- mapM someTVarToLabelled written
       (wakeup, wokeby) <- threadsUnblockedByWrites written
       mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written
       let effect' = effect
-                 <> writeEffects written
+                 <> writeEffects written'
                  <> wakeupEffects wakeup
           thread' = thread { threadControl = ThreadControl k ctl
                            , threadEffect  = effect'
@@ -636,10 +637,12 @@ schedule thread@Thread{
           (wakeup, wokeby) <- threadsUnblockedByWrites written
           mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
           vClockRead <- leastUpperBoundTVarVClocks read
+          read' <- mapM someTVarToLabelled read
+          written' <- mapM someTVarToLabelled written
           let vClock'     = vClock `leastUpperBoundVClock` vClockRead
               effect'     = effect
-                         <> readEffects read
-                         <> writeEffects written
+                         <> readEffects read'
+                         <> writeEffects written'
                          <> wakeupEffects unblocked
               thread'     = thread { threadControl = ThreadControl (k x) ctl,
                                      threadVClock  = vClock',
@@ -648,12 +651,12 @@ schedule thread@Thread{
                simstate') = unblockThreads True vClock' wakeup simstate
           sequence_ [ modifySTRef (tvarVClock r) (leastUpperBoundVClock vClock')
                     | SomeTVar r <- created ++ written ]
-          written' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written
+          written'' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) written
           created' <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) created
           -- We deschedule a thread after a transaction... another may have woken up.
           !trace <- deschedule Yield thread' simstate' { nextVid  = nextVid' }
           return $
-            SimPORTrace time tid tstep tlbl (EventTxCommitted written' created' (Just effect')) $
+            SimPORTrace time tid tstep tlbl (EventTxCommitted written'' created' (Just effect')) $
             traceMany
               [ (time, tid', (-1), tlbl', EventTxWakeup vids')
               | tid' <- unblocked
@@ -674,7 +677,8 @@ schedule thread@Thread{
         StmTxAborted read e -> do
           -- schedule this thread to immediately raise the exception
           vClockRead <- leastUpperBoundTVarVClocks read
-          let effect' = effect <> readEffects read
+          read' <- mapM someTVarToLabelled read
+          let effect' = effect <> readEffects read'
               thread' = thread { threadControl = ThreadControl (Throw e) ctl,
                                  threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
                                  threadEffect  = effect' }
@@ -686,7 +690,8 @@ schedule thread@Thread{
           mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read
           vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read
           vClockRead <- leastUpperBoundTVarVClocks read
-          let effect' = effect <> readEffects read
+          read' <- mapM someTVarToLabelled read
+          let effect' = effect <> readEffects read'
               thread' = thread { threadVClock  = vClock `leastUpperBoundVClock` vClockRead,
                                  threadEffect  = effect' }
           !trace <- deschedule (Blocked BlockedOnSTM) thread' simstate

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

@@ -38,8 +38,8 @@ import Control.Monad.IOSim.CommonTypes
 -- execution step.  Only used by *IOSimPOR*.
 --
 data Effect = Effect {
-    effectReads  :: !(Set TVarId),
-    effectWrites :: !(Set TVarId),
+    effectReads  :: !(Set (Labelled TVarId)),
+    effectWrites :: !(Set (Labelled TVarId)),
     effectForks  :: !(Set IOSimThreadId),
     effectThrows :: ![IOSimThreadId],
     effectWakeup :: !(Set IOSimThreadId)
@@ -50,11 +50,11 @@ ppEffect :: Effect -> String
 ppEffect Effect { effectReads, effectWrites, effectForks, effectThrows, effectWakeup } =
   "Effect { " ++
     concat (List.intersperse ", " $
-           [ "reads = "  ++ show effectReads  | not (null effectReads)  ]
-        ++ [ "writes = " ++ show effectWrites | not (null effectWrites) ]
-        ++ [ "forks = "  ++ ppList ppIOSimThreadId (Set.toList effectForks)  | not (null effectForks)  ]
-        ++ [ "throws = " ++ ppList ppIOSimThreadId             effectThrows  | not (null effectThrows) ]
-        ++ [ "wakeup = " ++ ppList ppIOSimThreadId (Set.toList effectWakeup) | not (null effectWakeup) ])
+           [ "reads = "  ++ ppList (ppLabelled show) (Set.toList effectReads)  | not (null effectReads)  ]
+        ++ [ "writes = " ++ ppList (ppLabelled show) (Set.toList effectWrites) | not (null effectWrites) ]
+        ++ [ "forks = "  ++ ppList ppIOSimThreadId (Set.toList effectForks)    | not (null effectForks)  ]
+        ++ [ "throws = " ++ ppList ppIOSimThreadId             effectThrows    | not (null effectThrows) ]
+        ++ [ "wakeup = " ++ ppList ppIOSimThreadId (Set.toList effectWakeup)   | not (null effectWakeup) ])
         ++ " }"
 
 
@@ -72,14 +72,14 @@ instance Monoid Effect where
 -- readEffect :: SomeTVar s -> Effect
 -- readEffect r = mempty{effectReads = Set.singleton $ someTvarId r }
 
-readEffects :: [SomeTVar s] -> Effect
-readEffects rs = mempty{effectReads = Set.fromList (map someTvarId rs)}
+readEffects :: [Labelled (SomeTVar s)] -> Effect
+readEffects rs = mempty{effectReads = Set.fromList (map (someTvarId <$>) rs)}
 
 -- writeEffect :: SomeTVar s -> Effect
 -- writeEffect r = mempty{effectWrites = Set.singleton $ someTvarId r }
 
-writeEffects :: [SomeTVar s] -> Effect
-writeEffects rs = mempty{effectWrites = Set.fromList (map someTvarId rs)}
+writeEffects :: [Labelled (SomeTVar s)] -> Effect
+writeEffects rs = mempty{effectWrites = Set.fromList (map (someTvarId <$>) rs)}
 
 forkEffect :: IOSimThreadId -> Effect
 forkEffect tid = mempty{effectForks = Set.singleton tid}