Generalise OrElseLeft/Right frame

Yogesh Sajanikar · Yogesh Sajanikar · commit 2126b8b5df82 · 2022-08-01T19:24:43.000+05:30
OrElseLeftFrame and OrElseRightFrame represent a control structure that
has a alternative branch that is executed when `retry` is applied. A
`catch` has a similar execution model when a `throw` is applied.

The control frame is generalised to BranchFrame that can hold an
alternative statement. If the execution context is `left` side of the
branch then the BranchFrame contains `right` statement. When we are
executing in the `right` context, the branch frame contains an empty
statement.
diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs
@@ -881,7 +881,7 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
                                 (mapMaybe traceString $ ds ++ ds')
                                 nextVid
 
-        OrElseLeftFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
+        BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
           -- Commit the TVars written in this sub-transaction that are also
           -- in the written set of the outer transaction
           !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
@@ -895,21 +895,6 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
           -- Skip the orElse right hand and continue with the k continuation
           go ctl' read written' writtenSeq' createdOuterSeq nextVid (k x)
 
-        OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
-          -- Commit the TVars written in this sub-transaction that are also
-          -- in the written set of the outer transaction
-          !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
-                          (Map.intersection written writtenOuter)
-          -- Merge the written set of the inner with the outer
-          let written'    = Map.union written writtenOuter
-              writtenSeq' = filter (\(SomeTVar tvar) ->
-                                      tvarId tvar `Map.notMember` writtenOuter)
-                                    writtenSeq
-                         ++ writtenOuterSeq
-              createdSeq' = createdSeq ++ createdOuterSeq
-          -- Continue with the k continuation
-          go ctl' read written' writtenSeq' createdSeq' nextVid (k x)
-
       ThrowStm e ->
         {-# SCC "execAtomically.go.ThrowStm" #-} do
         -- Revert all the TVar writes
@@ -925,15 +910,15 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
           -- Return vars read, so the thread can block on them
           k0 $! StmTxBlocked $! (Map.elems read)
 
-        OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+        BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
           {-# SCC "execAtomically.go.OrElseLeftFrame" #-} 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'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
+          let ctl'' = BranchFrame EmptyStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
           go ctl'' read Map.empty [] [] nextVid b
 
-        OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+        BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
           {-# SCC "execAtomically.go.OrElseRightFrame" #-} do
           -- Revert all the TVar writes within this orElse branch
           !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
@@ -944,7 +929,7 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
       OrElse a b k ->
         {-# SCC "execAtomically.go.OrElse" #-} do
         -- Execute the left side in a new frame with an empty written set
-        let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
+        let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
         go ctl' read Map.empty [] [] nextVid a
 
       NewTVar !mbLabel x k ->
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
@@ -28,6 +28,7 @@ module Control.Monad.IOSim.Types
   , runSTM
   , StmA (..)
   , StmTxResult (..)
+  , BranchStmA (..)
   , StmStack (..)
   , Timeout (..)
   , TimeoutException (..)
@@ -832,26 +833,25 @@ data StmTxResult s a =
        --
      | StmTxAborted  [SomeTVar s] SomeException
 
+
+-- | OrElse/Catch give rise to an alternate branch. A branch of a branch is an
+-- empty one.
+data BranchStmA s a = OrElseStmA (StmA s a) | EmptyStmA
+
 data StmStack s b a where
   -- | Executing in the context of a top level 'atomically'.
   AtomicallyFrame  :: StmStack s a a
 
-  -- | Executing in the context of the /left/ hand side of an 'orElse'
-  OrElseLeftFrame  :: StmA s a                -- orElse right alternative
+  -- | 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
                    -> (a -> StmA s b)         -- subsequent continuation
                    -> Map TVarId (SomeTVar s) -- saved written vars set
                    -> [SomeTVar s]            -- saved written vars list
                    -> [SomeTVar s]            -- created vars list
                    -> StmStack s b c
                    -> StmStack s a c
 
-  -- | Executing in the context of the /right/ hand side of an 'orElse'
-  OrElseRightFrame :: (a -> StmA s b)         -- subsequent continuation
-                   -> Map TVarId (SomeTVar s) -- saved written vars set
-                   -> [SomeTVar s]            -- saved written vars list
-                   -> [SomeTVar s]            -- created vars list
-                   -> StmStack s b c
-                   -> StmStack s a c
 
 ---
 --- Schedules
diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs
@@ -1092,7 +1092,7 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
                                 (mapMaybe traceString $ ds ++ ds')
                                 nextVid
 
-        OrElseLeftFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
+        BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
           -- Commit the TVars written in this sub-transaction that are also
           -- in the written set of the outer transaction
           !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
@@ -1106,21 +1106,6 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
           -- Skip the orElse right hand and continue with the k continuation
           go ctl' read written' writtenSeq' createdOuterSeq nextVid (k x)
 
-        OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
-          -- Commit the TVars written in this sub-transaction that are also
-          -- in the written set of the outer transaction
-          !_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
-                          (Map.intersection written writtenOuter)
-          -- Merge the written set of the inner with the outer
-          let written'    = Map.union written writtenOuter
-              writtenSeq' = filter (\(SomeTVar tvar) ->
-                                      tvarId tvar `Map.notMember` writtenOuter)
-                                    writtenSeq
-                         ++ writtenOuterSeq
-              createdSeq' = createdSeq ++ createdOuterSeq
-          -- Continue with the k continuation
-          go ctl' read written' writtenSeq' createdSeq' nextVid (k x)
-
       ThrowStm e ->
         {-# SCC "execAtomically.go.ThrowStm" #-} do
         -- Revert all the TVar writes
@@ -1136,15 +1121,15 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
           -- Return vars read, so the thread can block on them
           k0 $! StmTxBlocked $! Map.elems read
 
-        OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+        BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
           {-# SCC "execAtomically.go.OrElseLeftFrame" #-} 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'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
+          let ctl'' = BranchFrame EmptyStmA  k writtenOuter writtenOuterSeq createdOuterSeq ctl'
           go ctl'' read Map.empty [] [] nextVid b
 
-        OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
+        BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
           {-# SCC "execAtomically.go.OrElseRightFrame" #-} do
           -- Revert all the TVar writes within this orElse branch
           !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
@@ -1155,7 +1140,7 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
       OrElse a b k ->
         {-# SCC "execAtomically.go.OrElse" #-} do
         -- Execute the left side in a new frame with an empty written set
-        let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
+        let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
         go ctl' read Map.empty [] [] nextVid a
 
       NewTVar !mbLabel x k ->
