Skip to content

Commit c720399

Browse files
yogeshsajanikaryogeshsajanikar
authored
Merge pull request #15 from input-output-hk/CAD-4750-generalise-orelse-frame
CAD-4750 generalise OrElse frame
2 parents 3580d08 + ccc84f8 commit c720399

File tree

3 files changed

+60
-85
lines changed

3 files changed

+60
-85
lines changed

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

Lines changed: 25 additions & 38 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 ->
@@ -918,33 +906,32 @@ execAtomically !time !tid !tlbl !nextVid0 action0 k0 =
918906

919907
Retry ->
920908
{-# SCC "execAtomically.go.Retry" #-}
921-
case ctl of
922-
AtomicallyFrame -> do
923-
-- Revert all the TVar writes
924-
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
925-
-- Return vars read, so the thread can block on them
926-
k0 $! StmTxBlocked $! (Map.elems read)
927-
928-
OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
929-
{-# SCC "execAtomically.go.OrElseLeftFrame" #-} do
930-
-- Revert all the TVar writes within this orElse
931-
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
932-
-- Execute the orElse right hand with an empty written set
933-
let ctl'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
934-
go ctl'' read Map.empty [] [] nextVid b
935-
936-
OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
937-
{-# SCC "execAtomically.go.OrElseRightFrame" #-} do
938-
-- Revert all the TVar writes within this orElse branch
909+
do
910+
-- Always revert all the TVar writes for the retry
939911
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
940-
-- Skip the continuation and propagate the retry into the outer frame
941-
-- using the written set for the outer frame
942-
go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
912+
case ctl of
913+
AtomicallyFrame -> do
914+
-- Return vars read, so the thread can block on them
915+
k0 $! StmTxBlocked $! (Map.elems read)
916+
917+
BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
918+
{-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do
919+
-- Execute the orElse right hand with an empty written set
920+
let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
921+
go ctl'' read Map.empty [] [] nextVid b
922+
923+
BranchFrame _ _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
924+
{-# SCC "execAtomically.go.BranchFrame" #-} do
925+
-- Retry makes sense only within a OrElse context. If it is a branch other than
926+
-- OrElse left side, then bubble up the `retry` to the frame above.
927+
-- Skip the continuation and propagate the retry into the outer frame
928+
-- using the written set for the outer frame
929+
go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
943930

944931
OrElse a b k ->
945932
{-# SCC "execAtomically.go.OrElse" #-} do
946933
-- Execute the left side in a new frame with an empty written set
947-
let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
934+
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
948935
go ctl' read Map.empty [] [] nextVid a
949936

950937
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 (..)
@@ -844,26 +845,25 @@ data StmTxResult s a =
844845
--
845846
| StmTxAborted [SomeTVar s] SomeException
846847

848+
849+
-- | OrElse/Catch give rise to an alternate right hand side branch. A right branch
850+
-- can be a NoOp
851+
data BranchStmA s a = OrElseStmA (StmA s a) | NoOpStmA
852+
847853
data StmStack s b a where
848854
-- | Executing in the context of a top level 'atomically'.
849855
AtomicallyFrame :: StmStack s a a
850856

851-
-- | Executing in the context of the /left/ hand side of an 'orElse'
852-
OrElseLeftFrame :: StmA s a -- orElse right alternative
857+
-- | Executing in the context of the /left/ hand side of a branch.
858+
-- A right branch is represented by a frame containing empty statement.
859+
BranchFrame :: !(BranchStmA s a) -- right alternative, can be empty
853860
-> (a -> StmA s b) -- subsequent continuation
854861
-> Map TVarId (SomeTVar s) -- saved written vars set
855862
-> [SomeTVar s] -- saved written vars list
856863
-> [SomeTVar s] -- created vars list
857864
-> StmStack s b c
858865
-> StmStack s a c
859866

860-
-- | Executing in the context of the /right/ hand side of an 'orElse'
861-
OrElseRightFrame :: (a -> StmA s b) -- subsequent continuation
862-
-> Map TVarId (SomeTVar s) -- saved written vars set
863-
-> [SomeTVar s] -- saved written vars list
864-
-> [SomeTVar s] -- created vars list
865-
-> StmStack s b c
866-
-> StmStack s a c
867867

868868
---
869869
--- Schedules

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

Lines changed: 26 additions & 38 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 ->
@@ -1129,33 +1117,33 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
11291117

11301118
Retry ->
11311119
{-# SCC "execAtomically.go.Retry" #-}
1132-
case ctl of
1133-
AtomicallyFrame -> do
1134-
-- Revert all the TVar writes
1135-
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
1136-
-- Return vars read, so the thread can block on them
1137-
k0 $! StmTxBlocked $! Map.elems read
1138-
1139-
OrElseLeftFrame b k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1140-
{-# SCC "execAtomically.go.OrElseLeftFrame" #-} do
1141-
-- Revert all the TVar writes within this orElse
1142-
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
1143-
-- Execute the orElse right hand with an empty written set
1144-
let ctl'' = OrElseRightFrame k writtenOuter writtenOuterSeq createdOuterSeq ctl'
1145-
go ctl'' read Map.empty [] [] nextVid b
1146-
1147-
OrElseRightFrame _k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1148-
{-# SCC "execAtomically.go.OrElseRightFrame" #-} do
1149-
-- Revert all the TVar writes within this orElse branch
1120+
do
1121+
-- Always revert all the TVar writes for the retry
11501122
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
1151-
-- Skip the continuation and propagate the retry into the outer frame
1152-
-- using the written set for the outer frame
1153-
go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
1123+
case ctl of
1124+
AtomicallyFrame -> do
1125+
-- Return vars read, so the thread can block on them
1126+
k0 $! StmTxBlocked $! Map.elems read
1127+
1128+
BranchFrame (OrElseStmA b) k writtenOuter writtenOuterSeq createdOuterSeq ctl' ->
1129+
{-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do
1130+
!_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written
1131+
-- Execute the orElse right hand with an empty written set
1132+
let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl'
1133+
go ctl'' read Map.empty [] [] nextVid b
1134+
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.
1139+
-- Skip the continuation and propagate the retry into the outer frame
1140+
-- using the written set for the outer frame
1141+
go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid Retry
11541142

11551143
OrElse a b k ->
11561144
{-# SCC "execAtomically.go.OrElse" #-} do
11571145
-- Execute the left side in a new frame with an empty written set
1158-
let ctl' = OrElseLeftFrame b k written writtenSeq createdSeq ctl
1146+
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
11591147
go ctl' read Map.empty [] [] nextVid a
11601148

11611149
NewTVar !mbLabel x k ->

0 commit comments

Comments
 (0)