Skip to content

Commit 2e84a8c

Browse files
cootcoot
committed
io-sim: extend tvar tracing with string values
Sometimes it is useful to trace string values when inspecting 'TVar' values (see next commit in which we trace when a 'TMVar' is taken / released). For this purpose we provide a 'TraceValue' record and some useful pattern synonyms, which allow to log dynamic and / or string values. IOSim will log Dynamic values with 'EventDynamic', while string values will be logged with 'EventSay'. For 'IO' both are ignored, as the 'traceTVar' callback never fires.
1 parent 309b6f8 commit 2e84a8c

File tree

6 files changed

+118
-84
lines changed

6 files changed

+118
-84
lines changed

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

Lines changed: 67 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,10 @@
55
{-# LANGUAGE GADTs #-}
66
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
77
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE NamedFieldPuns #-}
9+
{-# LANGUAGE PatternSynonyms #-}
810
{-# LANGUAGE RankNTypes #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
912
{-# LANGUAGE StandaloneDeriving #-}
1013
{-# LANGUAGE TypeFamilies #-}
1114
{-# LANGUAGE TypeFamilyDependencies #-}
@@ -16,6 +19,8 @@ module Control.Monad.Class.MonadSTM
1619
( MonadSTM (..)
1720
, MonadLabelledSTM (..)
1821
, MonadInspectSTM (..)
22+
, TraceValue (TraceValue, TraceDynamic, TraceString, DontTrace, traceDynamic,
23+
traceString)
1924
, MonadTraceSTM (..)
2025
, LazyTVar
2126
, LazyTMVar
@@ -263,6 +268,41 @@ instance MonadInspectSTM IO where
263268
inspectTMVar _ = atomically . tryReadTMVar
264269

265270

271+
-- | A GADT which instructs how to trace the value. The 'traceDynamic' will
272+
-- use dynamic tracing, e.g. 'Control.Monad.IOSim.traceM'; while 'traceString'
273+
-- will be traced with 'EventSay'.
274+
--
275+
data TraceValue where
276+
TraceValue :: forall tr. Typeable tr
277+
=> { traceDynamic :: Maybe tr
278+
, traceString :: Maybe String
279+
}
280+
-> TraceValue
281+
282+
283+
-- | Use only dynamic tracer.
284+
--
285+
pattern TraceDynamic :: () => forall tr. Typeable tr => tr -> TraceValue
286+
pattern TraceDynamic tr <- TraceValue { traceDynamic = Just tr }
287+
where
288+
TraceDynamic tr = TraceValue { traceDynamic = Just tr, traceString = Nothing }
289+
290+
-- | Use only string tracing.
291+
--
292+
pattern TraceString :: String -> TraceValue
293+
pattern TraceString tr <- TraceValue { traceString = Just tr }
294+
where
295+
TraceString tr = TraceValue { traceDynamic = (Nothing :: Maybe ())
296+
, traceString = Just tr
297+
}
298+
299+
-- | Do not trace the value.
300+
--
301+
pattern DontTrace :: TraceValue
302+
pattern DontTrace <- TraceValue Nothing Nothing
303+
where
304+
DontTrace = TraceValue (Nothing :: Maybe ()) Nothing
305+
266306
-- | 'MonadTraceSTM' allows to trace values of stm variables when stm
267307
-- transaction is commited. This allows to verify invariants when a variable
268308
-- is commited.
@@ -277,92 +317,79 @@ class MonadInspectSTM m
277317
--
278318
{-# MINIMAL traceTVar, traceTQueue, traceTBQueue #-}
279319

280-
traceTVar :: Typeable tr
281-
=> proxy m
320+
traceTVar :: proxy m
282321
-> TVar m a
283-
-> (Maybe a -> a -> InspectMonad m tr)
322+
-> (Maybe a -> a -> InspectMonad m TraceValue)
284323
-- ^ callback which receives initial value or 'Nothing' (if it
285324
-- is a newly created 'TVar'), and the commited value.
286325
-> STM m ()
287326

288327

289-
traceTMVar :: Typeable tr
290-
=> proxy m
328+
traceTMVar :: proxy m
291329
-> TMVar m a
292-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
330+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
293331
-> STM m ()
294332

295-
traceTQueue :: Typeable tr
296-
=> proxy m
333+
traceTQueue :: proxy m
297334
-> TQueue m a
298-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
335+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
299336
-> STM m ()
300337

301-
traceTBQueue :: Typeable tr
302-
=> proxy m
338+
traceTBQueue :: proxy m
303339
-> TBQueue m a
304-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
340+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
305341
-> STM m ()
306342

307343
default traceTMVar :: ( TMVar m a ~ TMVarDefault m a
308-
, Typeable tr
309344
)
310345
=> proxy m
311346
-> TMVar m a
312-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
347+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
313348
-> STM m ()
314349
traceTMVar = traceTMVarDefault
315350

316351

317-
traceTVarIO :: Typeable tr
318-
=> proxy m
352+
traceTVarIO :: proxy m
319353
-> TVar m a
320-
-> (Maybe a -> a -> InspectMonad m tr)
354+
-> (Maybe a -> a -> InspectMonad m TraceValue)
321355
-> m ()
322356

323-
traceTMVarIO :: Typeable tr
324-
=> proxy m
357+
traceTMVarIO :: proxy m
325358
-> TMVar m a
326-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
359+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
327360
-> m ()
328361

329-
traceTQueueIO :: Typeable tr
330-
=> proxy m
362+
traceTQueueIO :: proxy m
331363
-> TQueue m a
332-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
364+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
333365
-> m ()
334366

335-
traceTBQueueIO :: Typeable tr
336-
=> proxy m
367+
traceTBQueueIO :: proxy m
337368
-> TBQueue m a
338-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
369+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
339370
-> m ()
340371

341-
default traceTVarIO :: Typeable tr
342-
=> proxy m
372+
default traceTVarIO :: proxy m
343373
-> TVar m a
344-
-> (Maybe a -> a -> InspectMonad m tr)
374+
-> (Maybe a -> a -> InspectMonad m TraceValue)
345375
-> m ()
346376
traceTVarIO = \p v f -> atomically (traceTVar p v f)
347377

348-
default traceTMVarIO :: Typeable tr
349-
=> proxy m
378+
default traceTMVarIO :: proxy m
350379
-> TMVar m a
351-
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m tr)
380+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
352381
-> m ()
353382
traceTMVarIO = \p v f -> atomically (traceTMVar p v f)
354383

355-
default traceTQueueIO :: Typeable tr
356-
=> proxy m
384+
default traceTQueueIO :: proxy m
357385
-> TQueue m a
358-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
386+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
359387
-> m ()
360388
traceTQueueIO = \p v f -> atomically (traceTQueue p v f)
361389

362-
default traceTBQueueIO :: Typeable tr
363-
=> proxy m
390+
default traceTBQueueIO :: proxy m
364391
-> TBQueue m a
365-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
392+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
366393
-> m ()
367394
traceTBQueueIO = \p v f -> atomically (traceTBQueue p v f)
368395

@@ -480,10 +507,10 @@ labelTMVarDefault
480507
labelTMVarDefault (TMVar tvar) = labelTVar tvar
481508

482509
traceTMVarDefault
483-
:: (MonadTraceSTM m, Typeable tr)
510+
:: MonadTraceSTM m
484511
=> proxy m
485512
-> TMVarDefault m a
486-
-> (Maybe (Maybe a) -> Maybe a -> InspectMonad m tr)
513+
-> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue)
487514
-> STM m ()
488515
traceTMVarDefault p (TMVar t) f = traceTVar p t f
489516

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

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,13 @@
77
--
88
module Control.Monad.IOSim.CommonTypes where
99

10+
import Control.Monad.Class.MonadSTM (TraceValue)
1011
import Control.Monad.ST.Lazy
1112

1213
import Data.Function (on)
1314
import Data.Map (Map)
1415
import Data.Set (Set)
1516
import Data.STRef.Lazy
16-
import Data.Typeable (Typeable)
1717

1818
data ThreadId = RacyThreadId [Int]
1919
| ThreadId [Int] -- non racy threads have higher priority
@@ -72,16 +72,12 @@ data TVar s a = TVar {
7272

7373
-- | Callback to construct a trace which will be attached to the dynamic
7474
-- trace.
75-
tvarTrace :: !(STRef s (Maybe (MkTVarTrace s a)))
75+
tvarTrace :: !(STRef s (Maybe (Maybe a -> a -> ST s TraceValue)))
7676
}
7777

7878
instance Eq (TVar s a) where
7979
(==) = on (==) tvarId
8080

81-
data MkTVarTrace s a where
82-
MkTVarTrace :: forall s a tr. Typeable tr => (Maybe a -> a -> ST s tr)
83-
-> MkTVarTrace s a
84-
8581
data SomeTVar s where
8682
SomeTVar :: !(TVar s a) -> SomeTVar s
8783

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

Lines changed: 18 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,7 @@ import Prelude hiding (read)
5656
import Data.Foldable (traverse_)
5757
import qualified Data.List as List
5858
import qualified Data.List.Trace as Trace
59-
import Data.Maybe (catMaybes)
59+
import Data.Maybe (mapMaybe)
6060
import Data.Map.Strict (Map)
6161
import qualified Data.Map.Strict as Map
6262
import Data.OrdPSQ (OrdPSQ)
@@ -406,7 +406,8 @@ schedule thread@Thread{
406406

407407
Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \res ->
408408
case res of
409-
StmTxCommitted x written _read created tvarTraces nextVid' -> do
409+
StmTxCommitted x written _read created
410+
tvarDynamicTraces tvarStringTraces nextVid' -> do
410411
(wakeup, wokeby) <- threadsUnblockedByWrites written
411412
mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
412413
let thread' = thread { threadControl = ThreadControl (k x) ctl }
@@ -431,7 +432,10 @@ schedule thread@Thread{
431432
, let Just vids' = Set.toList <$> Map.lookup tid' wokeby ]
432433
$ traceMany
433434
[ (time, tid, tlbl, EventLog tr)
434-
| tr <- tvarTraces ]
435+
| tr <- tvarDynamicTraces ]
436+
$ traceMany
437+
[ (time, tid, tlbl, EventSay str)
438+
| str <- tvarStringTraces ]
435439
$ SimTrace time tid tlbl (EventUnblocked unblocked)
436440
$ SimTrace time tid tlbl (EventDeschedule Yield)
437441
$ trace
@@ -821,7 +825,10 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
821825
k0 $ StmTxCommitted x (reverse writtenSeq)
822826
[]
823827
(reverse createdSeq)
824-
(catMaybes $ ds ++ ds')
828+
(mapMaybe (\TraceValue { traceDynamic }
829+
-> toDyn <$> traceDynamic)
830+
$ ds ++ ds')
831+
(mapMaybe traceString $ ds ++ ds')
825832
nextVid
826833

827834
OrElseLeftFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
@@ -893,7 +900,7 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
893900
go ctl read written writtenSeq createdSeq nextVid k
894901

895902
TraceTVar tvar f k -> do
896-
writeSTRef (tvarTrace tvar) (Just $ MkTVarTrace f)
903+
writeSTRef (tvarTrace tvar) (Just f)
897904
go ctl read written writtenSeq createdSeq nextVid k
898905

899906
ReadTVar v k
@@ -1001,19 +1008,18 @@ readTVarUndos TVar{tvarUndo} = readSTRef tvarUndo
10011008
-- 'written.
10021009
traceTVarST :: TVar s a
10031010
-> Bool -- true if it's a new 'TVar'
1004-
-> ST s (Maybe Dynamic)
1011+
-> ST s TraceValue
10051012
traceTVarST TVar{tvarCurrent, tvarUndo, tvarTrace} new = do
10061013
mf <- readSTRef tvarTrace
10071014
case mf of
1008-
Nothing -> return Nothing
1009-
Just (MkTVarTrace f) -> do
1015+
Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ())
1016+
, traceString = Nothing }
1017+
Just f -> do
10101018
vs <- readSTRef tvarUndo
10111019
v <- readSTRef tvarCurrent
10121020
case (new, vs) of
1013-
(True, _) ->
1014-
Just . toDyn <$> f Nothing v
1015-
(_, _:_) ->
1016-
Just . toDyn <$> f (Just $ last vs) v
1021+
(True, _) -> f Nothing v
1022+
(_, _:_) -> f (Just $ last vs) v
10171023
_ -> error "traceTVarST: unexpected tvar state"
10181024

10191025

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

Lines changed: 5 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -9,9 +9,8 @@ module Control.Monad.IOSim.STM where
99

1010
import Control.Monad.Class.MonadSTM (MonadSTM (..),
1111
MonadInspectSTM (..), MonadLabelledSTM (..),
12-
MonadTraceSTM (..))
12+
MonadTraceSTM (..), TraceValue (..))
1313

14-
import Data.Typeable (Typeable)
1514
import Numeric.Natural (Natural)
1615

1716
--
@@ -26,12 +25,10 @@ labelTQueueDefault
2625
labelTQueueDefault (TQueue queue) label = labelTVar queue label
2726

2827
traceTQueueDefault
29-
:: ( MonadTraceSTM m
30-
, Typeable tr
31-
)
28+
:: MonadTraceSTM m
3229
=> proxy m
3330
-> TQueueDefault m a
34-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
31+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
3532
-> STM m ()
3633
traceTQueueDefault p (TQueue queue) f =
3734
traceTVar p queue
@@ -101,12 +98,10 @@ labelTBQueueDefault
10198
labelTBQueueDefault (TBQueue queue _size) label = labelTVar queue label
10299

103100
traceTBQueueDefault
104-
:: ( MonadTraceSTM m
105-
, Typeable tr
106-
)
101+
:: MonadTraceSTM m
107102
=> proxy m
108103
-> TBQueueDefault m a
109-
-> (Maybe [a] -> [a] -> InspectMonad m tr)
104+
-> (Maybe [a] -> [a] -> InspectMonad m TraceValue)
110105
-> STM m ()
111106
traceTBQueueDefault p (TBQueue queue _size) f =
112107
traceTVar p queue (\mas as -> f (g <$> mas) (g as))

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

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ import Control.Monad.Class.MonadTime
8282
import Control.Monad.Class.MonadTimer
8383
import Control.Monad.Class.MonadEventlog
8484
import Control.Monad.Class.MonadSTM (MonadSTM, MonadInspectSTM (..),
85-
MonadLabelledSTM (..), MonadTraceSTM (..), TMVarDefault)
85+
MonadLabelledSTM (..), MonadTraceSTM (..), TMVarDefault, TraceValue)
8686
import qualified Control.Monad.Class.MonadSTM as MonadSTM
8787
import Control.Monad.Class.MonadST
8888
import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)
@@ -186,9 +186,9 @@ data StmA s a where
186186

187187
SayStm :: String -> StmA s b -> StmA s b
188188
OutputStm :: Dynamic -> StmA s b -> StmA s b
189-
TraceTVar :: forall s a b tr. Typeable tr
190-
=> TVar s a
191-
-> (Maybe a -> a -> ST s tr)
189+
TraceTVar :: forall s a b.
190+
TVar s a
191+
-> (Maybe a -> a -> ST s TraceValue)
192192
-> StmA s b -> StmA s b
193193

194194
-- Exported type
@@ -440,6 +440,9 @@ instance MonadInspectSTM (IOSim s) where
440440
-- | This instance adds a trace when a variable was written, just after the
441441
-- stm transaction was committed.
442442
--
443+
-- Traces the first value using dynamic tracing, like 'traceM' does, i.e. with
444+
-- 'EventDynamic'; the string is traced using 'EventSay'.
445+
--
443446
instance MonadTraceSTM (IOSim s) where
444447
traceTVar _ tvar f = STM $ \k -> TraceTVar tvar f (k ())
445448
traceTQueue = traceTQueueDefault
@@ -816,6 +819,7 @@ data StmTxResult s a =
816819
[SomeTVar s] -- ^ read tvars
817820
[SomeTVar s] -- ^ created tvars
818821
[Dynamic]
822+
[String]
819823
TVarId -- updated TVarId name supply
820824

821825
-- | A blocked transaction reports the vars that were read so that the

0 commit comments

Comments
 (0)