io sim performance fix

.github/workflows/checks.yml

@@ -46,8 +46,8 @@ jobs:
       uses: haskell-actions/setup@v2.11.0
       id: setup-haskell
       with:
-        ghc-version: 9.6.3
-        cabal-version: 3.10.1.0
+        ghc-version: 9.6.7
+        cabal-version: 3.14.2.0
 
     - name: "Setup cabal bin path"
       run: |

io-classes/CHANGELOG.md

@@ -1,6 +1,6 @@
 # Revsion history of io-classes
 
-## next
+## 1.11.0.0
 
 ### Breaking changes
 

io-classes/io-classes.cabal

@@ -1,6 +1,6 @@
 cabal-version:       3.4
 name:                io-classes
-version:             1.10.1.0
+version:             1.11.0.0
 synopsis:            Type classes for concurrency with STM, ST and timing
 description:
   IO Monad class hierarchy compatible with:

io-classes/io-classes/Control/Monad/Class/MonadEventlog.hs

@@ -1,4 +1,9 @@
-module Control.Monad.Class.MonadEventlog (MonadEventlog (..)) where
+module Control.Monad.Class.MonadEventlog
+  ( MonadEventlog (..)
+    -- Re-exports
+  , IO.traceEvent
+  , IO.traceMarker
+  ) where
 
 import Control.Monad.Reader
 

io-sim/CHANGELOG.md

@@ -1,13 +1,20 @@
 # Revision history of io-sim
 
-## next version
+## 1.11.0.0
 
 ### Breaking changes
 
+* Removed `EventSayEvaluationError` and `EventLogEvaluationError`.
+
 ### Non-breaking changes
 
 * Added `ppSayTrace` which pritty prints `EventSay` which are coming from `say` usage.
 * Repository moved to https://github.com/IntersectMBO/io-sim
+* Exported `traceMarker`, `traceEvent` from `Control.Monad.Class.MonadEventlog`.
+* `say`, `traceM` and `traceSTM` no longer evaluate their arguments to _NF_ or
+  _WHNF_.  This is dropped since it introduced a performance regression in
+  `io-sim-1.10` on large tests which include `say` used just for debugging
+  purposes.
 
 ## 1.10.1.0
 

io-sim/io-sim.cabal

@@ -1,6 +1,6 @@
 cabal-version:       3.4
 name:                io-sim
-version:             1.10.1.0
+version:             1.11.0.0
 synopsis:            A pure simulator for monadic concurrency with STM.
 description:
   A pure simulator monad with support of concurrency (base & async style), stm,
@@ -66,7 +66,7 @@ library
     default-extensions: GADTs
   build-depends:       base              >=4.16 && <4.23,
                        io-classes:{io-classes,strict-stm,si-timers}
-                                        ^>=1.10,
+                                        ^>=1.11,
                        exceptions        >=0.10,
                        containers,
                        deepseq,

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

@@ -367,7 +367,7 @@ data Failure =
   deriving Show
 
 instance Exception Failure where
-    displayException (FailureException err) = displayException err
+    displayException (FailureException err) = displayException  err
     displayException (FailureDeadlock threads) =
       concat [ "<<io-sim deadlock: "
              , intercalate ", " (show `map` threads)

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

@@ -56,7 +56,6 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Time (UTCTime (..), fromGregorian)
 
-import Control.DeepSeq (force)
 import Control.Exception (NonTermination (..), SomeAsyncException, assert,
            throw)
 import Control.Monad (join, when)
@@ -314,36 +313,14 @@ schedule !thread@Thread{
                  $ trace
 
     Say msg k -> do
-      mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of
-                                        Nothing -> Just e
-                                        Just {} -> Nothing)
-                           $ evaluate (force msg)
-      case mbNF of
-        Left e -> do
-          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
-          trace <- schedule thread' simstate
-          return $ SimTrace time tid tlbl (EventSayEvaluationError e)
-                 $ trace
-        Right msg' -> do
-          let thread' = thread { threadControl = ThreadControl k ctl }
-          trace <- schedule thread' simstate
-          return (SimTrace time tid tlbl (EventSay msg') trace)
+      let thread' = thread { threadControl = ThreadControl k ctl }
+      trace <- schedule thread' simstate
+      return (SimTrace time tid tlbl (EventSay msg) trace)
 
-    Output x@(Dynamic _ x') k -> do
-      mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of
-                                          Nothing -> Just e
-                                          Just {} -> Nothing)
-                             $ evaluate x'
-      case mbWHNF of
-        Left e -> do
-          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
-          trace <- schedule thread' simstate
-          return $ SimTrace time tid tlbl (EventLogEvaluationError e)
-                 $ trace
-        Right {} -> do
-          let thread' = thread { threadControl = ThreadControl k ctl }
-          trace <- schedule thread' simstate
-          return (SimTrace time tid tlbl (EventLog x) trace)
+    Output x k -> do
+      let thread' = thread { threadControl = ThreadControl k ctl }
+      trace <- schedule thread' simstate
+      return (SimTrace time tid tlbl (EventLog x) trace)
 
     LiftST st k -> do
       x <- strictToLazyST st
@@ -1125,8 +1102,25 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
           -- Skip the right hand alternative and continue with the k continuation
           go ctl' read written' writtenSeq' createdSeq' nextVid (k x)
 
-      ThrowStm e ->
-        throwStm ctl read written nextVid e
+      ThrowStm e -> do
+        -- Rollback `TVar`s written since catch handler was installed
+        !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
+        case ctl of
+          AtomicallyFrame -> do
+            k0 $ StmTxAborted (Map.elems read) (toException e)
+
+          BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
+            -- Execute the left side in a new frame with an empty written set.
+            -- but preserve ones that were set prior to it, as specified in the
+            -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.
+            let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
+            go ctl'' read Map.empty [] [] nextVid (h e)
+
+          BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
+            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)
+
+          BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
+            go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)
 
       CatchStm a h k -> do
         -- Execute the catch handler with an empty written set.
@@ -1194,32 +1188,12 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
             go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k
 
       SayStm msg k -> do
-        mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of
-                                          Nothing -> Just e
-                                          Just {} -> Nothing)
-                             $ evaluate (force msg)
-        case mbNF of
-          Left e -> do
-            trace <- throwStm ctl read written nextVid e
-            return $ SimTrace time tid tlbl (EventSayEvaluationError e)
-                   $ trace
-          Right msg' -> do
-            trace <- go ctl read written writtenSeq createdSeq nextVid k
-            return $ SimTrace time tid tlbl (EventSay msg') trace
-
-      OutputStm x@(Dynamic _ x') k -> do
-        mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of
-                                            Nothing -> Just e
-                                            Just {} -> Nothing)
-                               $ evaluate x'
-        case mbWHNF of
-          Left e -> do
-            trace <- throwStm ctl read written nextVid e
-            return $ SimTrace time tid tlbl (EventLogEvaluationError e)
-                   $ trace
-          Right {} -> do
-            trace <- go ctl read written writtenSeq createdSeq nextVid k
-            return $ SimTrace time tid tlbl (EventLog x) trace
+        trace <- go ctl read written writtenSeq createdSeq nextVid k
+        return $ SimTrace time tid tlbl (EventSay msg) trace
+
+      OutputStm x k -> do
+        trace <- go ctl read written writtenSeq createdSeq nextVid k
+        return $ SimTrace time tid tlbl (EventLog x) trace
 
       LiftSTStm st k -> do
         x <- strictToLazyST st
@@ -1237,34 +1211,6 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
             Map.keysSet written
          == Set.fromList [ tvarId tvar | SomeTVar tvar <- writtenSeq ]
 
-    -- throw an exception in an STM transaction
-    throwStm :: forall b.
-                StmStack s b a
-             -> Map TVarId (SomeTVar s)
-             -> Map TVarId (SomeTVar s)
-             -> VarId
-             -> SomeException
-             -> ST s (SimTrace c)
-    throwStm ctl read written nextVid e = do
-      -- Rollback `TVar`s written since catch handler was installed
-      !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-      case ctl of
-        AtomicallyFrame -> do
-          k0 $ StmTxAborted (Map.elems read) (toException e)
-
-        BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
-          -- Execute the left side in a new frame with an empty written set.
-          -- but preserve ones that were set prior to it, as specified in the
-          -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.
-          let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
-          go ctl'' read Map.empty [] [] nextVid (h e)
-
-        BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
-          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)
-
-        BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
-          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e)
-
 
 -- | Special case of 'execAtomically' supporting only var reads and writes
 --

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

@@ -145,20 +145,14 @@ runIOSim (IOSim k) = k Return
 -- can then be recovered with `selectTraceEventsDynamic` or
 -- `selectTraceEventsDynamic'`.
 --
--- Note: `traceM` evaluates the `a` to `WHNF`, exceptions are thrown by the
--- current thread and the trace will include `EventLogEvaluationError`.
---
 traceM :: Typeable a => a -> IOSim s ()
-traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ())
+traceM !x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ())
 
 -- | Trace a value, in the same was as `traceM` does, but from the `STM` monad.
 -- This is primarily useful for debugging.
 --
--- Note: `traceSTM` evaluates the `a` to `WHNF`, if exception is thrown, the
--- trace will end with `TraceException`.
---
 traceSTM :: Typeable a => a -> STMSim s ()
-traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ())
+traceSTM !x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ())
 
 data Thrower = ThrowSelf | ThrowOther deriving (Ord, Eq, Show)
 
@@ -339,10 +333,6 @@ instance MonadPlus (STM s) where
 instance MonadFix (STM s) where
     mfix f = STM $ oneShot $ \k -> FixStm f k
 
--- | `IOSim s` instance is strict: the string will be evaluated to normal form,
--- if an exception is encountered it is thrown in the current thread, and the
--- log will contain `EventSayEvaluationError`.
---
 instance MonadSay (IOSim s) where
   say msg = IOSim $ oneShot $ \k -> Say msg (k ())
 
@@ -493,10 +483,6 @@ instance MonadFork (IOSim s) where
 instance MonadTest (IOSim s) where
   exploreRaces       = IOSim $ oneShot $ \k -> ExploreRaces (k ())
 
--- | `STM (IOSim s)` instance is strict: the string will be evaluated to normal
--- form, if an exception is encountered the trace will finish with
--- `TraceException`.
---
 instance MonadSay (STMSim s) where
   say msg = STM $ oneShot $ \k -> SayStm msg (k ())
 
@@ -1056,13 +1042,9 @@ pattern TraceInternalError msg = Trace.Nil (InternalError msg)
 --
 data SimEventType
   = EventSay  String
-  -- ^ holds value of `say`
-  | EventSayEvaluationError SomeException
-  -- ^ holds error resulted from evaluation of the expression passed to `say` to NF.
+  -- ^ hold value of `say`
   | EventLog  Dynamic
-  -- ^ holds a dynamic value of `Control.Monad.IOSim.traceM`
-  | EventLogEvaluationError SomeException
-  -- ^ holds error resulted from evaluation of the expression passed to `traceM` to WHNF.
+  -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM`
   | EventMask MaskingState
   -- ^ masking state changed
 
@@ -1192,9 +1174,7 @@ unsafeEvaluateString name a = unsafePerformIO $
 ppSimEventType :: SimEventType -> String
 ppSimEventType = \case
   EventSay a -> "Say " ++ a
-  EventSayEvaluationError err -> "SayEvaluationError " ++ show err
   EventLog a -> "Dynamic " ++ show a
-  EventLogEvaluationError err -> "DynamicEvaluationError " ++ show err
   EventMask a -> "Mask " ++ show a
   EventThrow err -> "Throw " ++ unsafeEvaluateString "exception" (show err)
   EventThrowTo err tid ->