Merge pull request #208 from input-output-hk/coot/io-sim-si-timers-import

io-sim: qualified import of si-timers library

Author: coot

io-classes/src/Control/Monad/Class/MonadFork.hs

@@ -43,16 +43,18 @@ labelThisThread label = myThreadId >>= \tid -> labelThread tid label
 
 class MonadThread m => MonadFork m where
 
-  forkIO           :: m () -> m (ThreadId m)
-  forkOn           :: Int -> m () -> m (ThreadId m)
-  forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
-  forkFinally      :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
-  throwTo          :: Exception e => ThreadId m -> e -> m ()
+  forkIO             :: m () -> m (ThreadId m)
+  forkOn             :: Int -> m () -> m (ThreadId m)
+  forkIOWithUnmask   :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
+  forkFinally        :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
+  throwTo            :: Exception e => ThreadId m -> e -> m ()
 
-  killThread       :: ThreadId m -> m ()
-  killThread tid = throwTo tid ThreadKilled
+  killThread         :: ThreadId m -> m ()
+  killThread tid     =  throwTo tid ThreadKilled
 
-  yield            :: m ()
+  yield              :: m ()
+
+  getNumCapabilities :: m Int
 
 
 instance MonadThread IO where
@@ -66,13 +68,14 @@ instance MonadThread IO where
 #endif
 
 instance MonadFork IO where
-  forkIO           = IO.forkIO
-  forkOn           = IO.forkOn
-  forkIOWithUnmask = IO.forkIOWithUnmask
-  forkFinally      = IO.forkFinally
-  throwTo          = IO.throwTo
-  killThread       = IO.killThread
-  yield            = IO.yield
+  forkIO             = IO.forkIO
+  forkOn             = IO.forkOn
+  forkIOWithUnmask   = IO.forkIOWithUnmask
+  forkFinally        = IO.forkFinally
+  throwTo            = IO.throwTo
+  killThread         = IO.killThread
+  yield              = IO.yield
+  getNumCapabilities = IO.getNumCapabilities
 
 instance MonadThread m => MonadThread (ReaderT r m) where
   type ThreadId (ReaderT r m) = ThreadId m
@@ -87,7 +90,9 @@ instance MonadFork m => MonadFork (ReaderT e m) where
                          let restore' :: ReaderT e m a -> ReaderT e m a
                              restore' (ReaderT f) = ReaderT $ restore . f
                          in runReaderT (k restore') e
-  forkFinally f k     = ReaderT $ \e -> forkFinally (runReaderT f e)
-                                      $ \err -> runReaderT (k err) e
+  forkFinally f k      = ReaderT $ \e -> forkFinally (runReaderT f e)
+                                       $ \err -> runReaderT (k err) e
   throwTo e t = lift (throwTo e t)
   yield       = lift yield
+
+  getNumCapabilities = lift getNumCapabilities

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

@@ -60,9 +60,9 @@ module Control.Monad.IOSim.Types
   , ppDebug
   , module Control.Monad.IOSim.CommonTypes
   , Thrower (..)
-  , Time (..)
-  , addTime
-  , diffTime
+  , SI.Time (..)
+  , SI.addTime
+  , SI.diffTime
     -- * Internal API
   , Timeout (..)
   , newTimeout
@@ -97,7 +97,8 @@ import Control.Monad.Class.MonadTest
 import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)
 import Control.Monad.Class.MonadThrow qualified as MonadThrow
 import Control.Monad.Class.MonadTime
-import Control.Monad.Class.MonadTime.SI
+import Control.Monad.Class.MonadTime.SI (DiffTime)
+import Control.Monad.Class.MonadTime.SI qualified as SI
 import Control.Monad.Class.MonadTimer
 import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
 import Control.Monad.Class.MonadTimer.SI qualified as SI
@@ -167,7 +168,7 @@ data SimA s a where
 
   LiftST       :: StrictST.ST s a -> (a -> SimA s b) -> SimA s b
 
-  GetMonoTime  :: (Time    -> SimA s b) -> SimA s b
+  GetMonoTime  :: (SI.Time    -> SimA s b) -> SimA s b
   GetWallTime  :: (UTCTime -> SimA s b) -> SimA s b
   SetWallTime  ::  UTCTime -> SimA s b  -> SimA s b
   UnshareClock :: SimA s b -> SimA s b
@@ -479,6 +480,7 @@ instance MonadFork (IOSim s) where
                        forkIO $ try (restore task) >>= k
   throwTo tid e      = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ())
   yield              = IOSim $ oneShot $ \k -> YieldSim (k ())
+  getNumCapabilities = return 1
 
 instance MonadTest (IOSim s) where
   exploreRaces       = IOSim $ oneShot $ \k -> ExploreRaces (k ())
@@ -672,10 +674,10 @@ instance MonadMonotonicTimeNSec (IOSim s) where
   getMonotonicTimeNSec = IOSim $ oneShot $ \k -> GetMonoTime (k . conv)
     where
       -- convert time in picoseconds to nanoseconds
-      conv :: Time -> Word64
-      conv (Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000)
+      conv :: SI.Time -> Word64
+      conv (SI.Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000)
 
-instance MonadMonotonicTime (IOSim s) where
+instance SI.MonadMonotonicTime (IOSim s) where
   getMonotonicTime = IOSim $ oneShot $ \k -> GetMonoTime k
 
 instance MonadTime (IOSim s) where
@@ -788,14 +790,14 @@ instance MonadEventlog (IOSim s) where
 data SimEvent
     -- | Used when using `IOSim`.
   = SimEvent {
-      seTime        :: !Time,
+      seTime        :: !SI.Time,
       seThreadId    :: !IOSimThreadId,
       seThreadLabel :: !(Maybe ThreadLabel),
       seType        :: !SimEventType
     }
     -- | Only used for /IOSimPOR/
   | SimPOREvent {
-      seTime        :: !Time,
+      seTime        :: !SI.Time,
       seThreadId    :: !IOSimThreadId,
       seStep        :: !Int,
       seThreadLabel :: !(Maybe ThreadLabel),
@@ -815,7 +817,7 @@ ppSimEvent :: Int -- ^ width of the time
            -> SimEvent
            -> String
 
-ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThreadId, seThreadLabel, seType} =
+ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = SI.Time time, seThreadId, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
            timeWidth
            (show time)
@@ -825,7 +827,7 @@ ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThread
            (fromMaybe "" seThreadLabel)
            (ppSimEventType seType)
 
-ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThreadId, seStep, seThreadLabel, seType} =
+ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = SI.Time time, seThreadId, seStep, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
            timeWidth
            (show time)
@@ -841,11 +843,11 @@ ppSimEvent _ _ _ (SimRacesFound controls) =
 
 -- | A result type of a simulation.
 data SimResult a
-    = MainReturn    !Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
+    = MainReturn    !SI.Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
     -- ^ Return value of the main thread.
-    | MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
+    | MainException !SI.Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
     -- ^ Exception thrown by the main thread.
-    | Deadlock      !Time ![Labelled IOSimThreadId]
+    | Deadlock      !SI.Time ![Labelled IOSimThreadId]
     -- ^ Deadlock discovered in the simulation.  Deadlocks are discovered if
     -- simply the simulation cannot do any progress in a given time slot and
     -- there's no event which would advance the time.
@@ -863,7 +865,7 @@ ppSimResult :: Show a
             -> SimResult a
             -> String
 ppSimResult timeWidth tidWidth thLabelWidth r = case r of
-    MainReturn (Time time) tid a tids ->
+    MainReturn (SI.Time time) tid a tids ->
       printf "%-*s - %-*s %-*s - %s %s"
              timeWidth
              (show time)
@@ -873,7 +875,7 @@ ppSimResult timeWidth tidWidth thLabelWidth r = case r of
              (fromMaybe "" $ l_label tid)
              ("MainReturn " ++ show a)
              ("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
-    MainException (Time time) tid e tids ->
+    MainException (SI.Time time) tid e tids ->
       printf "%-*s - %-*s %-*s - %s %s"
              timeWidth
              (show time)
@@ -883,7 +885,7 @@ ppSimResult timeWidth tidWidth thLabelWidth r = case r of
              (fromMaybe "" $ l_label tid)
              ("MainException " ++ show e)
              ("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
-    Deadlock (Time time) tids ->
+    Deadlock (SI.Time time) tids ->
       printf "%-*s - %-*s %-*s - %s %s"
              timeWidth
              (show time)
@@ -920,12 +922,12 @@ ppTrace tr = Trace.ppTrace
         bimaximum
       . bimap (const (Max 0, Max 0, Max 0))
               (\a -> case a of
-                SimEvent {seTime = Time time, seThreadId, seThreadLabel} ->
+                SimEvent {seTime = SI.Time time, seThreadId, seThreadLabel} ->
                   ( Max (length (show time))
                   , Max (length (show (seThreadId)))
                   , Max (length seThreadLabel)
                   )
-                SimPOREvent {seTime = Time time, seThreadId, seThreadLabel} ->
+                SimPOREvent {seTime = SI.Time time, seThreadId, seThreadLabel} ->
                   ( Max (length (show time))
                   , Max (length (show (seThreadId)))
                   , Max (length seThreadLabel)
@@ -974,13 +976,13 @@ ppDebug = appEndo
         . Trace.toList
 
 
-pattern SimTrace :: Time -> IOSimThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
+pattern SimTrace :: SI.Time -> IOSimThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
                  -> SimTrace a
 pattern SimTrace time threadId threadLabel traceEvent trace =
     Trace.Cons (SimEvent time threadId threadLabel traceEvent)
                trace
 
-pattern SimPORTrace :: Time -> IOSimThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
+pattern SimPORTrace :: SI.Time -> IOSimThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
                     -> SimTrace a
 pattern SimPORTrace time threadId step threadLabel traceEvent trace =
     Trace.Cons (SimPOREvent time threadId step threadLabel traceEvent)
@@ -992,15 +994,15 @@ pattern TraceRacesFound controls trace =
     Trace.Cons (SimRacesFound controls)
                trace
 
-pattern TraceMainReturn :: Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
+pattern TraceMainReturn :: SI.Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
                         -> SimTrace a
 pattern TraceMainReturn time tid a threads = Trace.Nil (MainReturn time tid a threads)
 
-pattern TraceMainException :: Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
+pattern TraceMainException :: SI.Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
                            -> SimTrace a
 pattern TraceMainException time tid err threads = Trace.Nil (MainException time tid err threads)
 
-pattern TraceDeadlock :: Time -> [Labelled IOSimThreadId]
+pattern TraceDeadlock :: SI.Time -> [Labelled IOSimThreadId]
                       -> SimTrace a
 pattern TraceDeadlock time threads = Trace.Nil (Deadlock time threads)
 
@@ -1066,22 +1068,22 @@ data SimEventType
   -- Timeouts, Timers & Delays
   --
 
-  | EventThreadDelay        TimeoutId Time
+  | EventThreadDelay        TimeoutId SI.Time
   -- ^ thread delayed
   | EventThreadDelayFired   TimeoutId
   -- ^ thread woken up after a delay
 
-  | EventTimeoutCreated        TimeoutId IOSimThreadId Time
+  | EventTimeoutCreated        TimeoutId IOSimThreadId SI.Time
   -- ^ new timeout created (via `timeout`)
   | EventTimeoutFired          TimeoutId
   -- ^ timeout fired
 
-  | EventRegisterDelayCreated TimeoutId TVarId Time
+  | EventRegisterDelayCreated TimeoutId TVarId SI.Time
   -- ^ registered delay (via `registerDelay`)
   | EventRegisterDelayFired TimeoutId
   -- ^ registered delay fired
 
-  | EventTimerCreated         TimeoutId TVarId Time
+  | EventTimerCreated         TimeoutId TVarId SI.Time
   -- ^ a new 'Timeout' created (via `newTimeout`)
   | EventTimerCancelled       TimeoutId
   -- ^ a 'Timeout' was cancelled (via `cancelTimeout`)

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

@@ -80,11 +80,14 @@ import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)
 import Control.Monad.Class.MonadSTM hiding (STM)
 import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))
 import Control.Monad.Class.MonadThrow as MonadThrow
-import Control.Monad.Class.MonadTime
+import Control.Monad.Class.MonadTime (NominalDiffTime)
+import Control.Monad.Class.MonadTime qualified as Time
+import Control.Monad.Class.MonadTime.SI qualified as SI
 import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
 
 import Control.Monad.IOSim.InternalTypes
-import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Trace (SimTrace))
+import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Time (..),
+           Trace (SimTrace))
 import Control.Monad.IOSim.Types (SimEvent)
 import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)
 import Control.Monad.IOSimPOR.Types
@@ -186,7 +189,7 @@ data TimerCompletionInfo s =
 instance Hashable a => Hashable (Down a)
 
 type RunQueue   = HashPSQ (Down IOSimThreadId) (Down IOSimThreadId) ()
-type Timeouts s = IntPSQ Time (TimerCompletionInfo s)
+type Timeouts s = IntPSQ SI.Time (TimerCompletionInfo s)
 
 -- | Internal state.
 --
@@ -196,7 +199,7 @@ data SimState s a = SimState {
        -- and blocked threads.
        threads          :: !(Map IOSimThreadId (Thread s a)),
        -- | current time
-       curTime          :: !Time,
+       curTime          :: !SI.Time,
        -- | ordered list of timers and timeouts
        timers           :: !(Timeouts s),
        -- | timeout locks in order to synchronize the timeout handler and the
@@ -221,7 +224,7 @@ initialState =
     SimState {
       runqueue = PSQ.empty,
       threads  = Map.empty,
-      curTime  = Time 0,
+      curTime  = SI.Time 0,
       timers   = IPSQ.empty,
       clocks   = Map.singleton (ClockId []) epoch1970,
       nextVid  = 0,
@@ -252,8 +255,8 @@ invariant Nothing SimState{runqueue,threads,clocks} =
 
 -- | Interpret the simulation monotonic time as a 'NominalDiffTime' since
 -- the start.
-timeSinceEpoch :: Time -> NominalDiffTime
-timeSinceEpoch (Time t) = fromRational (toRational t)
+timeSinceEpoch :: SI.Time -> NominalDiffTime
+timeSinceEpoch (SI.Time t) = fromRational (toRational t)
 
 
 -- | Insert thread into `runqueue`.
@@ -457,15 +460,15 @@ schedule thread@Thread{
     GetWallTime k -> do
       let clockid  = threadClockId thread
           clockoff = clocks Map.! clockid
-          walltime = timeSinceEpoch time `addUTCTime` clockoff
+          walltime = timeSinceEpoch time `Time.addUTCTime` clockoff
           thread'  = thread { threadControl = ThreadControl (k walltime) ctl }
       schedule thread' simstate
 
     SetWallTime walltime' k -> do
       let clockid   = threadClockId thread
           clockoff  = clocks Map.! clockid
-          walltime  = timeSinceEpoch time `addUTCTime` clockoff
-          clockoff' = addUTCTime (diffUTCTime walltime' walltime) clockoff
+          walltime  = timeSinceEpoch time `Time.addUTCTime` clockoff
+          clockoff' = (walltime' `Time.diffUTCTime` walltime) `Time.addUTCTime` clockoff
           thread'   = thread { threadControl = ThreadControl k ctl }
           simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }
       schedule thread' simstate'
@@ -1322,7 +1325,7 @@ removeMinimums = \psq -> coerce $
           | p == p' -> collectAll (k:ks) p (x:xs) psq'
         _           -> (reverse ks, p, reverse xs, psq)
 
-traceMany :: [(Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]
+traceMany :: [(SI.Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]
           -> SimTrace a -> SimTrace a
 traceMany []                                   trace = trace
 traceMany ((time, tid, tstep, tlbl, event):ts) trace =
@@ -1374,7 +1377,7 @@ controlSimTraceST limit control mainAction =
 --
 
 execAtomically :: forall s a c.
-                  Time
+                  SI.Time
                -> IOSimThreadId
                -> Maybe ThreadLabel
                -> VarId