Skip to content

Commit d5b4c46

Browse files
yogeshsajanikaryogeshsajanikar
committed
Generalise OrElseLeft/Right frame
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.
1 parent 4b180e3 commit d5b4c46

File tree

3 files changed

+35
-55
lines changed

3 files changed

+35
-55
lines changed

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

Lines changed: 14 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -881,21 +881,9 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
881881
(mapMaybe traceString $ ds ++ ds')
882882
nextVid
883883

884-
OrElseLeftFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
885-
-- Commit the TVars written in this sub-transaction that are also
886-
-- in the written set of the outer transaction
887-
!_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
888-
(Map.intersection written writtenOuter)
889-
-- Merge the written set of the inner with the outer
890-
let written' = Map.union written writtenOuter
891-
writtenSeq' = filter (\(SomeTVar tvar) ->
892-
tvarId tvar `Map.notMember` writtenOuter)
893-
writtenSeq
894-
++ writtenOuterSeq
895-
-- Skip the orElse right hand and continue with the k continuation
896-
go ctl' read written' writtenSeq' createdOuterSeq nextVid (k x)
897-
898-
OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
884+
BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
885+
-- The branch has successfully completed the transaction. Hence,
886+
-- the alternative branch can be ignored.
899887
-- Commit the TVars written in this sub-transaction that are also
900888
-- in the written set of the outer transaction
901889
!_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
@@ -907,7 +895,7 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
907895
writtenSeq
908896
++ writtenOuterSeq
909897
createdSeq' = createdSeq ++ createdOuterSeq
910-
-- Continue with the k continuation
898+
-- Skip the right hand alternative and continue with the k continuation
911899
go ctl' read written' writtenSeq' createdSeq' nextVid (k x)
912900

913901
ThrowStm e ->
@@ -925,17 +913,19 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
925913
-- Return vars read, so the thread can block on them
926914
k0 $! StmTxBlocked $! (Map.elems read)
927915

928-
OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
929-
{-# SCC "execAtomically.go.OrElseLeftFrame" #-} do
930-
-- Revert all the TVar writes within this orElse
916+
BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
917+
{-# SCC "execAtomically.go.BranchFrame" #-} do
918+
-- Revert all the TVar writes within this orElse branch
931919
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
932920
-- Execute the orElse right hand with an empty written set
933-
let ctl'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
921+
let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
934922
go ctl'' read Map.empty [] [] nextVid b
935923

936-
OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
937-
{-# SCC "execAtomically.go.OrElseRightFrame" #-} do
938-
-- Revert all the TVar writes within this orElse branch
924+
BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
925+
{-# SCC "execAtomically.go.BranchFrame" #-} do
926+
-- Retry makes sense only within a OrElse context. If it is a branch other than
927+
-- OrElse left side, then bubble up the `retry` to the frame above.
928+
-- Revert all the TVar writes within this branch
939929
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
940930
-- Skip the continuation and propagate the retry into the outer frame
941931
-- using the written set for the outer frame
@@ -944,7 +934,7 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
944934
OrElse a b k ->
945935
{-# SCC "execAtomically.go.OrElse" #-} do
946936
-- Execute the left side in a new frame with an empty written set
947-
let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
937+
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
948938
go ctl' read Map.empty [] [] nextVid a
949939

950940
NewTVar !mbLabel x k ->

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

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ module Control.Monad.IOSim.Types
2828
, runSTM
2929
, StmA (..)
3030
, StmTxResult (..)
31+
, BranchStmA (..)
3132
, StmStack (..)
3233
, Timeout (..)
3334
, TimeoutException (..)
@@ -832,26 +833,25 @@ data StmTxResult s a =
832833
--
833834
| StmTxAborted [SomeTVar s] SomeException
834835

836+
837+
-- | OrElse/Catch give rise to an alternate right hand side branch. A right branch
838+
-- can be a NoOp
839+
data BranchStmA s a = OrElseStmA (StmA s a) | NoOpStmA
840+
835841
data StmStack s b a where
836842
-- | Executing in the context of a top level 'atomically'.
837843
AtomicallyFrame :: StmStack s a a
838844

839-
-- | Executing in the context of the /left/ hand side of an 'orElse'
840-
OrElseLeftFrame :: StmA s a -- orElse right alternative
845+
-- | Executing in the context of the /left/ hand side of a branch.
846+
-- A right branch is represented by a frame containing empty statement.
847+
BranchFrame :: BranchStmA s a -- right alternative, can be empty
841848
-> (a -> StmA s b) -- subsequent continuation
842849
-> Map TVarId (SomeTVar s) -- saved written vars set
843850
-> [SomeTVar s] -- saved written vars list
844851
-> [SomeTVar s] -- created vars list
845852
-> StmStack s b c
846853
-> StmStack s a c
847854

848-
-- | Executing in the context of the /right/ hand side of an 'orElse'
849-
OrElseRightFrame :: (a -> StmA s b) -- subsequent continuation
850-
-> Map TVarId (SomeTVar s) -- saved written vars set
851-
-> [SomeTVar s] -- saved written vars list
852-
-> [SomeTVar s] -- created vars list
853-
-> StmStack s b c
854-
-> StmStack s a c
855855

856856
---
857857
--- Schedules

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

Lines changed: 12 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1092,21 +1092,9 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
10921092
(mapMaybe traceString $ ds ++ ds')
10931093
nextVid
10941094

1095-
OrElseLeftFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
1096-
-- Commit the TVars written in this sub-transaction that are also
1097-
-- in the written set of the outer transaction
1098-
!_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
1099-
(Map.intersection written writtenOuter)
1100-
-- Merge the written set of the inner with the outer
1101-
let written' = Map.union written writtenOuter
1102-
writtenSeq' = filter (\(SomeTVar tvar) ->
1103-
tvarId tvar `Map.notMember` writtenOuter)
1104-
writtenSeq
1105-
++ writtenOuterSeq
1106-
-- Skip the orElse right hand and continue with the k continuation
1107-
go ctl' read written' writtenSeq' createdOuterSeq nextVid (k x)
1108-
1109-
OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
1095+
BranchFrame _b k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do
1096+
-- The branch has successfully completed the transaction. Hence,
1097+
-- the alternative branch can be ignored.
11101098
-- Commit the TVars written in this sub-transaction that are also
11111099
-- in the written set of the outer transaction
11121100
!_ <- traverse_ (\(SomeTVar tvar) -> commitTVar tvar)
@@ -1118,7 +1106,7 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
11181106
writtenSeq
11191107
++ writtenOuterSeq
11201108
createdSeq' = createdSeq ++ createdOuterSeq
1121-
-- Continue with the k continuation
1109+
-- Skip the orElse right hand and continue with the k continuation
11221110
go ctl' read written' writtenSeq' createdSeq' nextVid (k x)
11231111

11241112
ThrowStm e ->
@@ -1136,16 +1124,18 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
11361124
-- Return vars read, so the thread can block on them
11371125
k0 $! StmTxBlocked $! Map.elems read
11381126

1139-
OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1140-
{-# SCC "execAtomically.go.OrElseLeftFrame" #-} do
1127+
BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1128+
{-# SCC "execAtomically.go.BranchFrame" #-} do
11411129
-- Revert all the TVar writes within this orElse
11421130
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
11431131
-- Execute the orElse right hand with an empty written set
1144-
let ctl'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
1132+
let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
11451133
go ctl'' read Map.empty [] [] nextVid b
11461134

1147-
OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1148-
{-# SCC "execAtomically.go.OrElseRightFrame" #-} do
1135+
BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1136+
{-# SCC "execAtomically.go.BranchFrame" #-} do
1137+
-- Retry makes sense only within a OrElse context. If it is a branch other than
1138+
-- OrElse left side, then bubble up the `retry` to the frame above.
11491139
-- Revert all the TVar writes within this orElse branch
11501140
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
11511141
-- Skip the continuation and propagate the retry into the outer frame
@@ -1155,7 +1145,7 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
11551145
OrElse a b k ->
11561146
{-# SCC "execAtomically.go.OrElse" #-} do
11571147
-- Execute the left side in a new frame with an empty written set
1158-
let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
1148+
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
11591149
go ctl' read Map.empty [] [] nextVid a
11601150

11611151
NewTVar !mbLabel x k ->

0 commit comments

Comments
 (0)