suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added support for extended rendezvous throughout the compiler

Browse Source
This commit is contained in:
Neil Brown 2009-04-19 16:26:37 +00:00
parent 41cf599ebe
commit 3a5565471f
13 changed files with 229 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
backends/GenerateC.hs
View File

@ -1044,11 +1044,24 @@ genDest f v = call genVariable' v A.Original (f . Pointer . stripPointers)
genChan :: A.Variable -> CGen ()
genChan c = call genVariable' c A.Original (const $ Pointer $ Plain "Channel")
cgenInputItem :: A.Variable -> A.InputItem -> CGen ()
cgenInputItem c (A.InCounted m cv av)
= do call genInputItem c (A.InVariable m cv)
t <- astTypeOf av
tell ["ChanIn(wptr,"]
cgenInputItem :: A.Variable -> A.InputItem -> Maybe A.Process -> CGen ()
cgenInputItem c (A.InCounted m cv av) mp
= do call genInputItem c (A.InVariable m cv) Nothing
case mp of
Nothing -> cgenInputItem' ""
Just p ->
do tell ["ChanXAble(wptr,"]
genChan c
tell [");"]
cgenInputItem' "X"
call genProcess p
tell ["ChanXEnd(wptr,"]
genChan c
tell [");"]
where
cgenInputItem' x
= do t <- astTypeOf av
tell ["Chan", x, "In(wptr,"]
genChan c
tell [","]
genDest id av
@ -1058,7 +1071,19 @@ cgenInputItem c (A.InCounted m cv av)
tell ["*"]
call genBytesIn m subT (Right av)
tell [");"]
cgenInputItem c (A.InVariable m v)
cgenInputItem c (A.InVariable m v) mp
= case mp of
Nothing -> cgenInputItem' ""
Just p -> do tell ["ChanXAble(wptr,"]
genChan c
tell [");"]
cgenInputItem' "X"
call genProcess p
tell ["ChanXEnd(wptr,"]
genChan c
tell [");"]
where
cgenInputItem' x
= do case v of
-- If we are reading into a dereferenced mobile, we must make sure
-- that something is in that mobile first:
@ -1075,22 +1100,16 @@ cgenInputItem c (A.InVariable m v)
t <- astTypeOf v
isMobile <- isMobileType t
let rhs = genDest (if isMobile then Pointer else id) v
case (t, isMobile) of
(A.Int, _) ->
do tell ["ChanInInt(wptr,"]
genChan c
tell [","]
rhs
tell [");"]
(_, True) ->
if isMobile
then
do call genClearMobile m v -- TODO insert this via a pass
tell ["MTChanIn(wptr,"]
tell ["MTChan", x, "In(wptr,"]
genChan c
tell [",(void**)"]
rhs
tell [");"]
_ ->
do tell ["ChanIn(wptr,"]
else
do tell ["Chan", x, "In(wptr,"]
genChan c
tell [","]
rhs
@ -1815,7 +1834,7 @@ cgenInput c im
= do case im of
A.InputTimerRead m (A.InVariable m' v) -> call genTimerRead c v
A.InputTimerAfter m e -> call genTimerWait e
A.InputSimple m is -> sequence_ $ map (call genInputItem c) is
A.InputSimple m [ii] mp -> call genInputItem c ii mp
_ -> call genMissing $ "genInput " ++ show im
cgenTimerRead :: A.Variable -> A.Variable -> CGen ()

2
backends/GenerateCBased.hs
View File

@ -166,7 +166,7 @@ data GenOps = GenOps {
-- | Generates an IF statement (which can have replicators, specifications and such things inside it).
genIf :: Meta -> A.Structured A.Choice -> CGen (),
genInput :: A.Variable -> A.InputMode -> CGen (),
genInputItem :: A.Variable -> A.InputItem -> CGen (),
genInputItem :: A.Variable -> A.InputItem -> Maybe A.Process -> CGen (),
genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen (),
genIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen (),
genListAssign :: A.Variable -> A.Expression -> CGen (),

6
backends/GenerateCPPCSP.hs
View File

@ -329,11 +329,11 @@ cppgenTimerWait e
time <- genCPPCSPTime e
tell ["csp::SleepUntil(",time,");"]
cppgenInputItem :: A.Variable -> A.InputItem -> CGen ()
cppgenInputItem c dest
cppgenInputItem :: A.Variable -> A.InputItem -> Maybe A.Process -> CGen ()
cppgenInputItem c dest Nothing
= case dest of
(A.InCounted m cv av) ->
do call genInputItem c (A.InVariable m cv)
do call genInputItem c (A.InVariable m cv) Nothing
recvBytes av (
do call genVariable cv A.Original
tell ["*"]

2
checks/UsageCheckUtils.hs
View File

@ -163,7 +163,7 @@ getVarProc (A.Output _ chanVar outItems)
getVarOutputItem :: A.OutputItem -> Vars
getVarOutputItem (A.OutExpression _ e) = getVarExp e
getVarOutputItem (A.OutCounted _ ce ae) = (getVarExp ce) `unionVars` (getVarExp ae)
getVarProc (A.Input _ chanVar (A.InputSimple _ iis))
getVarProc (A.Input _ chanVar (A.InputSimple _ iis _))
= return $ (processVarUsed chanVar)
`unionVars` (mapUnionVars getVarInputItem iis)
where

19
common/ShowCode.hs
View File

@ -557,9 +557,9 @@ showProtocolItem (n,ts) = sequence_ $ intersperse (tell [" ; "]) $
showName n : (map showOccamM ts)
instance ShowOccam A.Variant where
showOccamM (A.Variant _ n iis p)
showOccamM (A.Variant _ n iis p mp)
= (showOccamLine (sequence_ $ intersperse (tell [" ; "]) $ [showName n] ++ (map showOccamM iis)))
>> occamIndent >> showOccamM p >> occamOutdent
>> occamIndent >> showOccamM p >> doMaybe (fmap showOccamM mp) >> occamOutdent
instance ShowOccam A.Actual where
showOccamM (A.ActualVariable v) = showOccamM v
@ -579,10 +579,19 @@ instance ShowOccam A.InputItem where
showOccamM (A.InCounted _ cv av) = showOccamM cv >> tell [" :: "] >> showOccamM av
instance ShowOccam A.InputMode where
showOccamM (A.InputSimple _ iis)
showOccamM (A.InputSimple _ iis Nothing)
= showOccamLine $ getTempItem >> tell [" ? "] >> (showWithSemis iis)
showOccamM (A.InputCase _ str)
= (showOccamLine $ getTempItem >> tell [" ? CASE"]) >> occamIndent >> showOccamM str >> occamOutdent
showOccamM (A.InputSimple _ iis (Just p))
= do showOccamLine $ getTempItem >> tell [" ?? "] >> (showWithSemis iis)
occamIndent
showOccamM p
occamOutdent
showOccamM (A.InputCase _ ty str)
= (showOccamLine $ getTempItem >> tell [op, "CASE"]) >> occamIndent >> showOccamM str >> occamOutdent
where
op = case ty of
A.InputCaseNormal -> " ? "
A.InputCaseExtended -> " ?? "
showOccamM (A.InputTimerRead _ ii)
= showOccamLine $ getTempItem >> tell [" ? "] >> showOccamM ii
showOccamM (A.InputTimerAfter _ e)

17
data/AST.hs
View File

@ -360,7 +360,12 @@ data Option =
-- | An option in a @? CASE@ process.
-- The name is the protocol tag, followed by zero or more input items, followed
-- by the process to be executed if that option is matched.
data Variant = Variant Meta Name [InputItem] Process
--
-- If this is part of a normal input, the first process is the process to execute,
-- and the Maybe item is ignored. If it is an extended input, the first process
-- is the one to execute during the extended rendezvous and the Maybe item is the
-- optional process to execute afterwards
data Variant = Variant Meta Name [InputItem] Process (Maybe Process)
deriving (Show, Eq, Typeable, Data)
-- | This represents something that can contain local replicators and
@ -410,12 +415,16 @@ instance Data a => Data (Structured a) where
dataTypeOf _ = _struct_DataType
dataCast1 f = gcast1 f
data InputCaseType
= InputCaseNormal | InputCaseExtended
deriving (Eq, Show, Typeable, Data)
-- | The mode in which an input operates.
data InputMode =
-- | A plain input from a channel.
InputSimple Meta [InputItem]
-- | A plain input from a channel, with a possible extended action.
InputSimple Meta [InputItem] (Maybe Process)
-- | A variant input from a channel.
| InputCase Meta (Structured Variant)
| InputCase Meta InputCaseType (Structured Variant)
-- | Read the value of a timer.
| InputTimerRead Meta InputItem
-- | Wait for a particular time to go past on a timer.

6
frontends/OccamCheckTypes.hs
View File

@ -336,15 +336,15 @@ checkProcesses x = checkDepthM doProcess x >> return x
doChoice (A.Choice _ e _) = checkExpressionBool e
doInput :: A.Variable -> A.InputMode -> PassM ()
doInput c (A.InputSimple m iis)
doInput c (A.InputSimple m iis _)
= do t <- checkChannel A.DirInput c
checkProtocol m t Nothing iis doInputItem
doInput c (A.InputCase _ s)
doInput c (A.InputCase _ _ s)
= do t <- checkChannel A.DirInput c
checkStructured (doVariant t) s
where
doVariant :: A.Type -> A.Variant -> PassM ()
doVariant t (A.Variant m tag iis _)
doVariant t (A.Variant m tag iis _ _)
= checkProtocol m t (Just tag) iis doInputItem
doInput c (A.InputTimerRead m ii)
= do t <- checkTimer c

14
frontends/OccamInferTypes.hs
View File

@ -416,14 +416,15 @@ inferTypes = occamOnlyPass "Infer types"
return $ A.AlternativeSkip m pre' p'
doInputMode :: A.Variable -> Infer A.InputMode
doInputMode v (A.InputSimple m iis)
doInputMode v (A.InputSimple m iis mp)
= do ts <- protocolItems m v >>* either id (const [])
iis' <- sequence [doInputItem t ii
| (t, ii) <- zip ts iis]
return $ A.InputSimple m iis'
doInputMode v (A.InputCase m sv)
mp' <- recurse mp
return $ A.InputSimple m iis' mp'
doInputMode v (A.InputCase m ty sv)
= do ct <- astTypeOf v
inTypeContext (Just ct) (recurse sv) >>* A.InputCase m
inTypeContext (Just ct) (recurse sv) >>* A.InputCase m ty
doInputMode _ (A.InputTimerRead m ii)
= doInputItem A.Int ii >>* A.InputTimerRead m
doInputMode _ im = inTypeContext (Just A.Int) $ descend im
@ -441,7 +442,7 @@ inferTypes = occamOnlyPass "Infer types"
return $ A.InCounted m cv' av'
doVariant :: Infer A.Variant
doVariant (A.Variant m n iis p)
doVariant (A.Variant m n iis p mp)
= do ctx <- getTypeContext
ets <- case ctx of
Just x -> protocolItems m x
@ -454,7 +455,8 @@ inferTypes = occamOnlyPass "Infer types"
Just ts -> do iis' <- sequence [doInputItem t ii
| (t, ii) <- zip ts iis]
p' <- recurse p
return $ A.Variant m n iis' p'
mp' <- recurse mp
return $ A.Variant m n iis' p' mp'
doStructured :: ( PolyplateM (A.Structured t) InferTypeOps () InferTypeM
, PolyplateM (A.Structured t) () InferTypeOps InferTypeM

112
frontends/ParseOccam.hs
View File

@ -19,7 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Parse occam code into an AST.
module ParseOccam (parseOccamProgram) where
import Control.Monad (join, liftM)
import Control.Monad (join, liftM, when)
import Control.Monad.State (MonadState, modify, get, put)
import Data.Char
import Data.List
@ -125,7 +125,7 @@ plainToken t = genToken test
test (Token _ t') = if t == t' then Just () else Nothing
--}}}
--{{{ symbols
sAmp, sAssign, sBang, sBar, sColon, sColons, sComma, sEq, sLeft, sLeftR,
sAmp, sAssign, sBang, sBar, sColon, sColons, sComma, sDoubleQuest, sEq, sLeft, sLeftR,
sQuest, sRight, sRightR, sSemi
:: OccParser ()
@ -136,6 +136,7 @@ sBar = reserved "|"
sColon = reserved ":"
sColons = reserved "::"
sComma = reserved ","
sDoubleQuest = reserved "??"
sEq = reserved "="
sLeft = reserved "["
sLeftR = reserved "("
@ -1106,7 +1107,7 @@ specification
= do m <- md
(ns, d, nt) <- declaration
return ([(A.Specification m n d, nt, normalName) | n <- ns], return ())
<|> do { a <- abbreviation; return ([a], return ()) }
<|> do { a <- abbreviation; return (a, return ()) }
<|> do { d <- definition; return ([d], return ()) }
<|> do { n <- pragma ; return (maybeToList n, return ()) }
<?> "specification"
@ -1668,37 +1669,60 @@ assignment
inputProcess :: OccParser A.Process
inputProcess
= do m <- md
(c, i) <- input
return $ A.Input m c i
(c, i, mp) <- input False
return $ case mp of
Nothing -> A.Input m c i
Just p -> A.Seq m $ A.Several m $ map (A.Only m) [A.Input m c i, p]
<?> "input process"
input :: OccParser (A.Variable, A.InputMode)
input
= channelInput
<|> timerInput
-- True for in-ALT, False for normal
input :: Bool ->OccParser (A.Variable, A.InputMode, Maybe A.Process)
input inAlt
= channelInput inAlt
<|> (timerInput >>* (\(a, b) -> (a, b, Nothing)))
<|> do m <- md
p <- tryVX port sQuest
v <- variable
eol
return (p, A.InputSimple m [A.InVariable m v])
return (p, A.InputSimple m [A.InVariable m v] Nothing, Nothing)
<?> "input"
channelInput :: OccParser (A.Variable, A.InputMode)
channelInput
channelInput :: Bool -> OccParser (A.Variable, A.InputMode, Maybe A.Process)
channelInput inAlt
= do m <- md
c <- tryVX channel sQuest
( do c <- tryVX channel sQuest
caseInput m c <|> plainInput m c
<|> do c <- tryVX channel sDoubleQuest
extCaseInput m c <|> extInput m c
)
<?> "channel input"
where
caseInput m c
= do sCASE
tl <- taggedList
eol
return (c, A.InputCase m (A.Only m (tl (A.Skip m))))
return (c, A.InputCase m A.InputCaseNormal (A.Only m (tl (A.Skip m) Nothing)), Nothing)
plainInput m c
= do is <- sepBy1 inputItem sSemi
eol
return (c, A.InputSimple m is)
return (c, A.InputSimple m is Nothing, Nothing)
extInput m c
= do is <- sepBy1 inputItem sSemi
eol
indent
p <- process
mp <- if inAlt then return Nothing else (tryVX process outdent >>* Just) <|> (outdent >> return Nothing)
return (c, A.InputSimple m is (Just p), mp)
extCaseInput m c
= do sCASE
tl <- taggedList
eol
indent
p <- process
mp <- if inAlt then return Nothing else (tryVX process outdent >>* Just) <|> (outdent >> return Nothing)
return (c, A.InputCase m A.InputCaseExtended (A.Only m (tl p mp)), Nothing)
timerInput :: OccParser (A.Variable, A.InputMode)
timerInput
@ -1708,7 +1732,7 @@ timerInput
<|> do { sAFTER; e <- expression; eol; return (c, A.InputTimerAfter m e) }
<?> "timer input"
taggedList :: OccParser (A.Process -> A.Variant)
taggedList :: OccParser (A.Process -> Maybe A.Process -> A.Variant)
taggedList
= do m <- md
tag <- tagName
@ -1732,19 +1756,28 @@ caseInput :: OccParser A.Process
caseInput
= do m <- md
c <- tryVX channel (sQuest >> sCASE >> eol)
vs <- maybeIndentedList m "empty ? CASE" variant
return $ A.Input m c (A.InputCase m (A.Several m vs))
vs <- maybeIndentedList m "empty ? CASE" (variant A.InputCaseNormal)
return $ A.Input m c (A.InputCase m A.InputCaseNormal (A.Several m vs))
<|> do m <- md
c <- tryVX channel (sDoubleQuest >> sCASE >> eol)
vs <- maybeIndentedList m "empty ? CASE" (variant A.InputCaseExtended)
return $ A.Input m c (A.InputCase m A.InputCaseExtended (A.Several m vs))
<?> "case input"
variant :: OccParser (A.Structured A.Variant)
variant
variant :: A.InputCaseType -> OccParser (A.Structured A.Variant)
variant ty
= do m <- md
tl <- tryVX taggedList eol
indent
p <- process
outdent
return $ A.Only m (tl p)
<|> handleSpecs specification variant A.Spec
case ty of
A.InputCaseNormal -> do outdent
return $ A.Only m (tl p Nothing)
A.InputCaseExtended ->
do mp <- (tryVX process outdent >>* Just)
<|> (outdent >> return Nothing)
return $ A.Only m (tl p mp)
<|> handleSpecs specification (variant ty) A.Spec
<?> "variant"
--}}}
--{{{ output (!)
@ -1943,39 +1976,48 @@ alternative
-- guards are below.
<|> do m <- md
(b, c) <- tryVXVX expression sAmp channel (sQuest >> sCASE >> eol)
vs <- maybeIndentedList m "empty ? CASE" variant
return $ A.Only m (A.Alternative m b c (A.InputCase m $ A.Several m vs) (A.Skip m))
guardCaseBody m b c A.InputCaseNormal
<|> do m <- md
c <- tryVXX channel sQuest (sCASE >> eol)
vs <- maybeIndentedList m "empty ? CASE" variant
return $ A.Only m (A.Alternative m (A.True m) c (A.InputCase m $ A.Several m vs) (A.Skip m))
guardCaseBody m (A.True m) c A.InputCaseNormal
<|> do m <- md
(b, c) <- tryVXVX expression sAmp channel (sDoubleQuest >> sCASE >> eol)
guardCaseBody m b c A.InputCaseExtended
<|> do m <- md
c <- tryVXX channel sDoubleQuest (sCASE >> eol)
guardCaseBody m (A.True m) c A.InputCaseExtended
<|> guardedAlternative
<|> handleSpecs specification alternative A.Spec
<?> "alternative"
where
guardCaseBody :: Meta -> A.Expression -> A.Variable -> A.InputCaseType -> OccParser (A.Structured A.Alternative)
guardCaseBody m b c ty
= do vs <- maybeIndentedList m "empty ? CASE" (variant ty)
return $ A.Only m (A.Alternative m b c (A.InputCase m ty $ A.Several m vs) (A.Skip m))
guardedAlternative :: OccParser (A.Structured A.Alternative)
guardedAlternative
= do m <- md
makeAlt <- guard
indent
(makeAlt, alreadyIndented) <- guard
when (not alreadyIndented) $ indent
p <- process
outdent
return $ A.Only m (makeAlt p)
<?> "guarded alternative"
guard :: OccParser (A.Process -> A.Alternative)
guard :: OccParser (A.Process -> A.Alternative, Bool)
guard
= do m <- md
(c, im) <- input
return $ A.Alternative m (A.True m) c im
(c, im, _) <- input True
return (A.Alternative m (A.True m) c im, True)
<|> do m <- md
sSKIP
eol
return $ A.AlternativeSkip m (A.True m)
return (A.AlternativeSkip m (A.True m), False)
<|> do m <- md
b <- tryVX expression sAmp
do { (c, im) <- input; return $ A.Alternative m b c im }
<|> do { sSKIP; eol; return $ A.AlternativeSkip m b }
do { (c, im, _) <- input True; return (A.Alternative m b c im, True) }
<|> do { sSKIP; eol; return (A.AlternativeSkip m b, False) }
<?> "guard"
--}}}
--{{{ PROC calls

2
frontends/ParseRain.hs
View File

@ -391,7 +391,7 @@ comm isAlt
(if isAlt
then pzero
else do {sOut ; exp <- expression ; possSemiColon ; return $ A.Output (findMeta lv) lv [A.OutExpression (findMeta exp) exp] })
<|> do {sIn ; rv <- lvalue ; possSemiColon ; return $ A.Input (findMeta lv) lv $ A.InputSimple (findMeta rv) [A.InVariable (findMeta rv) rv] }
<|> do {sIn ; rv <- lvalue ; possSemiColon ; return $ A.Input (findMeta lv) lv $ A.InputSimple (findMeta rv) [A.InVariable (findMeta rv) rv] Nothing }
<?> (if isAlt then "input statement" else "input or output statement")
}
where

4
frontends/RainTypes.hs
View File

@ -309,7 +309,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
checkWait _ = return ()
checkInputOutput :: RainTypeCheck A.Process
checkInputOutput p@(A.Input m chanVar (A.InputSimple _ [A.InVariable _ destVar]))
checkInputOutput p@(A.Input m chanVar (A.InputSimple _ [A.InVariable _ destVar] _))
= checkInput chanVar destVar m p
checkInputOutput (A.Input _ _ im@(A.InputTimerFor {})) = checkWait im
checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im
@ -319,7 +319,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
checkInputOutput _ = return ()
checkAltInput :: RainTypeCheck A.Alternative
checkAltInput a@(A.Alternative m _ chanVar (A.InputSimple _ [A.InVariable _ destVar]) body)
checkAltInput a@(A.Alternative m _ chanVar (A.InputSimple _ [A.InVariable _ destVar] _) body)
= checkInput chanVar destVar m a
checkAltInput (A.Alternative m _ _ im@(A.InputTimerFor {}) _) = checkWait im
checkAltInput (A.Alternative m _ _ im@(A.InputTimerAfter {}) _) = checkWait im

2
pass/Properties.hs
View File

@ -391,7 +391,7 @@ seqInputsFlattened :: Property
seqInputsFlattened = Property "seqInputsFlattened" $ checkNull "seqInputsFlattened" . listify findMultipleInputs
where
findMultipleInputs :: A.InputMode -> Bool
findMultipleInputs (A.InputSimple _ (_:_:_)) = True
findMultipleInputs (A.InputSimple _ (_:_:_) _) = True
findMultipleInputs _ = False
arraySizesDeclared :: Property

82
transformations/SimplifyComms.hs
View File

@ -21,6 +21,7 @@ module SimplifyComms where
import Control.Monad.State
import Data.List
import Data.Maybe
import qualified AST as A
import CompState
@ -142,30 +143,60 @@ transformInputCase = pass "Transform ? CASE statements/guards into plain CASE"
(applyBottomUpM doProcess)
where
doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputCase m' s))
doProcess (A.Input m v (A.InputCase m' ty s))
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.Original
s' <- doStructuredV v s
case ty of
A.InputCaseNormal -> do
s' <- doStructuredV Nothing v s
return $ A.Seq m $ A.Spec m' spec $ A.Several m'
[A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)])
[A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)] Nothing)
,A.Only m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s']
A.InputCaseExtended -> do
sA <- doStructuredV (Just A.InputCaseExtended) v s
sB <- doStructuredV (Just A.InputCaseNormal) v s
return $ A.Seq m $ A.Spec m' spec $ A.Several m' $ map (A.Only m')
[A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)]
$ Just (A.Case m' (A.ExprVariable m $ A.Variable m n) sA))
,A.Case m' (A.ExprVariable m $ A.Variable m n) sB
]
doProcess (A.Alt m pri s)
= do s' <- doStructuredA s
return (A.Alt m pri s')
doProcess p = return p
-- Convert Structured Variant into the equivalent Structured Option.
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
doStructuredV chanVar = transformOnly transform
--
-- For extended inputs, if there are no extra inputs after the tag, we must
-- perform the extended action during the extended input on the tag. This
-- is when (Just A.InputCaseExtended) is passed. If there are extra inputs
-- after the tag, we perform SKIP for the extended action, and then do our
-- real extended action on the further inputs
doStructuredV :: (Maybe A.InputCaseType) -> A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
doStructuredV mty chanVar = transformOnly transform
where
transform m (A.Variant m' n iis p)
transform m (A.Variant m' n iis p mp)
= do (Right items) <- protocolItems m' chanVar
let (Just idx) = elemIndex n (fst $ unzip items)
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
if length iis == 0
then p
else A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
case (mty, null iis) of
-- Normal input, no extra inputs:
(Nothing, True) -> p
-- Extended phase, no extra inputs, so do extended process now:
(Just A.InputCaseExtended, True) -> p
-- After extended, no extra inputs, do after process:
(Just A.InputCaseNormal, True) -> fromMaybe (A.Skip m) mp
-- Normal input, extra inputs to do:
(Nothing, False) -> A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis Nothing),
A.Only (findMeta p) p]
-- Extended phase, extra inputs to do:
(Just A.InputCaseExtended, False) -> A.Skip m
-- After extended, extra inputs to do:
(Just A.InputCaseNormal, False) -> A.Seq m' $ A.Several m'
$ map (A.Only m') $
[A.Input m' chanVar (A.InputSimple m' iis $ Just p)
] ++ maybeToList mp
-- Transform alt guards.
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
@ -173,12 +204,21 @@ transformInputCase = pass "Transform ? CASE statements/guards into plain CASE"
where
-- The processes that are the body of input-case guards are always
-- skip, so we can discard them.
doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _)
doAlternative m (A.Alternative m' e v (A.InputCase m'' ty s) _)
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.Original
s' <- doStructuredV v s
case ty of
A.InputCaseNormal -> do
s' <- doStructuredV Nothing v s
return $ A.Spec m' spec $ A.Only m $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)] Nothing) $
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
A.InputCaseExtended -> do
sA <- doStructuredV (Just A.InputCaseExtended) v s
sB <- doStructuredV (Just A.InputCaseNormal) v s
return $ A.Spec m' spec $ A.Only m $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)] $
Just $ A.Case m'' (A.ExprVariable m'' $ A.Variable m n) sA)
(A.Case m'' (A.ExprVariable m'' $ A.Variable m n) sB)
-- Leave other guards untouched.
doAlternative m a = return $ A.Only m a
@ -189,14 +229,18 @@ transformProtocolInput = pass "Flatten sequential protocol inputs into multiple
(applyBottomUpM2 doProcess doAlternative)
where
doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_)))
= return $ A.Seq m $ A.Several m $
map (A.Only m . A.Input m v . A.InputSimple m' . singleton) iis
doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_) mp))
= return $ A.Seq m $ A.Several m $ map (A.Only m . A.Input m v) $ flatten m' iis mp
doProcess p = return p
-- We put the extended input on the final input:
flatten :: Meta -> [A.InputItem] -> Maybe A.Process -> [A.InputMode]
flatten m [ii] mp = [A.InputSimple m [ii] mp]
flatten m (ii:iis) mp = A.InputSimple m [ii] Nothing : flatten m iis mp
doAlternative :: A.Alternative -> PassM A.Alternative
doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_)))) body)
= return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $
map (A.Only m' . A.Input m' v . A.InputSimple m' . singleton) otherIIS
doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_))) mp) body)
= return $ A.Alternative m cond v (A.InputSimple m' [firstII] Nothing) $ A.Seq m' $ A.Several m' $
(map (A.Only m' . A.Input m' v) $ flatten m' otherIIS mp)
++ [A.Only m' body]
doAlternative s = return s