Added tests and implementation for a new pass for transforming input-case statements into case statements
This commit is contained in:
Neil Brown
parent
443b648d73
commit
8b2e14f3bd
|
|
@ -255,6 +255,170 @@ testOutExprs = TestList
|
||||||
xName = simpleName "x"
|
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:
|
--Returns the list of tests:
|
||||||
tests :: Test
|
tests :: Test
|
||||||
tests = TestList
|
tests = TestList
|
||||||
|
|
@ -262,8 +426,9 @@ tests = TestList
|
||||||
testFunctionsToProcs0
|
testFunctionsToProcs0
|
||||||
,testFunctionsToProcs1
|
,testFunctionsToProcs1
|
||||||
,testFunctionsToProcs2
|
,testFunctionsToProcs2
|
||||||
,testTransformConstr0
|
,testInputCase
|
||||||
,testOutExprs
|
,testOutExprs
|
||||||
|
,testTransformConstr0
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -21,6 +21,7 @@ module SimplifyComms where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.Generics
|
import Data.Generics
|
||||||
|
import Data.List
|
||||||
|
|
||||||
import qualified AST as A
|
import qualified AST as A
|
||||||
import CompState
|
import CompState
|
||||||
|
|
@ -69,3 +70,100 @@ outExprs = doGeneric `extM` doProcess
|
||||||
abbrevExpr m e = do t <- typeOfExpression e
|
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
|
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)
|
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']
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user