From 8b2e14f3bd8a0cd3fa3dfcbb5e7075b41e6d97ac Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 13 Oct 2007 23:28:41 +0000 Subject: [PATCH] Added tests and implementation for a new pass for transforming input-case statements into case statements --- transformations/PassTest.hs | 167 ++++++++++++++++++++++++++++++- transformations/SimplifyComms.hs | 98 ++++++++++++++++++ 2 files changed, 264 insertions(+), 1 deletion(-) diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index 20ee538..b00ced3 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -254,6 +254,170 @@ testOutExprs = TestList chan = variable "c" xName = simpleName "x" + +testInputCase :: Test +testInputCase = TestList + [ + -- Input that only involves tags: + {- + The idea is to transform: + c ? CASE + a0 + --Process p0 + into: + SEQ + INT tag: + SEQ + c ? tag + CASE tag + a0 + --Process p0 + -} + TestCase $ testPass "testInputCase 0" + (tag2 A.Seq DontCare $ + tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag2 A.Declaration DontCare A.Int) $ + tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] + ,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ + tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0 + ] + ) + (transformInputCase $ + A.Input emptyMeta c $ A.InputCase emptyMeta $ A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0 + ) + (defineMyProtocol >> defineC) + + -- Input that involves multiple tags and multiple inputs: + {- + The idea is to transform: + c ? CASE + a0 + --Process p0 + c1 ; z + --Process p1 + b2 ; x ; y + --Process p2 + into: + SEQ + INT tag: + SEQ + c ? tag + CASE tag + a0 + --Process p0 + c1 + SEQ + c ? z + --Process p1 + b2 + SEQ + c ? x ; y + --Process p2 + -} + ,TestCase $ testPass "testInputCase 1" + (tag2 A.Seq DontCare $ + tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag2 A.Declaration DontCare A.Int) $ + tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] + ,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ tag2 A.Several emptyMeta + [tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0 + ,tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 2] $ + tag2 A.Seq DontCare $ tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],tag2 A.OnlyP DontCare p1] + ,tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 1] $ + tag2 A.Seq DontCare $ tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],tag2 A.OnlyP DontCare p2] + ] + ] + ) + (transformInputCase $ + A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta + [A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0 + ,A.OnlyV emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 + ,A.OnlyV emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 + ] + ) + (defineMyProtocol >> defineC) + + -- Input that involves multiple tags and multiple inputs and specs (sheesh!): + {- + The idea is to transform: + c ? CASE + a0 + --Process p0 + INT z: + c1 ; z + --Process p1 + INT x: + INT y: + b2 ; x ; y + --Process p2 + into: + SEQ + INT tag: + SEQ + c ? tag + CASE tag + a0 + --Process p0 + INT z: + c1 + SEQ + c ? z + --Process p1 + INT x: + INT y: + b2 + SEQ + c ? x ; y + --Process p2 + -} + ,TestCase $ testPass "testInputCase 2" + (tag2 A.Seq DontCare $ + tag3 A.Spec DontCare (tag3 A.Specification DontCare (Named "tag" DontCare) $ tag2 A.Declaration DontCare A.Int) $ + tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ tag3 A.Input DontCare c $ tag2 A.InputSimple DontCare [tag2 A.InVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)] + ,tag2 A.OnlyP DontCare $ tag3 A.Case DontCare (tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare (Named "tag" DontCare)) $ tag2 A.Several emptyMeta + [tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 0] p0 + ,specIntPatt "z" $ tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 2] $ + tag2 A.Seq DontCare $ tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta z],tag2 A.OnlyP DontCare p1] + ,specIntPatt "x" $ specIntPatt "y" $ tag2 A.OnlyO DontCare $ tag3 A.Option DontCare [intLiteralPattern 1] $ + tag2 A.Seq DontCare $ tag2 A.Several DontCare + [tag2 A.OnlyP DontCare $ A.Input emptyMeta c $ A.InputSimple emptyMeta [A.InVariable emptyMeta x,A.InVariable emptyMeta y],tag2 A.OnlyP DontCare p2] + ] + ] + ) + (transformInputCase $ + A.Input emptyMeta c $ A.InputCase emptyMeta $ A.Several emptyMeta + [A.OnlyV emptyMeta $ A.Variant emptyMeta a0 [] p0 + ,specInt "z" $ A.OnlyV emptyMeta $ A.Variant emptyMeta c1 [A.InVariable emptyMeta z] p1 + ,specInt "x" $ specInt "y" $ A.OnlyV emptyMeta $ A.Variant emptyMeta b2 [A.InVariable emptyMeta x,A.InVariable emptyMeta y] p2 + ] + ) + (defineMyProtocol >> defineC) + + --TODO test alt guards + ] + where + -- Various distinct simple processes: + p0 = A.Skip emptyMeta + p1 = A.Main emptyMeta + p2 = A.Stop emptyMeta + c = variable "c" + x = variable "x" + y = variable "y" + z = variable "z" + a0 = simpleName "a0" + b2 = simpleName "b2" + c1 = simpleName "c1" + defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot" A.ProtocolName + (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) + A.Original A.Unplaced + defineC = defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot")) + + specInt s = A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int) + specIntPatt s = tag3 A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int) --Returns the list of tests: tests :: Test @@ -262,8 +426,9 @@ tests = TestList testFunctionsToProcs0 ,testFunctionsToProcs1 ,testFunctionsToProcs2 - ,testTransformConstr0 + ,testInputCase ,testOutExprs + ,testTransformConstr0 ] diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 86cf06f..5e3b181 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -21,6 +21,7 @@ module SimplifyComms where import Control.Monad.State import Data.Generics +import Data.List import qualified AST as A import CompState @@ -69,3 +70,100 @@ outExprs = doGeneric `extM` doProcess abbrevExpr m e = do t <- typeOfExpression e specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev return (nm, A.Spec m specification) + +{- The explanation for this pass is taken from my (Neil's) mailing list post "Case protocols" on tock-discuss, dated 10th October 2007: + +Currently in Tock (from occam) we have CASE statements, and inputs for variant +protocols. They are parsed into separate AST entries, which is sensible. But +then in the backend there is some duplicate code because both things get turned +into some form of switch statement. It would be straightforward to unify the +code in the C/C++ backends, but I was wondering about doing something which +would be a bit cleaner; unifying them in an earlier pass (everything should be +a pass in nanopass :). The idea would be to turn (example is from the occam 2 +manual): + +from.dfs ? CASE + record; rnumber; rlen::buffer + -- process A + error ; enumber; elen::buffer + -- process B + +into: + +INT temp.var: +SEQ + from.dfs ? temp.var + CASE temp.var + 3 + SEQ + from.dfs ? rnumber ; rlen::buffer + -- process A + 4 + SEQ + from.dfs ? enumber ; elen::buffer + -- process B + +Note that the tags are turned into integer literals, which is what happens in +Tock already anyway. Note that in Tock each protocol item is already a +separate communication, so splitting out the sequential inputs is fine. ALTs +would have to be split as follows, by turning: + +ALT + from.dfs ? CASE + request ; query + -- process C + error ; enumber; elen::buffer + -- process D + +into: + +ALT + INT temp.var: + from.dfs ? temp.var + CASE temp.var + 0 + SEQ + from.dfs ? query + -- process C + 1 + SEQ + from.dfs ? enumber ; elen::buffer + -- process D +-} + +transformInputCase :: Data t => t -> PassM t +transformInputCase = doGeneric `extM` doProcess + where + doGeneric :: Data t => t -> PassM t + doGeneric = makeGeneric transformInputCase + + doProcess :: A.Process -> PassM A.Process + doProcess (A.Input m v (A.InputCase m' s)) + = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original + s' <- doStructured v s + return $ A.Seq m $ A.Spec m' spec $ A.Several m' + [A.OnlyP m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)]) + ,A.OnlyP m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s'] + doProcess p = doGeneric p + + doStructured :: A.Variable -> A.Structured -> PassM A.Structured + doStructured v (A.ProcThen m p s) + = do s' <- doStructured v s + p' <- doProcess p + return (A.ProcThen m p' s') + doStructured v (A.Spec m sp st) + = do st' <- doStructured v st + return (A.Spec m sp st') + doStructured v (A.Several m ss) + = do ss' <- mapM (doStructured v) ss + return (A.Several m ss') + doStructured chanVar (A.OnlyV m (A.Variant m' n iis p)) + = do (Right items) <- protocolItems chanVar + let (Just idx) = elemIndex n (fst $ unzip items) + p' <- doProcess p + return $ A.OnlyO m $ A.Option m' [makeConstant m' idx] $ + if (length iis == 0) + then p' + else A.Seq m' $ A.Several m' + [A.OnlyP m' $ A.Input m' chanVar (A.InputSimple m' iis) + ,A.OnlyP (findMeta p') p']