Skip to content

Commit bcfd34f

Browse files
cootcoot
committed
io-sim-por: SimPORTrace
Include step into simulation trace, but only for 'IOSimPOR'. This is useful for identifying scheduling issues.
1 parent 0943b64 commit bcfd34f

File tree

5 files changed

+137
-89
lines changed

5 files changed

+137
-89
lines changed

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

Lines changed: 32 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@ module Control.Monad.IOSim
2727
, unshareClock
2828
-- * Simulation trace
2929
, type SimTrace
30-
, Trace (Cons, Nil, Trace, SimTrace, TraceDeadlock, TraceLoop,
30+
, Trace (Cons, Nil, Trace, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop,
3131
TraceMainReturn, TraceMainException, TraceRacesFound)
3232
, SimResult (..)
3333
, SimEvent (..)
@@ -59,7 +59,7 @@ module Control.Monad.IOSim
5959
, printTraceEventsSay
6060
-- * Exploration options
6161
, ExplorationSpec
62-
, ExplorationOptions
62+
, ExplorationOptions (..)
6363
, stdExplorationOptions
6464
, withScheduleBound
6565
, withBranching
@@ -135,6 +135,7 @@ selectTraceRaces :: SimTrace a -> [ScheduleControl]
135135
selectTraceRaces = go
136136
where
137137
go (SimTrace _ _ _ _ trace) = go trace
138+
go (SimPORTrace _ _ _ _ _ trace) = go trace
138139
go (TraceRacesFound races trace) =
139140
races ++ go trace
140141
go _ = []
@@ -160,9 +161,10 @@ detachTraceRaces trace = unsafePerformIO $ do
160161
saveRaces r t = unsafePerformIO $ do
161162
modifyIORef races (r:)
162163
return t
163-
let go (SimTrace a b c d trace) = SimTrace a b c d $ go trace
164-
go (TraceRacesFound r trace) = saveRaces r $ go trace
165-
go t = t
164+
let go (SimTrace a b c d trace) = SimTrace a b c d $ go trace
165+
go (SimPORTrace a b c d e trace) = SimPORTrace a b c d e $ go trace
166+
go (TraceRacesFound r trace) = saveRaces r $ go trace
167+
go t = t
166168
return (readRaces,go trace)
167169

168170
-- | Select all the traced values matching the expected type. This relies on
@@ -230,6 +232,10 @@ traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v )
230232
case fn (seType eventCtx) of
231233
Nothing -> acc
232234
Just b -> Cons b acc
235+
SimPOREvent{} ->
236+
case fn (seType eventCtx) of
237+
Nothing -> acc
238+
Just b -> Cons b acc
233239
)
234240
undefined -- it is ignored
235241

@@ -306,6 +312,7 @@ traceResult :: Bool -> SimTrace a -> Either Failure a
306312
traceResult strict = go
307313
where
308314
go (SimTrace _ _ _ _ t) = go t
315+
go (SimPORTrace _ _ _ _ _ t) = go t
309316
go (TraceRacesFound _ t) = go t
310317
go (TraceMainReturn _ _ tids@(_:_))
311318
| strict = Left (FailureSloppyShutdown tids)
@@ -315,9 +322,11 @@ traceResult strict = go
315322
go TraceLoop{} = error "Impossible: traceResult TraceLoop{}"
316323

317324
traceEvents :: SimTrace a -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
318-
traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)
319-
: traceEvents t
320-
traceEvents _ = []
325+
traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)
326+
: traceEvents t
327+
traceEvents (SimPORTrace time tid _ tlbl event t) = (time, tid, tlbl, event)
328+
: traceEvents t
329+
traceEvents _ = []
321330

322331

323332
ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
@@ -462,23 +471,28 @@ compareTraces (Just passing) trace = unsafePerformIO $ do
462471
sleeper <- newIORef Nothing
463472
return (unsafePerformIO $ readIORef sleeper,
464473
go sleeper passing trace)
465-
where go sleeper (SimTrace tpass tidpass _ _ pass')
466-
(SimTrace tfail tidfail tlfail evfail fail')
474+
where go sleeper (SimPORTrace tpass tidpass _ _ _ pass')
475+
(SimPORTrace tfail tidfail tstepfail tlfail evfail fail')
467476
| (tpass,tidpass) == (tfail,tidfail) =
468-
SimTrace tfail tidfail tlfail evfail $
469-
go sleeper pass' fail'
470-
go sleeper (SimTrace tpass tidpass tlpass _ _) fail =
477+
SimPORTrace tfail tidfail tstepfail tlfail evfail
478+
$ go sleeper pass' fail'
479+
go sleeper (SimPORTrace tpass tidpass tsteppass tlpass _ _) fail =
471480
unsafePerformIO $ do
472481
writeIORef sleeper $ Just ((tpass, tidpass, tlpass),Set.empty)
473-
return $ SimTrace tpass tidpass tlpass EventThreadSleep $
474-
wakeup sleeper tidpass fail
482+
return $ SimPORTrace tpass tidpass tsteppass tlpass EventThreadSleep
483+
$ wakeup sleeper tidpass fail
484+
go _ SimTrace {} _ = error "compareTraces: invariant violation"
485+
go _ _ SimTrace {} = error "compareTraces: invariant violation"
475486
go _ _ fail = fail
476-
wakeup sleeper tidpass fail@(SimTrace tfail tidfail tlfail evfail fail')
487+
488+
wakeup sleeper tidpass
489+
fail@(SimPORTrace tfail tidfail tstepfail tlfail evfail fail')
477490
| tidpass == tidfail =
478-
SimTrace tfail tidfail tlfail EventThreadWake fail
491+
SimPORTrace tfail tidfail tstepfail tlfail EventThreadWake fail
479492
| otherwise = unsafePerformIO $ do
480493
Just (slp,racing) <- readIORef sleeper
481494
writeIORef sleeper $ Just (slp,Set.insert (tidfail,tlfail) racing)
482-
return $ SimTrace tfail tidfail tlfail evfail
495+
return $ SimPORTrace tfail tidfail tstepfail tlfail evfail
483496
$ wakeup sleeper tidpass fail'
497+
wakeup _ _ SimTrace {} = error "compareTraces: invariant violation"
484498
wakeup _ _ fail = fail

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

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

10-
import Control.Exception (Exception)
11-
import Control.Monad.Class.MonadThrow (MaskingState (..))
1210
import Control.Monad.ST.Lazy
1311

1412
import Data.Function (on)

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,9 @@ 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 (SimEvent)
83+
import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),
84+
Trace(SimPORTrace))
8385
import Control.Monad.IOSim.InternalTypes
8486

8587
--

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

Lines changed: 28 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ module Control.Monad.IOSim.Types
5353
, SimEvent (..)
5454
, SimResult (..)
5555
, SimTrace
56-
, Trace.Trace (Trace, SimTrace, TraceMainReturn, TraceMainException,
56+
, Trace.Trace (Trace, SimTrace, SimPORTrace, TraceMainReturn, TraceMainException,
5757
TraceDeadlock, TraceRacesFound, TraceLoop)
5858
, ppTrace
5959
, ppTrace_
@@ -576,13 +576,21 @@ data SimEvent
576576
seThreadLabel :: !(Maybe ThreadLabel),
577577
seType :: !SimEventType
578578
}
579+
| SimPOREvent {
580+
seTime :: !Time,
581+
seThreadId :: !ThreadId,
582+
seStep :: !Int,
583+
seThreadLabel :: !(Maybe ThreadLabel),
584+
seType :: !SimEventType
585+
}
579586
| SimRacesFound [ScheduleControl]
580587
deriving Generic
581588
deriving Show via Quiet SimEvent
582589

583590
seThreadLabel' :: SimEvent -> Maybe ThreadLabel
584-
seThreadLabel' SimEvent {seThreadLabel} = seThreadLabel
585-
seThreadLabel' SimRacesFound {} = Nothing
591+
seThreadLabel' SimEvent {seThreadLabel} = seThreadLabel
592+
seThreadLabel' SimPOREvent {seThreadLabel} = seThreadLabel
593+
seThreadLabel' SimRacesFound {} = Nothing
586594

587595
ppSimEvent :: Int -- ^ width of thread label
588596
-> SimEvent
@@ -596,6 +604,15 @@ ppSimEvent d SimEvent {seTime, seThreadId, seThreadLabel, seType} =
596604
(show seType)
597605
where
598606
threadLabel = fromMaybe "" seThreadLabel
607+
ppSimEvent d SimPOREvent {seTime, seThreadId, seStep, seThreadLabel, seType} =
608+
printf "%-24s - %-13s %-*s - %s"
609+
(show seTime)
610+
(show (seThreadId, seStep))
611+
d
612+
threadLabel
613+
(show seType)
614+
where
615+
threadLabel = fromMaybe "" seThreadLabel
599616
ppSimEvent _ (SimRacesFound controls) =
600617
"RacesFound "++show controls
601618

@@ -647,6 +664,12 @@ pattern SimTrace time threadId threadLabel traceEvent trace =
647664
Trace.Cons (SimEvent time threadId threadLabel traceEvent)
648665
trace
649666

667+
pattern SimPORTrace :: Time -> ThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
668+
-> SimTrace a
669+
pattern SimPORTrace time threadId step threadLabel traceEvent trace =
670+
Trace.Cons (SimPOREvent time threadId step threadLabel traceEvent)
671+
trace
672+
650673
pattern TraceRacesFound :: [ScheduleControl] -> SimTrace a
651674
-> SimTrace a
652675
pattern TraceRacesFound controls trace =
@@ -668,8 +691,8 @@ pattern TraceDeadlock time threads = Trace.Nil (Deadlock time threads)
668691
pattern TraceLoop :: SimTrace a
669692
pattern TraceLoop = Trace.Nil Loop
670693

671-
{-# COMPLETE SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-}
672-
{-# COMPLETE Trace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-}
694+
{-# COMPLETE SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-}
695+
{-# COMPLETE Trace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-}
673696

674697

675698
data SimEventType

0 commit comments

Comments
 (0)