Skip to content

Commit 1b5f5cc

Browse files
cootcoot
authored
Merge pull request #117 from input-output-hk/coot/io-sim-changes
IOSim changes
2 parents 38222f6 + d263fc7 commit 1b5f5cc

File tree

6 files changed

+120
-42
lines changed

6 files changed

+120
-42
lines changed

‎io-sim/CHANGELOG.md

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,9 @@
44

55
### Breaking changes
66

7+
* `MainReturn`, `MainException` and the pattern synonyms `TraceMainReturn`,
8+
`TraceMainException` changed their signature. They will now also show the main thread id.
9+
710
#### Breaking changes
811

912
* Renamed `ThreadId` to `IOSimThreadId` to avoid a clash with `ThreadId`
@@ -14,6 +17,7 @@
1417
a constructor for internal failures. This improved error reporting when
1518
there's a bug in `IOSimPOR`. Currently it's only used by some of the
1619
assertions in `IOSimPOR`.
20+
* added pretty printer for `SimResult`, and other pretty printer improvements.
1721

1822
#### Non breaking changes
1923

@@ -29,6 +33,10 @@
2933
{1,2}.2`, a non racy step is printed as `Thread [1,2].2`.
3034
* Fixed trace of calls to the `deschedule` function.
3135
* Exposed `Timeout` type as part of the `newTimeout` API.
36+
* When `explorationDebugLevel` is set, avoid printing the same trace twice.
37+
* Reimplemented `labelTVarIO` and `traceTVarIO` in `ST` monad, which simplifies
38+
trace of these calls.
39+
* Fixed `traceTVar` for `TVar`'s created with `registerDelay`.
3240

3341
## 1.2.0.0
3442

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

Lines changed: 6 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -131,9 +131,9 @@ selectTraceEvents
131131
selectTraceEvents fn =
132132
bifoldr ( \ v _
133133
-> case v of
134-
MainException _ e _ -> throw (FailureException e)
134+
MainException _ _ e _ -> throw (FailureException e)
135135
Deadlock _ threads -> throw (FailureDeadlock threads)
136-
MainReturn _ _ _ -> []
136+
MainReturn _ _ _ _ -> []
137137
Loop -> error "Impossible: selectTraceEvents _ TraceLoop{}"
138138
InternalError msg -> throw (FailureInternal msg)
139139
)
@@ -430,10 +430,10 @@ traceResult strict = unsafePerformIO . eval
430430
go (SimTrace _ _ _ _ t) = eval t
431431
go (SimPORTrace _ _ _ _ _ t) = eval t
432432
go (TraceRacesFound _ t) = eval t
433-
go (TraceMainReturn _ _ tids@(_:_))
433+
go (TraceMainReturn _ _ _ tids@(_:_))
434434
| strict = pure $ Left (FailureSloppyShutdown tids)
435-
go (TraceMainReturn _ x _) = pure $ Right x
436-
go (TraceMainException _ e _) = pure $ Left (FailureException e)
435+
go (TraceMainReturn _ _ x _) = pure $ Right x
436+
go (TraceMainException _ _ e _) = pure $ Left (FailureException e)
437437
go (TraceDeadlock _ threads) = pure $ Left (FailureDeadlock threads)
438438
go TraceLoop{} = error "Impossible: traceResult TraceLoop{}"
439439
go (TraceInternalError msg) = pure $ Left (FailureInternal msg)
@@ -558,9 +558,9 @@ exploreSimTraceST optsf main k =
558558
traceWithRaces <- IOSimPOR.controlSimTraceST (explorationStepTimelimit opts) control main
559559
(readRaces, trace0) <- detachTraceRacesST traceWithRaces
560560
(readSleeperST, trace) <- compareTracesST passingTrace trace0
561+
() <- traceDebugLog (explorationDebugLevel opts) traceWithRaces
561562
conjoinNoCatchST
562563
[ do sleeper <- readSleeperST
563-
() <- traceDebugLog (explorationDebugLevel opts) traceWithRaces
564564
prop <- k passingTrace trace
565565
return $ counterexample ("Schedule control: " ++ show control)
566566
$ counterexample
@@ -580,7 +580,6 @@ exploreSimTraceST optsf main k =
580580
-- node.
581581
races <- catMaybes
582582
<$> (readRaces >>= traverse (cachedST cacheRef) . take limit)
583-
() <- traceDebugLog (explorationDebugLevel opts) traceWithRaces
584583
let branching = length races
585584
-- tabulate "Races explored" (map show races) $
586585
tabulate "Branching factor" [bucket branching]

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

Lines changed: 16 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -211,7 +211,7 @@ schedule !thread@Thread{
211211
-- the main thread is done, so we're done
212212
-- even if other threads are still running
213213
return $ SimTrace time tid tlbl EventThreadFinished
214-
$ TraceMainReturn time x (labelledThreads threads)
214+
$ TraceMainReturn time (Labelled tid tlbl) x (labelledThreads threads)
215215

216216
ForkFrame -> do
217217
-- this thread is done
@@ -278,7 +278,7 @@ schedule !thread@Thread{
278278
-- An unhandled exception in the main thread terminates the program
279279
return (SimTrace time tid tlbl (EventThrow e) $
280280
SimTrace time tid tlbl (EventThreadUnhandled e) $
281-
TraceMainException time e (labelledThreads threads))
281+
TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))
282282

283283
| otherwise -> do
284284
-- An unhandled exception in any other thread terminates the thread
@@ -460,6 +460,9 @@ schedule !thread@Thread{
460460
let !timers' = PSQ.delete tmid timers
461461
!thread' = thread { threadControl = ThreadControl k ctl }
462462
!written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)
463+
-- note: we are not running traceTVar on 'tvar', since its not exposed to
464+
-- the user, and thus it cannot have an attached callback.
465+
!_ <- traverse_ (\(SomeTVar tvar') -> commitTVar tvar') written
463466
(wakeup, wokeby) <- threadsUnblockedByWrites written
464467
mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written
465468
let (unblocked,
@@ -769,6 +772,10 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } =
769772
-- Reuse the STM functionality here to write all the timer TVars.
770773
-- Simplify to a special case that only reads and writes TVars.
771774
!written <- execAtomically' (runSTM $ mapM_ timeoutSTMAction fired)
775+
!ds <- traverse (\(SomeTVar tvar) -> do
776+
tr <- traceTVarST tvar False
777+
!_ <- commitTVar tvar
778+
return tr) written
772779
(wakeupSTM, wokeby) <- threadsUnblockedByWrites written
773780
!_ <- mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
774781

@@ -794,6 +801,10 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } =
794801
++ [ ( time', ThreadId [-1], Just "register delay timer"
795802
, EventRegisterDelayFired tmid)
796803
| (tmid, TimerRegisterDelay _) <- zip tmids fired ]
804+
++ [ (time', ThreadId [-1], Just "register delay timer", EventLog (toDyn a))
805+
| TraceValue { traceDynamic = Just a } <- ds ]
806+
++ [ (time', ThreadId [-1], Just "register delay timer", EventSay a)
807+
| TraceValue { traceString = Just a } <- ds ]
797808
++ [ (time', tid', tlbl', EventTxWakeup vids)
798809
| tid' <- wakeupSTM
799810
, let tlbl' = lookupThreadLabel tid' threads
@@ -809,6 +820,7 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } =
809820
| (tid, _, _) <- timeoutExpired ])
810821
trace
811822
where
823+
timeoutSTMAction :: TimerCompletionInfo s -> STM s ()
812824
timeoutSTMAction (Timer var) = do
813825
x <- readTVar var
814826
case x of
@@ -1244,7 +1256,6 @@ execAtomically' = go Map.empty
12441256
-> ST s [SomeTVar s]
12451257
go !written action = case action of
12461258
ReturnStm () -> do
1247-
!_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar) written
12481259
return (Map.elems written)
12491260
ReadTVar v k -> do
12501261
x <- execReadTVar v
@@ -1322,7 +1333,7 @@ readTVarUndos TVar{tvarUndo} = readSTRef tvarUndo
13221333
traceTVarST :: TVar s a
13231334
-> Bool -- true if it's a new 'TVar'
13241335
-> ST s TraceValue
1325-
traceTVarST TVar{tvarCurrent, tvarUndo, tvarTrace} new = do
1336+
traceTVarST TVar{tvarId, tvarCurrent, tvarUndo, tvarTrace} new = do
13261337
mf <- readSTRef tvarTrace
13271338
case mf of
13281339
Nothing -> return TraceValue { traceDynamic = (Nothing :: Maybe ())
@@ -1333,7 +1344,7 @@ traceTVarST TVar{tvarCurrent, tvarUndo, tvarTrace} new = do
13331344
case (new, vs) of
13341345
(True, _) -> f Nothing v
13351346
(_, _:_) -> f (Just $ last vs) v
1336-
_ -> error "traceTVarST: unexpected tvar state"
1347+
_ -> error ("traceTVarST: unexpected tvar state " ++ show tvarId)
13371348

13381349

13391350

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

Lines changed: 66 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -133,6 +133,7 @@ import Control.Monad.IOSimPOR.Types
133133

134134

135135
import qualified System.IO.Error as IO.Error (userError)
136+
import Data.List (intercalate)
136137

137138
{-# ANN module "HLint: ignore Use readTVarIO" #-}
138139
newtype IOSim s a = IOSim { unIOSim :: forall r. (a -> SimA s r) -> SimA s r }
@@ -468,6 +469,10 @@ instance MonadSay (STMSim s) where
468469

469470
instance MonadLabelledSTM (IOSim s) where
470471
labelTVar tvar label = STM $ \k -> LabelTVar label tvar (k ())
472+
labelTVarIO tvar label = IOSim $ oneShot $ \k ->
473+
LiftST ( lazyToStrictST $
474+
writeSTRef (tvarLabel tvar) $! (Just label)
475+
) k
471476
labelTQueue = labelTQueueDefault
472477
labelTBQueue = labelTBQueueDefault
473478

@@ -552,6 +557,10 @@ instance MonadInspectSTM (IOSim s) where
552557
--
553558
instance MonadTraceSTM (IOSim s) where
554559
traceTVar _ tvar f = STM $ \k -> TraceTVar tvar f (k ())
560+
traceTVarIO tvar f = IOSim $ oneShot $ \k ->
561+
LiftST ( lazyToStrictST $
562+
writeSTRef (tvarTrace tvar) $! Just f
563+
) k
555564
traceTQueue = traceTQueueDefault
556565
traceTBQueue = traceTBQueueDefault
557566

@@ -799,9 +808,9 @@ ppSimEvent _ _ _ (SimRacesFound controls) =
799808

800809
-- | A result type of a simulation.
801810
data SimResult a
802-
= MainReturn !Time a ![Labelled IOSimThreadId]
811+
= MainReturn !Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
803812
-- ^ Return value of the main thread.
804-
| MainException !Time SomeException ![Labelled IOSimThreadId]
813+
| MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
805814
-- ^ Exception thrown by the main thread.
806815
| Deadlock !Time ![Labelled IOSimThreadId]
807816
-- ^ Deadlock discovered in the simulation. Deadlocks are discovered if
@@ -813,6 +822,47 @@ data SimResult a
813822
| InternalError String
814823
deriving (Show, Functor)
815824

825+
ppSimResult :: Show a
826+
=> Int
827+
-> Int
828+
-> Int
829+
-> SimResult a
830+
-> String
831+
ppSimResult timeWidth tidWidth thLabelWidth r = case r of
832+
MainReturn (Time time) tid a tids ->
833+
printf "%-*s - %-*s %-*s - %s %s"
834+
timeWidth
835+
(show time)
836+
tidWidth
837+
(ppIOSimThreadId (l_labelled tid))
838+
thLabelWidth
839+
(fromMaybe "" $ l_label tid)
840+
("MainReturn " ++ show a)
841+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
842+
MainException (Time time) tid e tids ->
843+
printf "%-*s - %-*s %-*s - %s %s"
844+
timeWidth
845+
(show time)
846+
tidWidth
847+
(ppIOSimThreadId (l_labelled tid))
848+
thLabelWidth
849+
(fromMaybe "" $ l_label tid)
850+
("MainException " ++ show e)
851+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
852+
Deadlock (Time time) tids ->
853+
printf "%-*s - %-*s %-*s - %s %s"
854+
timeWidth
855+
(show time)
856+
tidWidth
857+
""
858+
thLabelWidth
859+
""
860+
"Deadlock"
861+
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
862+
Loop -> "<<io-sim-por: step execution exceded explorationStepTimelimit>>"
863+
InternalError e -> "<<io-sim internal error: " ++ show e ++ ">>"
864+
865+
816866
-- | A type alias for 'IOSim' simulation trace. It comes with useful pattern
817867
-- synonyms.
818868
--
@@ -822,21 +872,21 @@ type SimTrace a = Trace.Trace (SimResult a) SimEvent
822872
--
823873
ppTrace :: Show a => SimTrace a -> String
824874
ppTrace tr = Trace.ppTrace
825-
show
826-
(ppSimEvent timeWidth tidWith labelWidth)
875+
(ppSimResult timeWidth tidWidth labelWidth)
876+
(ppSimEvent timeWidth tidWidth labelWidth)
827877
tr
828878
where
829-
(Max timeWidth, Max tidWith, Max labelWidth) =
879+
(Max timeWidth, Max tidWidth, Max labelWidth) =
830880
bimaximum
831881
. bimap (const (Max 0, Max 0, Max 0))
832882
(\a -> case a of
833-
SimEvent {seTime, seThreadId, seThreadLabel} ->
834-
( Max (length (show seTime))
883+
SimEvent {seTime = Time time, seThreadId, seThreadLabel} ->
884+
( Max (length (show time))
835885
, Max (length (show (seThreadId)))
836886
, Max (length seThreadLabel)
837887
)
838-
SimPOREvent {seTime, seThreadId, seThreadLabel} ->
839-
( Max (length (show seTime))
888+
SimPOREvent {seTime = Time time, seThreadId, seThreadLabel} ->
889+
( Max (length (show time))
840890
, Max (length (show (seThreadId)))
841891
, Max (length seThreadLabel)
842892
)
@@ -851,10 +901,10 @@ ppTrace tr = Trace.ppTrace
851901
ppTrace_ :: SimTrace a -> String
852902
ppTrace_ tr = Trace.ppTrace
853903
(const "")
854-
(ppSimEvent timeWidth tidWith labelWidth)
904+
(ppSimEvent timeWidth tidWidth labelWidth)
855905
tr
856906
where
857-
(Max timeWidth, Max tidWith, Max labelWidth) =
907+
(Max timeWidth, Max tidWidth, Max labelWidth) =
858908
bimaximum
859909
. bimap (const (Max 0, Max 0, Max 0))
860910
(\a -> case a of
@@ -902,13 +952,13 @@ pattern TraceRacesFound controls trace =
902952
Trace.Cons (SimRacesFound controls)
903953
trace
904954

905-
pattern TraceMainReturn :: Time -> a -> [Labelled IOSimThreadId]
955+
pattern TraceMainReturn :: Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
906956
-> SimTrace a
907-
pattern TraceMainReturn time a threads = Trace.Nil (MainReturn time a threads)
957+
pattern TraceMainReturn time tid a threads = Trace.Nil (MainReturn time tid a threads)
908958

909-
pattern TraceMainException :: Time -> SomeException -> [Labelled IOSimThreadId]
959+
pattern TraceMainException :: Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
910960
-> SimTrace a
911-
pattern TraceMainException time err threads = Trace.Nil (MainException time err threads)
961+
pattern TraceMainException time tid err threads = Trace.Nil (MainException time tid err threads)
912962

913963
pattern TraceDeadlock :: Time -> [Labelled IOSimThreadId]
914964
-> SimTrace a
@@ -1124,7 +1174,7 @@ ppSimEventType = \case
11241174
concat [ "Effect ",
11251175
ppVectorClock clock, " ",
11261176
ppEffect eff ]
1127-
EventRaces a -> "Races " ++ show a
1177+
EventRaces a -> show a
11281178

11291179
-- | A labelled value.
11301180
--

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

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -314,10 +314,11 @@ schedule thread@Thread{
314314
-- even if other threads are still running
315315
return $ SimPORTrace time tid tstep tlbl EventThreadFinished
316316
$ traceFinalRacesFound simstate
317-
$ TraceMainReturn time x ( labelledThreads
318-
. Map.filter (not . isThreadDone)
319-
$ threads
320-
)
317+
$ TraceMainReturn time (Labelled tid tlbl) x
318+
( labelledThreads
319+
. Map.filter (not . isThreadDone)
320+
$ threads
321+
)
321322

322323
ForkFrame -> do
323324
-- this thread is done
@@ -397,7 +398,7 @@ schedule thread@Thread{
397398
return (SimPORTrace time tid tstep tlbl (EventThrow e) $
398399
SimPORTrace time tid tstep tlbl (EventThreadUnhandled e) $
399400
traceFinalRacesFound simstate { threads = Map.insert tid thread' threads } $
400-
TraceMainException time e (labelledThreads threads))
401+
TraceMainException time (Labelled tid tlbl) e (labelledThreads threads))
401402

402403
| otherwise -> do
403404
-- An unhandled exception in any other thread terminates the thread
@@ -1021,6 +1022,10 @@ reschedule simstate@SimState{ threads, timers, curTime = time, races } =
10211022
-- Reuse the STM functionality here to write all the timer TVars.
10221023
-- Simplify to a special case that only reads and writes TVars.
10231024
written <- execAtomically' (runSTM $ mapM_ timeoutAction fired)
1025+
!ds <- traverse (\(SomeTVar tvar) -> do
1026+
tr <- traceTVarST tvar False
1027+
!_ <- commitTVar tvar
1028+
return tr) written
10241029
(wakeupSTM, wokeby) <- threadsUnblockedByWrites written
10251030
mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
10261031

@@ -1046,6 +1051,10 @@ reschedule simstate@SimState{ threads, timers, curTime = time, races } =
10461051
++ [ ( time', ThreadId [-1], -1, Just "register delay timer"
10471052
, EventRegisterDelayFired tmid)
10481053
| (tmid, TimerRegisterDelay _) <- zip tmids fired ]
1054+
++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventLog (toDyn a))
1055+
| TraceValue { traceDynamic = Just a } <- ds ]
1056+
++ [ (time', ThreadId [-1], -1, Just "register delay timer", EventSay a)
1057+
| TraceValue { traceString = Just a } <- ds ]
10491058
++ [ (time', tid', -1, tlbl', EventTxWakeup vids)
10501059
| tid' <- wakeupSTM
10511060
, let tlbl' = lookupThreadLabel tid' threads
@@ -1742,7 +1751,7 @@ updateRaces thread@Thread { threadId = tid }
17421751
concurrent0 =
17431752
Map.keysSet (Map.filter (\t -> not (isThreadDone t)
17441753
&& threadId t `Set.notMember`
1745-
effectForks (stepEffect newStep)
1754+
effectForks newEffect
17461755
) threads)
17471756

17481757
-- A new step to add to the `activeRaces` list.
@@ -1932,7 +1941,7 @@ stepInfoToScheduleMods
19321941
{ scheduleModTarget = stepStepId step
19331942
, scheduleModControl = control
19341943
, scheduleModInsertion = takeWhile (/=stepStepId step')
1935-
(map stepStepId (reverse nondep))
1944+
(stepStepId `map` reverse nondep)
19361945
++ [stepStepId step']
19371946
-- It should be unnecessary to include the delayed
19381947
-- step in the insertion, since the default

0 commit comments

Comments
 (0)