diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index f99d042..4017aeb 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -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 () diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 75896a7..6d187f5 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -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 (), diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 960c6d6..c6d2393 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -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 ["*"] diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index 8687973..dd7cb49 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -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 diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 9bb8330..df5c351 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -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) diff --git a/data/AST.hs b/data/AST.hs index c4a71a0..12f9019 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -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. diff --git a/frontends/OccamCheckTypes.hs b/frontends/OccamCheckTypes.hs index 5ad0fd3..3bde74a 100644 --- a/frontends/OccamCheckTypes.hs +++ b/frontends/OccamCheckTypes.hs @@ -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 diff --git a/frontends/OccamInferTypes.hs b/frontends/OccamInferTypes.hs index c9998bc..6aa62bc 100644 --- a/frontends/OccamInferTypes.hs +++ b/frontends/OccamInferTypes.hs @@ -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 diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index a4dab4d..e55c81e 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- | 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 - caseInput m c <|> plainInput m c + ( 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 diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index 6d86ffa..55be8f7 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -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 diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 5634d0b..986f634 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -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 diff --git a/pass/Properties.hs b/pass/Properties.hs index a907d69..abce1af 100644 --- a/pass/Properties.hs +++ b/pass/Properties.hs @@ -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 diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index e92e805..02c795d 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -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 - 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.Case m' (A.ExprVariable m $ A.Variable m n) 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)] 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 - return $ A.Spec m' spec $ A.Only m $ - A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $ - A.Case m'' (A.ExprVariable m'' $ A.Variable m n) 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)] 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