ddbec737f2
For some reason, the usage check tests are now very slow to run (perhaps because of all the operator definitions added to each one?), which needs further investigation.
713 lines
30 KiB
Haskell
713 lines
30 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | Contains test for various shared passes.
|
|
module PassTest (tests) where
|
|
|
|
import Control.Monad.State hiding (guard)
|
|
import Data.Generics
|
|
import qualified Data.Map as Map
|
|
import Test.HUnit hiding (State)
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Metadata
|
|
import OccamEDSL
|
|
import Pattern
|
|
import SimplifyComms
|
|
import SimplifyExprs
|
|
import TagAST
|
|
import TestUtils
|
|
import TreeUtils
|
|
import Types
|
|
import Unnest
|
|
import Utils
|
|
|
|
m :: Meta
|
|
m = emptyMeta
|
|
|
|
-- | An expression list containing a single value of 0.
|
|
valof0 :: A.Structured A.ExpressionList
|
|
valof0 = A.Only m $ A.ExpressionList m [intLiteral 0]
|
|
|
|
-- | An expression list containing variables with the two given names.
|
|
valofTwo :: String -> String -> A.Structured A.ExpressionList
|
|
valofTwo a b = A.Only m $ A.ExpressionList m [exprVariable a,exprVariable b]
|
|
|
|
-- | Looks up an item from the Items, and attempts to cast it. Fails (via assertions) if
|
|
-- either the item is not found, or if the cast is invalid.
|
|
assertGetItemCast :: Typeable t => String -> Items -> IO t
|
|
assertGetItemCast k kv
|
|
= case (Map.lookup k kv) of
|
|
Nothing -> (assertFailure "Internal error; expected item not present") >> return (undefined)
|
|
Just (ADI v) -> case (cast v) of
|
|
Just v' -> return v'
|
|
Nothing -> (assertFailure $ "Wrong type when casting in assertGetItemCast for key: " ++ k) >> return (undefined)
|
|
|
|
-- | Given a body, returns a function spec:
|
|
singleParamFunc :: A.Structured A.ExpressionList -> A.Specification
|
|
singleParamFunc body = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Left body))
|
|
|
|
singleParamFuncProc :: A.Process -> A.Specification
|
|
singleParamFuncProc body = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Right body))
|
|
|
|
-- | Returns the expected body of the single parameter process (when the function had valof0 as a body)
|
|
singleParamBodyExp :: Pattern -- ^ to match: A.Process
|
|
singleParamBodyExp = tag2 A.Seq DontCare $ mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
|
|
|
-- | Returns the expected specification type of the single parameter process
|
|
singleParamSpecExp :: Pattern -> Pattern -- ^ to match: A.SpecType
|
|
singleParamSpecExp body = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"), tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare)] body
|
|
|
|
-- | Tests a function with a single return, and a single parameter.
|
|
testFunctionsToProcs0 :: Test
|
|
testFunctionsToProcs0 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs0" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = singleParamFunc valof0
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procSpec
|
|
procSpec = singleParamSpecExp singleParamBodyExp
|
|
--check return parameters were defined:
|
|
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
|
|
assertVarDef "testFunctionsToProcs0" state (A.nameName ret0) $
|
|
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs0" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procSpec A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs0" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function with multiple returns, and multiple parameters.
|
|
testFunctionsToProcs1 :: Test
|
|
testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs1 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, A.Recursive) [A.Int,A.Real32]
|
|
[A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (Just $ Left $ valofTwo "param0" "param1"))
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procBody
|
|
procBody = tag4 A.Proc DontCare (A.PlainSpec, A.Recursive)
|
|
[tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"),
|
|
tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"),
|
|
tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare),
|
|
tag3 A.Formal A.Abbrev A.Real32 (Named "ret1" DontCare)] $
|
|
tag2 A.Seq DontCare $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare),tag2 A.Variable DontCare (Named "ret1" DontCare)] $
|
|
tag2 A.ExpressionList DontCare [exprVariable "param0",exprVariable "param1"]
|
|
--check return parameters were defined:
|
|
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
|
|
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
|
|
assertVarDef "testFunctionsToProcs1 B" state (A.nameName ret0) $
|
|
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs1 C" state (A.nameName ret1) $
|
|
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1)
|
|
(A.Declaration m A.Real32) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs1 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procBody A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs1 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function that contains a function.
|
|
-- Currently I have chosen to put DontCare for the body of the function as stored in the NameDef.
|
|
-- This behaviour is not too important, and may change at a later date.
|
|
testFunctionsToProcs2 :: Test
|
|
testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs2 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "fooOuter") (A.Function m (A.PlainSpec,
|
|
A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ Just $ Left $
|
|
A.Spec m (singleParamFunc valof0) valof0)
|
|
exp = tag3 A.Specification DontCare (simpleName "fooOuter") procBodyOuter
|
|
procHeader body = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0"), tag3 A.Formal A.Abbrev A.Int (Named "retOuter0" DontCare)] body
|
|
procBodyOuter = procHeader $
|
|
tag2 A.Seq DontCare $
|
|
mSpecP (tag3 A.Specification DontCare (simpleName "foo") (singleParamSpecExp singleParamBodyExp)) $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "retOuter0" DontCare)] $ tag2 A.ExpressionList DontCare [intLiteral 0]
|
|
|
|
|
|
--check return parameters were defined:
|
|
check (items,state) = do retOuter0 <- ((assertGetItemCast "retOuter0" items) :: IO A.Name)
|
|
ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
|
|
assertVarDef "testFunctionsToProcs2 B" state (A.nameName ret0) $
|
|
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs2 C" state (A.nameName retOuter0) $
|
|
tag7 A.NameDef DontCare (A.nameName retOuter0) (A.nameName retOuter0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs2 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo") (singleParamSpecExp DontCare)
|
|
A.Original A.NameUser A.Unplaced
|
|
assertVarDef "testFunctionsToProcs2 E" state "fooOuter" $
|
|
tag7 A.NameDef DontCare ("fooOuter") ("fooOuter") (procHeader DontCare)
|
|
A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs2 F" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
|
assertEqual "testFunctionsToProcs2 G" (Just [A.Int]) (Map.lookup "fooOuter" (csFunctionReturns state))
|
|
|
|
-- | Tests a function with a single return, and a single parameter, with a Process body
|
|
testFunctionsToProcs3 :: Test
|
|
testFunctionsToProcs3 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs3" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = singleParamFuncProc $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [intLiteral 0]
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procSpec
|
|
procSpec = singleParamSpecExp singleParamBodyExp
|
|
--check return parameters were defined:
|
|
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
|
|
assertVarDef "testFunctionsToProcs3" state (A.nameName ret0) $
|
|
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs3" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procSpec A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs3" (Just [A.Int]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
-- | Tests a function with multiple returns, and multiple parameters.
|
|
testFunctionsToProcs4 :: Test
|
|
testFunctionsToProcs4 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs4 A" exp functionsToProcs orig (return ()) check
|
|
where
|
|
orig = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, A.PlainRec) [A.Int,A.Real32]
|
|
[A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] $
|
|
Just $ Right $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [exprVariable "param0", exprVariable "param1"])
|
|
exp = tag3 A.Specification DontCare (simpleName "foo") procBody
|
|
procBody = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"),
|
|
tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"),
|
|
tag3 A.Formal A.Abbrev A.Int (Named "ret0" DontCare),
|
|
tag3 A.Formal A.Abbrev A.Real32 (Named "ret1" DontCare)] $
|
|
tag2 A.Seq DontCare $
|
|
mOnlyP $
|
|
tag3 A.Assign DontCare [tag2 A.Variable DontCare (Named "ret0" DontCare),tag2 A.Variable DontCare (Named "ret1" DontCare)] $
|
|
tag2 A.ExpressionList DontCare [exprVariable "param0",exprVariable "param1"]
|
|
--check return parameters were defined:
|
|
check (items,state) = do ret0 <- ((assertGetItemCast "ret0" items) :: IO A.Name)
|
|
ret1 <- ((assertGetItemCast "ret1" items) :: IO A.Name)
|
|
assertVarDef "testFunctionsToProcs4 B" state (A.nameName ret0) $
|
|
tag7 A.NameDef DontCare (A.nameName ret0) (A.nameName ret0)
|
|
(A.Declaration m A.Int) A.Abbrev A.NameNonce A.Unplaced
|
|
assertVarDef "testFunctionsToProcs4 C" state (A.nameName ret1) $
|
|
tag7 A.NameDef DontCare (A.nameName ret1) (A.nameName ret1)
|
|
(A.Declaration m A.Real32) A.Abbrev A.NameNonce A.Unplaced
|
|
--check proc was defined:
|
|
assertVarDef "testFunctionsToProcs4 D" state "foo" $
|
|
tag7 A.NameDef DontCare ("foo") ("foo")
|
|
procBody A.Original A.NameUser A.Unplaced
|
|
--check csFunctionReturns was changed:
|
|
assertEqual "testFunctionsToProcs4 E" (Just [A.Int,A.Real32]) (Map.lookup "foo" (csFunctionReturns state))
|
|
|
|
|
|
skipP :: A.Structured A.Process
|
|
skipP = A.Only m (A.Skip m)
|
|
|
|
-- | Tests that a simple constructor (with no expression, nor function call) gets converted into the appropriate initialisation code
|
|
testTransformConstr0 :: Test
|
|
testTransformConstr0 = TestCase $ testPass "transformConstr0" exp transformConstr orig startState
|
|
where
|
|
startState :: State CompState ()
|
|
startState = defineConst "x" A.Int (intLiteral 42)
|
|
|
|
t = A.Array [dimension 10] A.Int
|
|
|
|
orig = A.Spec m (A.Specification m (simpleName "arr") $
|
|
A.Is m A.ValAbbrev t $ A.ActualExpression $ A.Literal m t $ A.ArrayListLiteral m $
|
|
A.Spec m (A.Specification m (simpleName "x") (A.Rep m (A.For m (intLiteral 0) (intLiteral 10)
|
|
(intLiteral 1))))
|
|
$ (A.Only m $ exprVariable "x")) skipP
|
|
exp = nameAndStopCaringPattern "indexVar" "i" $ mkPattern exp'
|
|
exp' = A.Spec m (A.Specification m (simpleName "arr") (A.Declaration m t)) $
|
|
A.ProcThen m
|
|
(A.Seq m $ A.Spec m (A.Specification m (simpleName "i")
|
|
(A.Declaration m A.Int)) $
|
|
A.Several m [A.Only m $ A.Assign m [variable "i"] $
|
|
A.ExpressionList m [intLiteral 0],
|
|
A.Spec m (A.Specification m (simpleName "x") $ A.Rep m (A.For m (intLiteral 0) (intLiteral 10) (intLiteral 1))) $
|
|
A.Several m
|
|
[A.Only m $ A.Assign m
|
|
[A.SubscriptedVariable m (A.Subscript m A.NoCheck $
|
|
exprVariable "i") (variable "arr")] $
|
|
A.ExpressionList m [exprVariable "x"],
|
|
A.Only m $ A.Assign m [variable "i"] $ A.ExpressionList m
|
|
[addExprsInt (intLiteral 1) (exprVariable "i")]]
|
|
]
|
|
)
|
|
skipP
|
|
|
|
|
|
testOutExprs :: Test
|
|
testOutExprs = TestList
|
|
[
|
|
-- Test outputting from an expression:
|
|
TestCase $ testPassWithItemsStateCheck "testOutExprs 0"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outXM 1]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Int)
|
|
(checkTempVarTypes "testOutExprs 0" [("temp_var", A.Int)])
|
|
|
|
-- Test outputting from a variable already:
|
|
,TestCase $ testPass "testOutExprs 1"
|
|
(tag2 A.Seq DontCare $
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[outX])
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outX]
|
|
)
|
|
(return ())
|
|
|
|
-- Test outputting from multiple output items:
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 2"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var0" A.Byte (eXM 1)) $ (abbr "temp_var1" A.Int (intLiteral 2))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
|
,mkPattern outX
|
|
,tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var1" DontCare)))
|
|
]
|
|
)
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [outXM 1,outX,A.OutExpression emptyMeta $ intLiteral 2]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Byte)
|
|
(checkTempVarTypes "testOutExprs 2" [("temp_var0", A.Byte),("temp_var1", A.Int)])
|
|
|
|
-- Test an OutCounted
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 3"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Byte (eXM 1))
|
|
(mOnlyP $ tag3 A.Output emptyMeta chan
|
|
[tag3 A.OutCounted emptyMeta
|
|
(tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var0" DontCare)))
|
|
(exprVariable "x")
|
|
]
|
|
)
|
|
)
|
|
outExprs (
|
|
A.Output emptyMeta chan [A.OutCounted emptyMeta (eXM 1) (exprVariable "x")]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Byte)
|
|
(checkTempVarTypes "testOutExprs 3" [("temp_var", A.Byte)])
|
|
|
|
-- Test that OutputCase is also processed:
|
|
,TestCase $ testPassWithItemsStateCheck "testOutExprs 4"
|
|
(tag2 A.Seq DontCare $ (abbr "temp_var" A.Int (eXM 1))
|
|
(mOnlyP $ tag4 A.OutputCase emptyMeta chan (simpleName "foo")
|
|
[tag2 A.OutExpression emptyMeta (tag2 A.ExprVariable DontCare (tag2 A.Variable DontCare (Named "temp_var" DontCare)))])
|
|
)
|
|
outExprs (
|
|
A.OutputCase emptyMeta chan (simpleName "foo") [outXM 1]
|
|
)
|
|
(defineName (xName) $ simpleDefDecl "x" A.Int)
|
|
(checkTempVarTypes "testOutExprs 3" [("temp_var", A.Int)])
|
|
|
|
-- Test that an empty outputcase works okay:
|
|
|
|
,TestCase $ testPass "testOutExprs 5"
|
|
(tag2 A.Seq DontCare $
|
|
(mOnlyP $ A.OutputCase emptyMeta chan (simpleName "foo") [])
|
|
)
|
|
outExprs (
|
|
A.OutputCase emptyMeta chan (simpleName "foo") []
|
|
)
|
|
(return ())
|
|
|
|
]
|
|
where
|
|
outX = A.OutExpression emptyMeta $ exprVariable "x"
|
|
outXM n = A.OutExpression emptyMeta $ eXM n
|
|
eXM n = buildExpr $ Dy (Var "x") "-" (Lit $ intLiteral n)
|
|
|
|
abbr key t e = mSpecP
|
|
(tag3 A.Specification DontCare (Named key DontCare)
|
|
$ mIs A.ValAbbrev t
|
|
$ mActualExpression' e)
|
|
|
|
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
|
|
-}
|
|
testOccamPassTransform "testInputCase 0" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- 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
|
|
-}
|
|
,testOccamPassTransform "testInputCase 1" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)
|
|
,inputCaseOption (c1, [oZ], p1)
|
|
,inputCaseOption (b2, [oX, oY], p2)
|
|
]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)
|
|
,caseOption ([2 :: Int], oSEQ
|
|
[oC *? oZ
|
|
,p1])
|
|
,caseOption ([1 :: Int], oSEQ
|
|
[oC *? sequence [oX, oY]
|
|
,p2])
|
|
]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- 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
|
|
-}
|
|
,testOccamPassTransform "testInputCase 2" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)
|
|
,decl (return A.Int) oZ [inputCaseOption (c1, [oZ], p1)]
|
|
,decl (return A.Int) oX
|
|
[decl (return A.Int) oY
|
|
[inputCaseOption (b2, [oX, oY], p2)]]
|
|
]
|
|
)
|
|
`becomes`
|
|
oSEQ
|
|
[declNonce (return A.Int) oA
|
|
[oC *? oA
|
|
,oCASE oA
|
|
[caseOption ([0 :: Int], p0)
|
|
,decl (return A.Int) oZ [caseOption ([2 :: Int], oSEQ
|
|
[oC *? oZ
|
|
,p1])]
|
|
,decl (return A.Int) oX
|
|
[decl (return A.Int) oY
|
|
[caseOption ([1 :: Int], oSEQ
|
|
[oC *? sequence [oX, oY]
|
|
,p2])]]
|
|
]
|
|
]
|
|
]
|
|
) transformInputCase
|
|
|
|
-- Input that only involves tags:
|
|
{-
|
|
The idea is to transform:
|
|
ALT
|
|
c ? CASE
|
|
a0
|
|
--Process p0
|
|
into:
|
|
ALT
|
|
INT tag:
|
|
c ? tag
|
|
CASE tag
|
|
a0
|
|
--Process p0
|
|
-}
|
|
,testOccamPassTransform "testInputCase 100" (nameAndStopCaringPattern "tag" "A") (
|
|
defineProtocolAndC $
|
|
(oALT
|
|
[guard (oC *? oCASEinput
|
|
[inputCaseOption (a0, [], p0)], return $ A.Skip emptyMeta)
|
|
]
|
|
)
|
|
`becomes`
|
|
oALT
|
|
[declNonce (return A.Int) oA
|
|
[guard (oC *? oA,
|
|
oCASE oA
|
|
[caseOption ([0 :: Int], p0)])
|
|
]
|
|
]
|
|
) transformInputCase
|
|
]
|
|
where
|
|
a0 = simpleName "a0"
|
|
b2 = simpleName "b2"
|
|
c1 = simpleName "c1"
|
|
|
|
defineProtocolAndC :: Occ (A.Structured A.Process) -> Occ (A.Structured A.Process)
|
|
defineProtocolAndC =
|
|
decl' (simpleName "prot")
|
|
(A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])])
|
|
A.Original A.NameUser
|
|
. singleton . decl (return $ A.Chan (A.ChanAttributes A.Unshared A.Unshared)
|
|
(A.UserProtocol $ simpleName "prot")) oC . singleton
|
|
|
|
testTransformProtocolInput :: Test
|
|
testTransformProtocolInput = TestList
|
|
[
|
|
TestCase $ testPass "testTransformProtocolInput0"
|
|
(seqItems [ii0])
|
|
transformProtocolInput (seqItems [ii0])
|
|
(return ())
|
|
,TestCase $ testPass "testTransformProtocolInput1"
|
|
(A.Seq emptyMeta $ A.Several emptyMeta $ map onlySingle [ii0, ii1, ii2])
|
|
transformProtocolInput (seqItems [ii0, ii1, ii2])
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput2"
|
|
(A.Alt emptyMeta False $ onlySingleAlt ii0)
|
|
transformProtocolInput (A.Alt emptyMeta False $ onlySingleAlt ii0)
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput3"
|
|
(A.Alt emptyMeta True $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c") (A.InputSimple emptyMeta [ii0]) $
|
|
A.Seq emptyMeta $ A.Several emptyMeta $ onlySingle ii1 : [A.Only emptyMeta $ A.Skip emptyMeta])
|
|
transformProtocolInput (A.Alt emptyMeta True $ A.Only emptyMeta $ altItems [ii0, ii1])
|
|
(return ())
|
|
|
|
,TestCase $ testPass "testTransformProtocolInput4"
|
|
(A.Alt emptyMeta False $ A.Only emptyMeta $ A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c") (A.InputSimple emptyMeta [ii0]) $
|
|
A.Seq emptyMeta $ A.Several emptyMeta $ map onlySingle [ii1,ii2] ++ [A.Only emptyMeta $ A.Skip emptyMeta])
|
|
transformProtocolInput (A.Alt emptyMeta False $ A.Only emptyMeta $ altItems [ii0, ii1, ii2])
|
|
(return ())
|
|
]
|
|
where
|
|
ii0 = A.InVariable emptyMeta (variable "x")
|
|
ii1 = A.InCounted emptyMeta (variable "y") (variable "z")
|
|
ii2 = A.InVariable emptyMeta (variable "a")
|
|
|
|
onlySingle = A.Only emptyMeta . A.Input emptyMeta (variable "c") . A.InputSimple emptyMeta . singleton
|
|
onlySingleAlt = A.Only emptyMeta . flip (A.Alternative emptyMeta (A.True
|
|
emptyMeta) (variable "c")) (A.Skip emptyMeta) . A.InputSimple emptyMeta . singleton
|
|
seqItems = A.Input emptyMeta (variable "c") . A.InputSimple emptyMeta
|
|
altItems = flip (A.Alternative emptyMeta (A.True emptyMeta) (variable "c")) (A.Skip emptyMeta) . A.InputSimple emptyMeta
|
|
|
|
|
|
testPullRepCounts :: Test
|
|
testPullRepCounts = TestList
|
|
[
|
|
testUnchanged 4 $ A.If emptyMeta
|
|
|
|
,forAllThree $ \blockType -> testOccamPassTransform "testPullRepCounts 5" (nameAndStopCaringPattern "nonce" "A")
|
|
(blockType
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6) (intLiteral 1)))
|
|
A.Original A.NameUser []
|
|
]
|
|
`becomes`
|
|
blockType
|
|
[decl' (simpleName "A")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 6) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "A") (intLiteral 1)))
|
|
A.Original A.NameUser []
|
|
]
|
|
]
|
|
) pullRepCounts
|
|
|
|
,forAllThree $ \blockType -> testOccamPassTransform "testPullRepCounts 6"
|
|
(nameAndStopCaringPattern "nonce1" "A" . nameAndStopCaringPattern "nonce2" "B")
|
|
(blockType
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6) (intLiteral 1)))
|
|
A.Original A.NameUser
|
|
[decl' (simpleName "Y")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 1) (intLiteral 8) (intLiteral 2)))
|
|
A.Original A.NameUser []
|
|
]
|
|
]
|
|
`becomes`
|
|
blockType
|
|
[decl' (simpleName "A")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 6) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "X")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "A") (intLiteral 1)))
|
|
A.Original A.NameUser
|
|
[decl' (simpleName "B")
|
|
(A.Is emptyMeta A.ValAbbrev A.Int $ A.ActualExpression $ intLiteral 8) A.ValAbbrev A.NameNonce
|
|
[decl' (simpleName "Y")
|
|
(A.Rep emptyMeta (A.For emptyMeta (intLiteral 1) (exprVariable "B")
|
|
(intLiteral 2)))
|
|
A.Original A.NameUser
|
|
[]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
) pullRepCounts
|
|
]
|
|
where
|
|
-- Not for PAR any more, that gets pulled up further
|
|
forAllThree :: (forall a. Data a => ([Occ (A.Structured a)] -> Occ A.Process) -> Test) -> Test
|
|
forAllThree f = TestList [f oSEQ, f oALT]
|
|
|
|
testUnchanged :: Data a => Int -> (A.Structured a -> A.Process) -> Test
|
|
testUnchanged n f = TestCase $ testPass
|
|
("testPullRepCounts/testUnchanged " ++ show n)
|
|
code
|
|
pullRepCounts code
|
|
(return ())
|
|
where
|
|
code = (f $ A.Spec emptyMeta (A.Specification emptyMeta (simpleName
|
|
"i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 5)
|
|
(intLiteral 1))) $ A.Several emptyMeta [])
|
|
|
|
|
|
testRemoveNesting :: Test
|
|
testRemoveNesting = TestList
|
|
[
|
|
test "Blank PROC" $
|
|
oPROC "foo" [] (
|
|
oSKIP
|
|
) oempty
|
|
|
|
, test "Nested PROC" $
|
|
(oPROC "bar" [] (
|
|
oSEQ
|
|
[decl oINT oX []]
|
|
) $
|
|
oPROC "foo" [] (
|
|
oSEQ
|
|
[decl oINT oX $
|
|
[oX *:= return (0::Int)
|
|
,oX *:= return (1::Int)]]
|
|
) oempty)
|
|
`shouldComeFrom`
|
|
oPROC "foo" [] (
|
|
oSEQ
|
|
[oPROC "bar" [] (
|
|
oSEQ
|
|
[decl oINT oX []]
|
|
) $
|
|
decl oINT oX
|
|
[oX *:= return (0::Int)
|
|
,oX *:= return (1::Int)]]
|
|
) oempty
|
|
]
|
|
where
|
|
test :: String -> Occ A.AST -> Test
|
|
test name x = testOccamPass name x removeNesting
|
|
|
|
|
|
--Returns the list of tests:
|
|
tests :: Test
|
|
tests = TestLabel "PassTest" $ TestList
|
|
[
|
|
testFunctionsToProcs0
|
|
,testFunctionsToProcs1
|
|
,testFunctionsToProcs2
|
|
,testFunctionsToProcs3
|
|
,testFunctionsToProcs4
|
|
,testInputCase
|
|
,testOutExprs
|
|
,testPullRepCounts
|
|
,testRemoveNesting
|
|
,testTransformConstr0
|
|
,testTransformProtocolInput
|
|
]
|
|
|
|
|