Skip to content

Commit 1c036f9

Browse files
cootcoot
committed
io-sim-por: expand tracing of IOSimPOR events
* trace descheduling events * trace schedule control events * trace reschedule event (only when we are following a new schedule, `ControlFollow`)
1 parent e840ca0 commit 1c036f9

File tree

8 files changed

+283
-172
lines changed

8 files changed

+283
-172
lines changed

‎io-sim/io-sim.cabal

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,10 +28,12 @@ library
2828
exposed-modules: Data.List.Trace,
2929
Control.Monad.IOSim,
3030
Control.Monad.IOSim.Types
31-
other-modules: Control.Monad.IOSim.Internal,
31+
other-modules: Control.Monad.IOSim.CommonTypes,
32+
Control.Monad.IOSim.Internal,
3233
Control.Monad.IOSim.InternalTypes,
3334
Control.Monad.IOSim.STM,
3435
Control.Monad.IOSimPOR.Internal,
36+
Control.Monad.IOSimPOR.Types,
3537
Control.Monad.IOSimPOR.QuickCheckUtils,
3638
Control.Monad.IOSimPOR.Timeout
3739
default-language: Haskell2010
@@ -53,6 +55,7 @@ library
5355
parallel,
5456
pretty-simple,
5557
psqueues >=0.2 && <0.3,
58+
text,
5659
time >=1.9.1 && <1.11,
5760
quiet,
5861
QuickCheck,

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ module Control.Monad.IOSim
1616
, runSimTrace
1717
, controlSimTrace
1818
, exploreSimTrace
19+
, ScheduleMod (..)
1920
, ScheduleControl (..)
2021
, runSimTraceST
2122
, liftST

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

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE StandaloneDeriving #-}
5+
6+
-- | Common types shared between `IOSim` and `IOSimPOR`.
7+
--
8+
module Control.Monad.IOSim.CommonTypes where
9+
10+
import Control.Exception (Exception)
11+
import Control.Monad.Class.MonadThrow (MaskingState (..))
12+
import Control.Monad.ST.Lazy
13+
14+
import Data.Function (on)
15+
import Data.Map (Map)
16+
import Data.Set (Set)
17+
import Data.STRef.Lazy
18+
import Data.Typeable (Typeable)
19+
20+
data ThreadId = RacyThreadId [Int]
21+
| ThreadId [Int] -- non racy threads have higher priority
22+
deriving (Eq, Ord, Show)
23+
24+
childThreadId :: ThreadId -> Int -> ThreadId
25+
childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])
26+
childThreadId (ThreadId is) i = ThreadId (is ++ [i])
27+
28+
setRacyThread :: ThreadId -> ThreadId
29+
setRacyThread (ThreadId is) = RacyThreadId is
30+
setRacyThread tid@RacyThreadId{} = tid
31+
32+
33+
newtype TVarId = TVarId Int deriving (Eq, Ord, Enum, Show)
34+
newtype TimeoutId = TimeoutId Int deriving (Eq, Ord, Enum, Show)
35+
newtype ClockId = ClockId [Int] deriving (Eq, Ord, Show)
36+
newtype VectorClock = VectorClock { getVectorClock :: Map ThreadId Int }
37+
deriving Show
38+
39+
unTimeoutId :: TimeoutId -> Int
40+
unTimeoutId (TimeoutId a) = a
41+
42+
type ThreadLabel = String
43+
type TVarLabel = String
44+
45+
data TVar s a = TVar {
46+
47+
-- | The identifier of this var.
48+
--
49+
tvarId :: !TVarId,
50+
51+
-- | Label.
52+
tvarLabel :: !(STRef s (Maybe TVarLabel)),
53+
54+
-- | The var's current value
55+
--
56+
tvarCurrent :: !(STRef s a),
57+
58+
-- | A stack of undo values. This is only used while executing a
59+
-- transaction.
60+
--
61+
tvarUndo :: !(STRef s [a]),
62+
63+
-- | Thread Ids of threads blocked on a read of this var. It is
64+
-- represented in reverse order of thread wakeup, without duplicates.
65+
--
66+
-- To avoid duplicates efficiently, the operations rely on a copy of the
67+
-- thread Ids represented as a set.
68+
--
69+
tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId)),
70+
71+
-- | The vector clock of the current value.
72+
--
73+
tvarVClock :: !(STRef s VectorClock),
74+
75+
-- | Callback to construct a trace which will be attached to the dynamic
76+
-- trace.
77+
tvarTrace :: !(STRef s (Maybe (MkTVarTrace s a)))
78+
}
79+
80+
instance Eq (TVar s a) where
81+
(==) = on (==) tvarId
82+
83+
data MkTVarTrace s a where
84+
MkTVarTrace :: forall s a tr. Typeable tr => (Maybe a -> a -> ST s tr)
85+
-> MkTVarTrace s a
86+
87+
data SomeTVar s where
88+
SomeTVar :: !(TVar s a) -> SomeTVar s
89+
90+
data Deschedule = Yield | Interruptable | Blocked | Terminated | Sleep
91+
deriving Show

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ import Control.Monad.Class.MonadThrow hiding (getMaskingState)
7979
import Control.Monad.Class.MonadTime
8080
import Control.Monad.Class.MonadTimer
8181

82-
import Control.Monad.IOSim.Types
82+
import Control.Monad.IOSim.Types hiding (Deschedule (..))
8383
import Control.Monad.IOSim.InternalTypes
8484

8585
--
@@ -413,7 +413,8 @@ schedule thread@Thread{
413413
-- as it is a fair policy (all runnable threads eventually run).
414414
trace <- deschedule Yield thread' simstate' { nextVid = nextVid' }
415415
return $
416-
SimTrace time tid tlbl (EventTxCommitted vids [nextVid..pred nextVid']) $
416+
SimTrace time tid tlbl (EventTxCommitted vids [nextVid..pred nextVid']
417+
Nothing) $
417418
traceMany
418419
[ (time, tid', tlbl', EventTxWakeup vids')
419420
| tid' <- unblocked
@@ -429,13 +430,13 @@ schedule thread@Thread{
429430
-- schedule this thread to immediately raise the exception
430431
let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
431432
trace <- schedule thread' simstate
432-
return $ SimTrace time tid tlbl EventTxAborted trace
433+
return $ SimTrace time tid tlbl (EventTxAborted Nothing) trace
433434

434435
StmTxBlocked read -> do
435436
mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read
436437
vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read
437438
trace <- deschedule Blocked thread simstate
438-
return $ SimTrace time tid tlbl (EventTxBlocked vids) trace
439+
return $ SimTrace time tid tlbl (EventTxBlocked vids Nothing) trace
439440

440441
GetThreadId k -> do
441442
let thread' = thread { threadControl = ThreadControl (k tid) ctl }

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Control.Monad.Class.MonadThrow (MaskingState (..))
1313

1414
import Control.Monad.IOSim.Types (SimA)
1515

16-
1716
-- We hide the type @b@ here, so it's useful to bundle these two parts
1817
-- together, rather than having Thread have an extential type, which
1918
-- makes record updates awkward.

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

Lines changed: 61 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,55 @@
1616
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
1717
{-# OPTIONS_GHC -Wno-partial-fields #-}
1818

19-
module Control.Monad.IOSim.Types where
19+
module Control.Monad.IOSim.Types
20+
( IOSim (..)
21+
, runIOSim
22+
, traceM
23+
, traceSTM
24+
, liftST
25+
, SimA (..)
26+
, StepId
27+
, STMSim
28+
, STM (..)
29+
, runSTM
30+
, StmA (..)
31+
, StmTxResult (..)
32+
, StmStack (..)
33+
, Timeout (..)
34+
, TimeoutException (..)
35+
36+
, setCurrentTime
37+
, unshareClock
38+
39+
, ScheduleControl (..)
40+
, ScheduleMod (..)
41+
, ExplorationOptions (..)
42+
, ExplorationSpec
43+
, withScheduleBound
44+
, withBranching
45+
, withStepTimelimit
46+
, withReplay
47+
, stdExplorationOptions
48+
49+
, EventlogEvent (..)
50+
, EventlogMarker (..)
51+
52+
, SimEventType (..)
53+
, SimEvent (..)
54+
, SimResult (..)
55+
, SimTrace
56+
, Trace.Trace (Trace, SimTrace, TraceMainReturn, TraceMainException,
57+
TraceDeadlock, TraceRacesFound, TraceLoop)
58+
, ppTrace
59+
, ppTrace_
60+
, ppSimEvent
61+
, TraceEvent
62+
, Labelled (..)
63+
64+
, module Control.Monad.IOSim.CommonTypes
65+
, SimM
66+
, SimSTM
67+
) where
2068

2169
import Control.Exception (ErrorCall (..), asyncExceptionFromException, asyncExceptionToException)
2270
import Control.Applicative
@@ -47,18 +95,20 @@ import Data.Bifoldable
4795
import Data.Bifunctor (bimap)
4896
import Data.Map.Strict (Map)
4997
import Data.Maybe (fromMaybe)
50-
import Data.Set (Set)
98+
import Data.Monoid (Endo (..))
5199
import Data.Dynamic (Dynamic, toDyn)
52-
import Data.Function (on)
53100
import Data.Typeable
54101
import Data.STRef.Lazy
55102
import qualified Data.List.Trace as Trace
103+
import qualified Debug.Trace as Debug
56104
import Text.Printf
57105

58106
import GHC.Generics (Generic)
59107
import Quiet (Quiet (..))
60108

109+
import Control.Monad.IOSim.CommonTypes
61110
import Control.Monad.IOSim.STM
111+
import Control.Monad.IOSimPOR.Types
62112

63113

64114
import qualified System.IO.Error as IO.Error (userError)
@@ -630,8 +680,10 @@ data SimEventType
630680

631681
| EventTxCommitted [Labelled TVarId] -- tx wrote to these
632682
[TVarId] -- and created these
633-
| EventTxAborted
683+
(Maybe Effect) -- effect performed (only for `IOSimPOR`)
684+
| EventTxAborted (Maybe Effect) -- effect performed (only for `IOSimPOR`)
634685
| EventTxBlocked [Labelled TVarId] -- tx blocked reading these
686+
(Maybe Effect) -- effect performed (only for `IOSimPOR`)
635687
| EventTxWakeup [Labelled TVarId] -- changed vars causing retry
636688

637689
| EventTimerCreated TimeoutId TVarId Time
@@ -644,35 +696,16 @@ data SimEventType
644696
| EventThreadSleep -- the labelling thread was runnable,
645697
-- but its execution was delayed
646698
| EventThreadWake -- until this point
699+
| EventDeschedule Deschedule
700+
| EventFollowControl ScheduleControl
701+
| EventAwaitControl StepId ScheduleControl
702+
| EventPerformAction StepId
703+
| EventReschedule ScheduleControl
647704
deriving Show
648705

649706
type TraceEvent = SimEventType
650707
{-# DEPRECATED TraceEvent "Use 'SimEventType' instead." #-}
651708

652-
data ThreadId = RacyThreadId [Int]
653-
| ThreadId [Int] -- non racy threads have higher priority
654-
deriving (Eq, Ord, Show)
655-
656-
childThreadId :: ThreadId -> Int -> ThreadId
657-
childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])
658-
childThreadId (ThreadId is) i = ThreadId (is ++ [i])
659-
660-
setRacyThread :: ThreadId -> ThreadId
661-
setRacyThread (ThreadId is) = RacyThreadId is
662-
setRacyThread tid@RacyThreadId{} = tid
663-
664-
newtype TVarId = TVarId Int deriving (Eq, Ord, Enum, Show)
665-
newtype TimeoutId = TimeoutId Int deriving (Eq, Ord, Enum, Show)
666-
newtype ClockId = ClockId [Int] deriving (Eq, Ord, Show)
667-
newtype VectorClock = VectorClock { getVectorClock :: Map ThreadId Int }
668-
deriving Show
669-
670-
unTimeoutId :: TimeoutId -> Int
671-
unTimeoutId (TimeoutId a) = a
672-
673-
type ThreadLabel = String
674-
type TVarLabel = String
675-
676709
data Labelled a = Labelled {
677710
l_labelled :: !a,
678711
l_label :: !(Maybe String)
@@ -684,49 +717,6 @@ data Labelled a = Labelled {
684717
-- Executing STM Transactions
685718
--
686719

687-
data MkTVarTrace s a where
688-
MkTVarTrace :: forall s a tr. Typeable tr => (Maybe a -> a -> ST s tr)
689-
-> MkTVarTrace s a
690-
691-
692-
data TVar s a = TVar {
693-
694-
-- | The identifier of this var.
695-
--
696-
tvarId :: !TVarId,
697-
698-
-- | Label.
699-
tvarLabel :: !(STRef s (Maybe TVarLabel)),
700-
701-
-- | The var's current value
702-
--
703-
tvarCurrent :: !(STRef s a),
704-
705-
-- | A stack of undo values. This is only used while executing a
706-
-- transaction.
707-
--
708-
tvarUndo :: !(STRef s [a]),
709-
710-
-- | Thread Ids of threads blocked on a read of this var. It is
711-
-- represented in reverse order of thread wakeup, without duplicates.
712-
--
713-
-- To avoid duplicates efficiently, the operations rely on a copy of the
714-
-- thread Ids represented as a set.
715-
--
716-
tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId)),
717-
718-
-- | The vector clock of the current value.
719-
--
720-
tvarVClock :: !(STRef s VectorClock),
721-
722-
-- | Callback to construct a trace which will be attached to the dynamic
723-
-- trace.
724-
tvarTrace :: !(STRef s (Maybe (MkTVarTrace s a)))
725-
}
726-
727-
instance Eq (TVar s a) where
728-
(==) = on (==) tvarId
729-
730720
data StmTxResult s a =
731721
-- | A committed transaction reports the vars that were written (in order
732722
-- of first write) so that the scheduler can unblock other threads that
@@ -756,9 +746,6 @@ data StmTxResult s a =
756746
--
757747
| StmTxAborted [SomeTVar s] SomeException
758748

759-
data SomeTVar s where
760-
SomeTVar :: !(TVar s a) -> SomeTVar s
761-
762749
data StmStack s b a where
763750
-- | Executing in the context of a top level 'atomically'.
764751
AtomicallyFrame :: StmStack s a a

0 commit comments

Comments
 (0)