Add strictness annotation to BranchFrame

- Refector changes to deduplicate

Author: yogeshsajanikar

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

@@ -906,30 +906,27 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
 
       Retry ->
         {-# SCC "execAtomically.go.Retry" #-}
-        case ctl of
-        AtomicallyFrame -> do
-          -- Revert all the TVar writes
-          !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Return vars read, so the thread can block on them
-          k0 $! StmTxBlocked $! (Map.elems read)
-
-        BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
-          {-# SCC "execAtomically.go.BranchFrame" #-} do
-          -- Revert all the TVar writes within this orElse branch
-          !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Execute the orElse right hand with an empty written set
-          let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
-          go ctl'' read Map.empty [] [] nextVid b
-
-        BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
-          {-# SCC "execAtomically.go.BranchFrame" #-} do
-          -- Retry makes sense only within a OrElse context. If it is a branch other than
-          -- OrElse left side, then bubble up the `retry` to the frame above.
-          -- Revert all the TVar writes within this branch
+        do
+          -- Always revert all the TVar writes for the retry
           !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Skip the continuation and propagate the retry into the outer frame
-          -- using the written set for the outer frame
-          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
+          case ctl of
+            AtomicallyFrame -> do
+              -- Return vars read, so the thread can block on them
+              k0 $! StmTxBlocked $! (Map.elems read)
+
+            BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+              {-# SCC "execAtomically.go.BranchFrame" #-} do
+              -- Execute the orElse right hand with an empty written set
+              let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
+              go ctl'' read Map.empty [] [] nextVid b
+
+            BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+              {-# SCC "execAtomically.go.BranchFrame" #-} do
+              -- Retry makes sense only within a OrElse context. If it is a branch other than
+              -- OrElse left side, then bubble up the `retry` to the frame above.
+              -- Skip the continuation and propagate the retry into the outer frame
+              -- using the written set for the outer frame
+              go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
 
       OrElse a b k ->
         {-# SCC "execAtomically.go.OrElse" #-} do

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

@@ -844,7 +844,7 @@ data StmStack s b a where
 
   -- | Executing in the context of the /left/ hand side of a branch.
   -- A right branch is represented by a frame containing empty statement.
-  BranchFrame      :: BranchStmA s a          -- right alternative, can be empty
+  BranchFrame      :: !(BranchStmA s a)       -- right alternative, can be empty
                    -> (a -> StmA s b)         -- subsequent continuation
                    -> Map TVarId (SomeTVar s) -- saved written vars set
                    -> [SomeTVar s]            -- saved written vars list

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

@@ -1117,30 +1117,28 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
 
       Retry ->
         {-# SCC "execAtomically.go.Retry" #-}
-        case ctl of
-        AtomicallyFrame -> do
-          -- Revert all the TVar writes
-          !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Return vars read, so the thread can block on them
-          k0 $! StmTxBlocked $! Map.elems read
-
-        BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
-          {-# SCC "execAtomically.go.BranchFrame" #-} do
-          -- Revert all the TVar writes within this orElse
-          !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Execute the orElse right hand with an empty written set
-          let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
-          go ctl'' read Map.empty [] [] nextVid b
-
-        BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
-          {-# SCC "execAtomically.go.BranchFrame" #-} do
-          -- Retry makes sense only within a OrElse context. If it is a branch other than
-          -- OrElse left side, then bubble up the `retry` to the frame above.
-          -- Revert all the TVar writes within this orElse branch
+        do
+          -- Always revert all the TVar writes for the retry
           !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
-          -- Skip the continuation and propagate the retry into the outer frame
-          -- using the written set for the outer frame
-          go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
+          case ctl of
+            AtomicallyFrame -> do
+              -- Return vars read, so the thread can block on them
+              k0 $! StmTxBlocked $! Map.elems read
+
+            BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+              {-# SCC "execAtomically.go.BranchFrame" #-} do
+              !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
+              -- Execute the orElse right hand with an empty written set
+              let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
+              go ctl'' read Map.empty [] [] nextVid b
+
+            BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+              {-# SCC "execAtomically.go.BranchFrame" #-} do
+              -- Retry makes sense only within a OrElse context. If it is a branch other than
+              -- OrElse left side, then bubble up the `retry` to the frame above.
+              -- Skip the continuation and propagate the retry into the outer frame
+              -- using the written set for the outer frame
+              go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
 
       OrElse a b k ->
         {-# SCC "execAtomically.go.OrElse" #-} do