Removed the Rep constructor from Structured and instead added a Rep constructor to SpecType
This way, all replicators are declared like other names, and their scope is considered replicated. This simplifies the code a little. Fixes #55
This commit is contained in:
Neil Brown
parent
9066d4112b
commit
41ff60cb78
|
|
@ -122,7 +122,8 @@ cgenOps = GenOps {
|
|||
genProcCall = cgenProcCall,
|
||||
genProcess = cgenProcess,
|
||||
genRecordTypeSpec = cgenRecordTypeSpec,
|
||||
genReplicator = cgenReplicator,
|
||||
genReplicatorStart = cgenReplicatorStart,
|
||||
genReplicatorEnd = cgenReplicatorEnd,
|
||||
genReplicatorLoop = cgenReplicatorLoop,
|
||||
genRetypeSizes = cgenRetypeSizes,
|
||||
genSeq = cgenSeq,
|
||||
|
|
@ -282,7 +283,6 @@ cgenOverArray m var func
|
|||
|
||||
-- | Generate code for one of the Structured types.
|
||||
cgenStructured :: Data a => A.Structured a -> (Meta -> a -> CGen ()) -> CGen ()
|
||||
cgenStructured (A.Rep _ rep s) def = call genReplicator rep (call genStructured s def)
|
||||
cgenStructured (A.Spec _ spec s) def = call genSpec spec (call genStructured s def)
|
||||
cgenStructured (A.ProcThen _ p s) def = call genProcess p >> call genStructured s def
|
||||
cgenStructured (A.Several _ ss) def = sequence_ [call genStructured s def | s <- ss]
|
||||
|
|
@ -1078,20 +1078,20 @@ cgenOutputItem c (A.OutExpression m e)
|
|||
--}}}
|
||||
|
||||
--{{{ replicators
|
||||
cgenReplicator :: A.Replicator -> CGen () -> CGen ()
|
||||
cgenReplicator rep body
|
||||
cgenReplicatorStart :: A.Name -> A.Replicator -> CGen ()
|
||||
cgenReplicatorStart n rep
|
||||
= do tell ["for("]
|
||||
call genReplicatorLoop rep
|
||||
call genReplicatorLoop n rep
|
||||
tell ["){"]
|
||||
body
|
||||
tell ["}"]
|
||||
cgenReplicatorEnd :: A.Replicator -> CGen ()
|
||||
cgenReplicatorEnd rep = tell ["}"]
|
||||
|
||||
isZero :: A.Expression -> Bool
|
||||
isZero (A.Literal _ A.Int (A.IntLiteral _ "0")) = True
|
||||
isZero _ = False
|
||||
|
||||
cgenReplicatorLoop :: A.Replicator -> CGen ()
|
||||
cgenReplicatorLoop (A.For m index base count)
|
||||
cgenReplicatorLoop :: A.Name -> A.Replicator -> CGen ()
|
||||
cgenReplicatorLoop index (A.For m base count)
|
||||
= if isZero base
|
||||
then simple
|
||||
else general
|
||||
|
|
@ -1120,7 +1120,7 @@ cgenReplicatorLoop (A.For m index base count)
|
|||
tell [";", counter, ">0;", counter, "--,"]
|
||||
genName index
|
||||
tell ["++"]
|
||||
cgenReplicatorLoop _ = cgenMissing "ForEach loops not yet supported in the C backend"
|
||||
cgenReplicatorLoop _ _ = cgenMissing "ForEach loops not yet supported in the C backend"
|
||||
--}}}
|
||||
|
||||
--{{{ abbreviations
|
||||
|
|
@ -1349,6 +1349,8 @@ cintroduceSpec (A.Specification _ n (A.Retypes m am t v))
|
|||
rhs
|
||||
tell [";"]
|
||||
call genRetypeSizes m t n origT v
|
||||
cintroduceSpec (A.Specification _ n (A.Rep m rep))
|
||||
= call genReplicatorStart n rep
|
||||
--cintroduceSpec (A.Specification _ n (A.RetypesExpr _ am t e))
|
||||
cintroduceSpec n = call genMissing $ "introduceSpec " ++ show n
|
||||
|
||||
|
|
@ -1376,6 +1378,8 @@ cremoveSpec (A.Specification m n (A.Declaration _ t))
|
|||
Nothing -> return ()
|
||||
where
|
||||
var = A.Variable m n
|
||||
cremoveSpec (A.Specification _ n (A.Rep _ rep))
|
||||
= call genReplicatorEnd rep
|
||||
cremoveSpec _ = return ()
|
||||
|
||||
cgenSpecMode :: A.SpecMode -> CGen ()
|
||||
|
|
@ -1691,7 +1695,6 @@ cgenAlt isPri s
|
|||
tell [label, ":\n;\n"]
|
||||
where
|
||||
containsTimers :: A.Structured A.Alternative -> Bool
|
||||
containsTimers (A.Rep _ _ s) = containsTimers s
|
||||
containsTimers (A.Spec _ _ s) = containsTimers s
|
||||
containsTimers (A.ProcThen _ _ s) = containsTimers s
|
||||
containsTimers (A.Only _ a)
|
||||
|
|
|
|||
|
|
@ -155,10 +155,10 @@ data GenOps = GenOps {
|
|||
genProcCall :: A.Name -> [A.Actual] -> CGen (),
|
||||
genProcess :: A.Process -> CGen (),
|
||||
genRecordTypeSpec :: A.Name -> Bool -> [(A.Name, A.Type)] -> CGen (),
|
||||
-- | Generates a replicator loop, given the replicator and body
|
||||
genReplicator :: A.Replicator -> CGen () -> CGen (),
|
||||
genReplicatorStart :: A.Name -> A.Replicator -> CGen (),
|
||||
genReplicatorEnd :: A.Replicator -> CGen (),
|
||||
-- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator)
|
||||
genReplicatorLoop :: A.Replicator -> CGen (),
|
||||
genReplicatorLoop :: A.Name -> A.Replicator -> CGen (),
|
||||
genRetypeSizes :: Meta -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen (),
|
||||
genSeq :: A.Structured A.Process -> CGen (),
|
||||
genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen (),
|
||||
|
|
|
|||
|
|
@ -715,9 +715,9 @@ cppgenListConcat a b
|
|||
call genExpression b
|
||||
tell [")"]
|
||||
|
||||
cppgenReplicatorLoop :: A.Replicator -> CGen ()
|
||||
cppgenReplicatorLoop rep@(A.For {}) = cgenReplicatorLoop rep
|
||||
cppgenReplicatorLoop (A.ForEach m n (A.ExprVariable _ v))
|
||||
cppgenReplicatorLoop :: A.Name -> A.Replicator -> CGen ()
|
||||
cppgenReplicatorLoop n rep@(A.For {}) = cgenReplicatorLoop n rep
|
||||
cppgenReplicatorLoop n (A.ForEach m (A.ExprVariable _ v))
|
||||
= do t <- astTypeOf v
|
||||
call genType t
|
||||
tell ["::iterator "]
|
||||
|
|
|
|||
|
|
@ -437,8 +437,10 @@ testOverArray = TestList $ map testOverArray'
|
|||
testReplicator :: Test
|
||||
testReplicator = TestList
|
||||
[
|
||||
testBothSame "testReplicator 0" "for(int foo=0;foo<10;foo++){@}" (tcall2 genReplicator (A.For emptyMeta foo (intLiteral 0) (intLiteral 10)) at)
|
||||
,testBothSameR "testReplicator 1" "for\\(int ([[:alnum:]_]+)=10,foo=1;\\1>0;\\1--,foo\\+\\+\\)\\{@\\}" (tcall2 genReplicator (A.For emptyMeta foo (intLiteral 1) (intLiteral 10)) at)
|
||||
testBothSame "testReplicator 0" "for(int foo=0;foo<10;foo++){" (tcall2 genReplicatorStart foo
|
||||
(A.For emptyMeta (intLiteral 0) (intLiteral 10)))
|
||||
,testBothSameR "testReplicator 1" "for\\(int ([[:alnum:]_]+)=10,foo=1;\\1>0;\\1--,foo\\+\\+\\)\\{" (tcall2 genReplicatorStart
|
||||
foo (A.For emptyMeta (intLiteral 1) (intLiteral 10)))
|
||||
]
|
||||
|
||||
testDeclaration :: Test
|
||||
|
|
|
|||
|
|
@ -68,13 +68,13 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $
|
|||
getArrayIndex _ = Nothing
|
||||
|
||||
-- Turns a replicator into background knowledge about that replicator
|
||||
makeRepBounds :: A.Replicator -> [BackgroundKnowledge]
|
||||
makeRepBounds (A.For m n from for) = [LessThanOrEqual from ev, LessThanOrEqual ev $ A.Dyadic m A.Subtr (A.Dyadic m A.Add from for) (makeConstant m 1)]
|
||||
makeRepBounds :: (A.Name, A.Replicator) -> [BackgroundKnowledge]
|
||||
makeRepBounds (n, A.For m from for) = [LessThanOrEqual from ev, LessThanOrEqual ev $ A.Dyadic m A.Subtr (A.Dyadic m A.Add from for) (makeConstant m 1)]
|
||||
where
|
||||
ev = A.ExprVariable m (A.Variable m n)
|
||||
|
||||
-- Gets all the replicators present in the argument
|
||||
listReplicators :: ParItems UsageLabel -> [A.Replicator]
|
||||
listReplicators :: ParItems UsageLabel -> [(A.Name, A.Replicator)]
|
||||
listReplicators p = mapMaybe nodeRep $ flattenParItems p
|
||||
|
||||
-- Checks the given ParItems of writes and reads against each other. The
|
||||
|
|
@ -244,7 +244,7 @@ data ArrayAccessType = AAWrite | AARead
|
|||
-- | Transforms the ParItems (from the control-flow graph) into the more suitable ArrayAccess
|
||||
-- data type used by this array usage checker.
|
||||
parItemToArrayAccessM :: Monad m =>
|
||||
( [(A.Replicator, Bool)] ->
|
||||
( [((A.Name, A.Replicator), Bool)] ->
|
||||
a ->
|
||||
m [(label, ArrayAccessType, (EqualityConstraintEquation, EqualityProblem, InequalityProblem))]
|
||||
) ->
|
||||
|
|
@ -441,7 +441,7 @@ makeEquations otherInfo accesses bound
|
|||
-- | Given a list of replicators (marked enabled\/disabled by a flag), the writes and reads,
|
||||
-- turns them into a single list of accesses with all the relevant information. The writes and reads
|
||||
-- can be grouped together because they are differentiated by the ArrayAccessType in the result
|
||||
mkEq :: [(A.Replicator, Bool)] ->
|
||||
mkEq :: [((A.Name, A.Replicator), Bool)] ->
|
||||
([A.Expression], [A.Expression]) ->
|
||||
StateT [(CoeffIndex, CoeffIndex)]
|
||||
(StateT VarMap (Either String))
|
||||
|
|
@ -452,8 +452,8 @@ makeEquations otherInfo accesses bound
|
|||
ws' = zip (repeat AAWrite) ws
|
||||
rs' = zip (repeat AARead) rs
|
||||
|
||||
makeRepVarEq :: (A.Replicator, Bool) -> StateT VarMap (Either String) (A.Variable, EqualityConstraintEquation, EqualityConstraintEquation)
|
||||
makeRepVarEq (A.For m varName from for, _)
|
||||
makeRepVarEq :: ((A.Name, A.Replicator), Bool) -> StateT VarMap (Either String) (A.Variable, EqualityConstraintEquation, EqualityConstraintEquation)
|
||||
makeRepVarEq ((varName, A.For m from for), _)
|
||||
= do from' <- makeSingleEq from "replication start"
|
||||
upper <- makeSingleEq (A.Dyadic m A.Subtr (A.Dyadic m A.Add for from) (makeConstant m 1)) "replication count"
|
||||
return (A.Variable m varName, from', upper)
|
||||
|
|
@ -472,9 +472,9 @@ makeEquations otherInfo accesses bound
|
|||
_ -> throwError "Replicated group found unexpectedly"
|
||||
|
||||
-- | Turns all instances of the variable from the given replicator into their primed version in the given expression
|
||||
mirrorFlaggedVars :: [FlattenedExp] -> (A.Replicator,Bool) -> StateT [(CoeffIndex,CoeffIndex)] (StateT VarMap (Either String)) [FlattenedExp]
|
||||
mirrorFlaggedVars :: [FlattenedExp] -> ((A.Name, A.Replicator),Bool) -> StateT [(CoeffIndex,CoeffIndex)] (StateT VarMap (Either String)) [FlattenedExp]
|
||||
mirrorFlaggedVars exp (_,False) = return exp
|
||||
mirrorFlaggedVars exp (A.For m varName from for, True)
|
||||
mirrorFlaggedVars exp ((varName, A.For m from for), True)
|
||||
= do varIndexes <- lift $ seqPair (varIndex (Scale 1 (A.ExprVariable emptyMeta var,0)), varIndex (Scale 1 (A.ExprVariable emptyMeta var,1)))
|
||||
modify (varIndexes :)
|
||||
return $ setIndexVar var 1 exp
|
||||
|
|
|
|||
|
|
@ -468,7 +468,7 @@ testMakeEquations = TestLabel "testMakeEquations" $ TestList
|
|||
testRep' (ind, problems, (repName, repFrom, repFor), exprs, upperBound) =
|
||||
TestCase $ assertEquivalentProblems ("testMakeEquations " ++ show ind)
|
||||
(map (\((a0,a1),b,c,d) -> ((lookup exprs a0, lookup exprs a1), b, makeConsistent c d)) problems)
|
||||
=<< (checkRight $ makeEquations [] (RepParItem (A.For emptyMeta (simpleName repName) repFrom repFor) $ makeParItems exprs) upperBound)
|
||||
=<< (checkRight $ makeEquations [] (RepParItem (simpleName "i", A.For emptyMeta repFrom repFor) $ makeParItems exprs) upperBound)
|
||||
|
||||
pairLatterTwo (l,a,b,c) = (l,a,(b,c))
|
||||
|
||||
|
|
|
|||
|
|
@ -37,26 +37,27 @@ joinCheckParFunctions f g x = seqPair (f x, g x)
|
|||
|
||||
-- | Given a function to check a list of graph labels and a flow graph,
|
||||
-- checks all PAR items in the flow graph
|
||||
checkPar :: forall m a b. Monad m => (a -> Maybe A.Replicator) -> ((Meta, ParItems a) -> m b) -> FlowGraph m a -> m [b]
|
||||
checkPar :: forall m a b. Monad m => (a -> Maybe (A.Name, A.Replicator)) -> ((Meta, ParItems a) -> m b) -> FlowGraph m a -> m [b]
|
||||
checkPar getRep f g = mapM f =<< allParItems
|
||||
where
|
||||
allStartParEdges :: m (Map.Map Int (Maybe A.Replicator, [(Node,Node)]))
|
||||
allStartParEdges :: m (Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
||||
allStartParEdges = foldM helper Map.empty parEdges
|
||||
where
|
||||
parEdges = mapMaybe tagStartParEdge $ labEdges g
|
||||
|
||||
helper :: Map.Map Int (Maybe A.Replicator, [(Node,Node)]) -> (Node,Node,Int) ->
|
||||
m (Map.Map Int (Maybe A.Replicator, [(Node,Node)]))
|
||||
helper :: Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]) -> (Node,Node,Int) ->
|
||||
m (Map.Map Int (Maybe (A.Name, A.Replicator), [(Node,Node)]))
|
||||
helper mp (s,e,n)
|
||||
| r == Nothing = fail "Could not find label for node"
|
||||
| prevR == Nothing || prevR == r = return $ Map.insertWith add n (join r,[(s,e)]) mp
|
||||
| otherwise = fail $ "Replicator not the same for all nodes at beginning of PAR: "
|
||||
++ show r ++ " ; " ++ show (Map.lookup n mp :: Maybe (Maybe A.Replicator, [(Node, Node)]))
|
||||
++ show r ++ " ; " ++ show (Map.lookup n mp :: Maybe (Maybe (A.Name,
|
||||
A.Replicator), [(Node, Node)]))
|
||||
where
|
||||
add (newR, newNS) (oldR, oldNS) = (newR, oldNS ++ newNS)
|
||||
prevR :: Maybe (Maybe A.Replicator)
|
||||
prevR :: Maybe (Maybe (A.Name, A.Replicator))
|
||||
prevR = liftM fst $ Map.lookup n mp
|
||||
r :: Maybe (Maybe A.Replicator)
|
||||
r :: Maybe (Maybe (A.Name, A.Replicator))
|
||||
r = lab g s >>* (getRep . getNodeData)
|
||||
|
||||
tagStartParEdge :: (Node,Node,EdgeLabel) -> Maybe (Node,Node,Int)
|
||||
|
|
@ -76,10 +77,10 @@ checkPar getRep f g = mapM f =<< allParItems
|
|||
where
|
||||
distinctItems = nub $ map fst ns
|
||||
|
||||
findMetaAndNodes :: (Int,(Maybe A.Replicator, [(Node,Node)])) -> m (Meta, ParItems a)
|
||||
findMetaAndNodes :: (Int,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> m (Meta, ParItems a)
|
||||
findMetaAndNodes x@(_,(_,ns)) = seqPair (checkAndGetMeta ns, return $ findNodes x)
|
||||
|
||||
findNodes :: (Int,(Maybe A.Replicator, [(Node,Node)])) -> ParItems a
|
||||
findNodes :: (Int,(Maybe (A.Name, A.Replicator), [(Node,Node)])) -> ParItems a
|
||||
findNodes (n, (mr, ses)) = maybe id RepParItem mr $ ParItems $ map (makeSeqItems n . snd) ses
|
||||
|
||||
makeSeqItems :: Int -> Node -> ParItems a
|
||||
|
|
|
|||
|
|
@ -65,11 +65,11 @@ data Decl = ScopeIn Bool String | ScopeOut String deriving (Show, Eq)
|
|||
data ParItems a
|
||||
= SeqItems [a] -- ^ A list of items that happen only in sequence (i.e. none are in parallel with each other)
|
||||
| ParItems [ParItems a] -- ^ A list of items that are all in parallel with each other
|
||||
| RepParItem A.Replicator (ParItems a) -- ^ A list of replicated items that happen in parallel
|
||||
| RepParItem (A.Name, A.Replicator) (ParItems a) -- ^ A list of replicated items that happen in parallel
|
||||
deriving (Show)
|
||||
|
||||
data UsageLabel = Usage
|
||||
{nodeRep :: Maybe A.Replicator
|
||||
{nodeRep :: Maybe (A.Name, A.Replicator)
|
||||
,nodeDecl :: Maybe Decl
|
||||
,nodeVars :: Vars}
|
||||
|
||||
|
|
@ -211,8 +211,8 @@ getVarFormals m = mapUnionVars (getVarFormal m)
|
|||
getVarFormal m (A.Formal _ _ n) = processVarW $ A.Variable m n
|
||||
|
||||
getVarRepExp :: A.Replicator -> Vars
|
||||
getVarRepExp (A.For _ _ e0 e1) = getVarExp e0 `unionVars` getVarExp e1
|
||||
getVarRepExp (A.ForEach _ _ e) = getVarExp e
|
||||
getVarRepExp (A.For _ e0 e1) = getVarExp e0 `unionVars` getVarExp e1
|
||||
getVarRepExp (A.ForEach _ e) = getVarExp e
|
||||
|
||||
getVarAlternative :: A.Alternative -> Vars
|
||||
getVarAlternative = const emptyVars -- TODO
|
||||
|
|
@ -226,7 +226,7 @@ labelFunctions = GLF
|
|||
,labelProcess = singleM getVarProc
|
||||
,labelAlternative = single getVarAlternative
|
||||
,labelStartNode = single (uncurry getVarFormals)
|
||||
,labelReplicator = \x -> return (Usage (Just x) Nothing (getVarRepExp x))
|
||||
,labelReplicator = \x -> return (Usage (Just x) Nothing (getVarRepExp $ snd x))
|
||||
--don't forget about the variables used as initialisers in declarations (hence getVarSpec)
|
||||
,labelScopeIn = pair (getDecl $ ScopeIn False) getVarSpec
|
||||
,labelScopeOut = pair (getDecl ScopeOut) (const emptyVars)
|
||||
|
|
|
|||
|
|
@ -428,8 +428,9 @@ instance ShowRain A.Expression where
|
|||
showRainM (A.OffsetOf _ t n) = tell ["OFFSETOF("] >> showRainM t >> tell [" , "] >> showName n >> tell [")"]
|
||||
showRainM (A.ExprConstr _ (A.RangeConstr _ _ e e'))
|
||||
= showRainM e >> tell [".."] >> showRainM e'
|
||||
showRainM (A.ExprConstr _ (A.RepConstr _ _ r e))
|
||||
= tell ["["] >> showRainM e >> tell ["|"] >> showRainM r >> tell ["]"]
|
||||
showRainM (A.ExprConstr _ (A.RepConstr _ _ n r e))
|
||||
= tell ["["] >> showRainM e >> tell ["|"] >> showName n >>
|
||||
showRainM r >> tell ["]"]
|
||||
|
||||
instance ShowOccam A.Formal where
|
||||
showOccamM (A.Formal am t n) = (maybeVal am)
|
||||
|
|
@ -507,6 +508,11 @@ instance ShowOccam A.Specification where
|
|||
= showOccamLine $ maybeVal am >> showOccamM t >> space >> showName n >> tell [" RETYPES "] >> showOccamM v >> colon
|
||||
showOccamM (A.Specification _ n (A.RetypesExpr _ am t e))
|
||||
= showOccamLine $ maybeVal am >> showOccamM t >> space >> showName n >> tell [" RETYPES "] >> showOccamM e >> colon
|
||||
showOccamM (A.Specification _ n (A.Rep _ rep))
|
||||
= do item <- currentContext
|
||||
(showOccamLine (return (item ++ " ") >> showName n >> showOccamM rep))
|
||||
-- TODO handle the indent
|
||||
|
||||
|
||||
showProtocolItem :: (A.Name, [A.Type]) -> CodeWriter ()
|
||||
showProtocolItem (n,ts) = sequence_ $ intersperse (tell [" ; "]) $
|
||||
|
|
@ -554,8 +560,8 @@ instance ShowOccam A.Alternative where
|
|||
occamOutdent
|
||||
|
||||
instance ShowOccam A.Replicator where
|
||||
showOccamM (A.For _ n start count) = tell [" "] >> showName n >> tell [" = "] >> showOccamM start >> tell [" FOR "] >> showOccamM count
|
||||
showOccamM (A.ForEach _ n e) = tell [" "] >> showName n >> tell [" IN "] >> showOccamM e
|
||||
showOccamM (A.For _ start count) = tell [" = "] >> showOccamM start >> tell [" FOR "] >> showOccamM count
|
||||
showOccamM (A.ForEach _ e) = tell [" IN "] >> showOccamM e
|
||||
|
||||
instance ShowOccam A.Choice where
|
||||
showOccamM (A.Choice _ e p) = showOccamLine (showOccamM e) >> occamBlock (showOccamM p)
|
||||
|
|
@ -566,9 +572,6 @@ instance ShowOccam A.Option where
|
|||
|
||||
instance (Data a, ShowOccam a) => ShowOccam (A.Structured a) where
|
||||
showOccamM (A.Spec _ spec str) = showOccamM spec >> showOccamM str
|
||||
showOccamM (A.Rep _ rep str)
|
||||
= do item <- currentContext
|
||||
(showOccamLine (return (item ++ " ") >> showOccamM rep)) >> occamIndent >> showOccamM str >> occamOutdent
|
||||
showOccamM (A.Only _ p) = showOccamM p
|
||||
showOccamM (A.Several _ ss) = sequence_ $ map showOccamM ss
|
||||
showOccamM (A.ProcThen _ p str) = showOccamLine (tell ["VALOF"]) >> occamBlock (showOccamM p >> showOccamLine (tell ["RESULT "] >> showOccamM str))
|
||||
|
|
@ -587,19 +590,23 @@ instance ShowRain A.ExpressionList where
|
|||
showRainM (A.ExpressionList _ [e]) = showRainM e
|
||||
|
||||
outerOccam :: (Data a, ShowOccam a) => String -> A.Structured a -> CodeWriter ()
|
||||
outerOccam keyword (A.Rep _ rep str)
|
||||
{- TODO get replicators working properly
|
||||
outerOccam keyword (A.Rep _ n rep str)
|
||||
= do showOccamLine (tell [keyword] >> showOccamM rep)
|
||||
beginStr keyword
|
||||
showOccamM str
|
||||
endStr
|
||||
-}
|
||||
outerOccam keyword str = doStr keyword (showOccamM str)
|
||||
|
||||
outerRain :: (Data a, ShowRain a) => String -> A.Structured a -> CodeWriter ()
|
||||
{- TODO get replicators working properly
|
||||
outerRain keyword (A.Rep _ rep str)
|
||||
= do showRainLine (tell [keyword] >> showRainM rep)
|
||||
pushContext keyword
|
||||
rainBlock $ showRainM str
|
||||
popContext
|
||||
-}
|
||||
outerRain keyword str = pushContext keyword >> (rainBlock $ showRainM str)
|
||||
>> popContext
|
||||
|
||||
|
|
@ -629,9 +636,6 @@ instance ShowOccam A.Process where
|
|||
-- TODO make this properly rain:
|
||||
instance (Data a, ShowRain a) => ShowRain (A.Structured a) where
|
||||
showRainM (A.Spec _ spec str) = showRainM spec >> showRainM str
|
||||
showRainM (A.Rep _ rep str)
|
||||
= do item <- currentContext
|
||||
(showRainLine (return (item ++ " ") >> showRainM rep)) >> rainIndent >> showRainM str >> rainOutdent
|
||||
showRainM (A.Only _ p) = showRainM p
|
||||
showRainM (A.Several _ ss) = sequence_ $ map showRainM ss
|
||||
showRainM (A.ProcThen _ p str) = showRainLine (tell ["VALOF"]) >> rainBlock (showRainM p >> showRainLine (tell ["RESULT "] >> showRainM str))
|
||||
|
|
@ -681,10 +685,8 @@ instance ShowRain A.Process where
|
|||
showRainM (A.Par _ A.PlacedPar str) = outerRain "placed par" str
|
||||
|
||||
instance ShowRain A.Replicator where
|
||||
showRainM (A.For _ n start count) = tell [" "] >> showName n >> tell [" = "] >> showRainM start >> tell [" for "] >> showRainM count
|
||||
showRainM (A.ForEach _ n e) = tell ["each ("] >> showName n >> colon >> showRainM e
|
||||
|
||||
|
||||
showRainM (A.For _ start count) = tell [" = "] >> showRainM start >> tell [" for "] >> showRainM count
|
||||
showRainM (A.ForEach _ e) = tell ["each ("] >> colon >> showRainM e
|
||||
|
||||
--TEMP:
|
||||
instance Data a => ShowRain a where
|
||||
|
|
|
|||
|
|
@ -228,7 +228,8 @@ makePar procList = A.Par emptyMeta A.PlainPar $ A.Several emptyMeta (map (A.Only
|
|||
|
||||
-- | Wraps the given process in a replicated 'A.Par' of the form PAR i = 0 FOR 3.
|
||||
makeRepPar :: A.Process -> A.Process
|
||||
makeRepPar proc = A.Par emptyMeta A.PlainPar $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 3)) (A.Only emptyMeta proc)
|
||||
makeRepPar proc = A.Par emptyMeta A.PlainPar $ A.Spec emptyMeta
|
||||
(A.Specification emptyMeta (simpleName "i") (A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 3)))) (A.Only emptyMeta proc)
|
||||
|
||||
-- | Creates an assignment to the given 'A.Variable' from the given 'A.Expression.'
|
||||
makeAssign :: A.Variable -> A.Expression -> A.Process
|
||||
|
|
|
|||
|
|
@ -99,6 +99,12 @@ typeOfSpec st
|
|||
A.IsChannelArray _ t _ -> return $ Just t
|
||||
A.Retypes _ _ t _ -> return $ Just t
|
||||
A.RetypesExpr _ _ t _ -> return $ Just t
|
||||
A.Rep _ (A.For _ _ e) -> astTypeOf e >>* Just
|
||||
A.Rep _ (A.ForEach _ e) -> do t <- astTypeOf e
|
||||
case t of
|
||||
A.List t' -> return $ Just t'
|
||||
A.Array _ t' -> return $ Just t'
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
--{{{ identifying types
|
||||
|
|
@ -256,7 +262,7 @@ typeOfExpression e
|
|||
A.BytesInType m t -> return A.Int
|
||||
A.OffsetOf m t n -> return A.Int
|
||||
A.ExprConstr m (A.RangeConstr _ t _ _) -> return t
|
||||
A.ExprConstr m (A.RepConstr _ t _ _) -> return t
|
||||
A.ExprConstr m (A.RepConstr _ t _ _ _) -> return t
|
||||
A.AllocMobile _ t _ -> return t
|
||||
--}}}
|
||||
|
||||
|
|
@ -624,7 +630,7 @@ bytesInType _ = return $ BIUnknown
|
|||
|
||||
-- | Get the number of items a replicator produces.
|
||||
countReplicator :: A.Replicator -> A.Expression
|
||||
countReplicator (A.For _ _ _ count) = count
|
||||
countReplicator (A.For _ _ count) = count
|
||||
|
||||
-- | Get the number of items in a Structured as an expression.
|
||||
countStructured :: Data a => A.Structured a -> A.Expression
|
||||
|
|
@ -632,7 +638,7 @@ countStructured = computeStructured (\m _ -> makeConstant m 1)
|
|||
|
||||
-- | Compute an expression over a Structured.
|
||||
computeStructured :: Data a => (Meta -> a -> A.Expression) -> A.Structured a -> A.Expression
|
||||
computeStructured f (A.Rep m rep s)
|
||||
computeStructured f (A.Spec _ (A.Specification _ _ (A.Rep m rep)) s)
|
||||
= A.Dyadic m A.Times (countReplicator rep) (computeStructured f s)
|
||||
computeStructured f (A.Spec _ _ s) = computeStructured f s
|
||||
computeStructured f (A.ProcThen _ _ s) = computeStructured f s
|
||||
|
|
|
|||
29
data/AST.hs
29
data/AST.hs
|
|
@ -248,7 +248,7 @@ data ArrayConstr =
|
|||
RangeConstr Meta Type Expression Expression
|
||||
-- | A more general and powerful array constructor as used in occam-pi.
|
||||
-- The first item is the replicator, the second is the expression
|
||||
| RepConstr Meta Type Replicator Expression
|
||||
| RepConstr Meta Type Name Replicator Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- | An expression.
|
||||
|
|
@ -339,11 +339,11 @@ data Replicator =
|
|||
-- | Count up in 1s from a start value.
|
||||
-- The 'Name' names the replicator index, the first expression is the base
|
||||
-- and the second expression is the count.
|
||||
For Meta Name Expression Expression
|
||||
For Meta Expression Expression
|
||||
-- | Iterate over a list.
|
||||
-- The 'Name' names the loop variable and the expression is the list to
|
||||
-- iterate over.
|
||||
| ForEach Meta Name Expression
|
||||
| ForEach Meta Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- | A choice in an @IF@ process.
|
||||
|
|
@ -381,8 +381,7 @@ data Variant = Variant Meta Name [InputItem] Process
|
|||
-- | This represents something that can contain local replicators and
|
||||
-- specifications.
|
||||
data Data a => Structured a =
|
||||
Rep Meta Replicator (Structured a)
|
||||
| Spec Meta Specification (Structured a)
|
||||
Spec Meta Specification (Structured a)
|
||||
| ProcThen Meta Process (Structured a)
|
||||
| Only Meta a
|
||||
| Several Meta [Structured a]
|
||||
|
|
@ -393,40 +392,35 @@ data Data a => Structured a =
|
|||
-- something that leaving GHC to handle deriving (Data) will not achieve.
|
||||
-- Therefore we have no choice but to provide our own instance long-hand here.
|
||||
|
||||
_struct_RepConstr, _struct_SpecConstr, _struct_ProcThenConstr,
|
||||
_struct_SpecConstr, _struct_ProcThenConstr,
|
||||
_struct_OnlyConstr, _struct_SeveralConstr :: Constr
|
||||
_struct_DataType :: DataType
|
||||
|
||||
_struct_RepConstr = mkConstr _struct_DataType "Rep" [] Prefix
|
||||
_struct_SpecConstr = mkConstr _struct_DataType "Spec" [] Prefix
|
||||
_struct_ProcThenConstr = mkConstr _struct_DataType "ProcThen" [] Prefix
|
||||
_struct_OnlyConstr = mkConstr _struct_DataType "Only" [] Prefix
|
||||
_struct_SeveralConstr = mkConstr _struct_DataType "Several" [] Prefix
|
||||
_struct_DataType = mkDataType "AST.Structured"
|
||||
[ _struct_RepConstr
|
||||
, _struct_SpecConstr
|
||||
[ _struct_SpecConstr
|
||||
, _struct_ProcThenConstr
|
||||
, _struct_OnlyConstr
|
||||
, _struct_SeveralConstr
|
||||
]
|
||||
|
||||
instance Data a => Data (Structured a) where
|
||||
gfoldl f z (Rep m r s) = z Rep `f` m `f` r `f` s
|
||||
gfoldl f z (Spec m sp str) = z Spec `f` m `f` sp `f` str
|
||||
gfoldl f z (ProcThen m p s) = z ProcThen `f` m `f` p `f` s
|
||||
gfoldl f z (Only m x) = z Only `f` m `f` x
|
||||
gfoldl f z (Several m ss) = z Several `f` m `f` ss
|
||||
toConstr (Rep {}) = _struct_RepConstr
|
||||
toConstr (Spec {}) = _struct_SpecConstr
|
||||
toConstr (ProcThen {}) = _struct_ProcThenConstr
|
||||
toConstr (Only {}) = _struct_OnlyConstr
|
||||
toConstr (Several {}) = _struct_SeveralConstr
|
||||
gunfold k z c = case constrIndex c of
|
||||
1 -> (k . k . k) (z Rep)
|
||||
2 -> (k . k . k) (z Spec)
|
||||
3 -> (k . k . k) (z ProcThen)
|
||||
4 -> (k . k) (z Only)
|
||||
5 -> (k . k) (z Several)
|
||||
1 -> (k . k . k) (z Spec)
|
||||
2 -> (k . k . k) (z ProcThen)
|
||||
3 -> (k . k) (z Only)
|
||||
4 -> (k . k) (z Several)
|
||||
_ -> error "gunfold"
|
||||
dataTypeOf _ = _struct_DataType
|
||||
dataCast1 f = gcast1 f
|
||||
|
|
@ -503,6 +497,9 @@ data SpecType =
|
|||
-- | A fake declaration of an unscoped name, such as a protocol tag.
|
||||
-- This allows 'SpecType' to be used to describe any identifier.
|
||||
| Unscoped Meta
|
||||
-- | A replicator (as in SEQ i = 0 FOR 6). The scope of the replicator is
|
||||
-- the code that is replicated according to this replicator.
|
||||
| Rep Meta Replicator
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- | Specification mode for @PROC@s and @FUNCTION@s.
|
||||
|
|
|
|||
|
|
@ -112,19 +112,18 @@ buildStructuredEL s _ = throwError $ "Unexpected element in function: " ++ show
|
|||
|
||||
buildStructuredAltNoSpecs :: (Monad mLabel, Monad mAlter) => (Node,Node) -> A.Structured A.Alternative -> ASTModifier mAlter (A.Structured A.Alternative) structType ->
|
||||
GraphMaker mLabel mAlter label structType ()
|
||||
-- On the matter of replicators:
|
||||
-- A replicated ALT has several guards, which will be replicated for
|
||||
-- different values of i (or whatever). But leaving aside the issue
|
||||
-- of constraints on i (TODO record the replicators in ALTs somehow)
|
||||
-- only one of the replicated guards will be chosen, so we can effectively
|
||||
-- ignore the replication (in terms of the flow graph at least)
|
||||
buildStructuredAltNoSpecs se (A.Spec _ _ str) route = buildStructuredAltNoSpecs se str (route33 route A.Spec)
|
||||
buildStructuredAltNoSpecs se (A.Several m ss) route
|
||||
= mapMR (route22 route A.Several) (buildStructuredAltNoSpecs se) ss >> return ()
|
||||
buildStructuredAltNoSpecs se (A.ProcThen _ _ str) route
|
||||
-- ProcThen is considered part of the specs, so we ignore it here
|
||||
= buildStructuredAltNoSpecs se str (route33 route A.ProcThen)
|
||||
buildStructuredAltNoSpecs se (A.Rep m rep str) route
|
||||
-- A replicated ALT has several guards, which will be replicated for
|
||||
-- different values of i (or whatever). But leaving aside the issue
|
||||
-- of constraints on i (TODO record the replicators in ALTs somehow)
|
||||
-- only one of the replicated guards will be chosen, so we can effectively
|
||||
-- ignore the replication (in terms of the flow graph at least)
|
||||
= buildStructuredAltNoSpecs se str (route33 route A.Rep)
|
||||
buildStructuredAltNoSpecs (nStart, nEnd) (A.Only _ guard) route
|
||||
= do (s,e) <- buildOnlyAlternative (route22 route A.Only) guard
|
||||
addEdge ESeq nStart s
|
||||
|
|
@ -162,14 +161,19 @@ buildJustSpecs (A.ProcThen m p str) route
|
|||
Just ((innerInStart, innerInEnd), innerOut) ->
|
||||
do addEdge ESeq procNodeEnd innerInStart
|
||||
return $ Just ((procNodeStart, innerInEnd), innerOut)
|
||||
buildJustSpecs (A.Rep _ _ str) route -- TODO should probably record the replicator somehow
|
||||
= return Nothing -- TODO
|
||||
|
||||
buildStructuredSeq :: (Monad mLabel, Monad mAlter) => A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType ->
|
||||
GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
buildStructuredSeq (A.Several m ss) route
|
||||
= do nodes <- mapMR (route22 route A.Several) buildStructuredSeq ss
|
||||
joinPairs m nodes
|
||||
buildStructuredSeq (A.Spec m (A.Specification mspec nm (A.Rep mrep rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do n <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
(s,e) <- buildStructuredSeq str (route33 route A.Spec)
|
||||
addEdge ESeq n s
|
||||
addEdge ESeq e n
|
||||
return (n, n)
|
||||
buildStructuredSeq (A.Spec m spec str) route
|
||||
= do (n,n') <- addSpecNodes spec route
|
||||
buildProcessOrFunctionSpec spec (route23 route A.Spec)
|
||||
|
|
@ -177,13 +181,6 @@ buildStructuredSeq (A.Spec m spec str) route
|
|||
addEdge ESeq n s
|
||||
addEdge ESeq e n'
|
||||
return (n, n')
|
||||
buildStructuredSeq (A.Rep m rep str) route
|
||||
= let alter = AlterReplicator $ route23 route A.Rep in
|
||||
do n <- addNode' (findMeta rep) labelReplicator rep alter
|
||||
(s,e) <- buildStructuredSeq str (route33 route A.Rep)
|
||||
addEdge ESeq n s
|
||||
addEdge ESeq e n
|
||||
return (n, n)
|
||||
buildStructuredSeq (A.Only _ p) route = buildProcess p (route22 route A.Only)
|
||||
buildStructuredSeq (A.ProcThen _ p str) route
|
||||
= do (ps, pe) <- buildProcess p (route23 route A.ProcThen)
|
||||
|
|
@ -198,6 +195,18 @@ buildStructuredPar pId (nStart, nEnd) (A.Several m ss) route
|
|||
= do nodes <- mapMRE (route22 route A.Several) (buildStructuredPar pId (nStart, nEnd)) ss
|
||||
addParEdges pId (nStart, nEnd) $ either (const []) id nodes
|
||||
return $ Left $ nonEmpty nodes
|
||||
buildStructuredPar pId (nStart, nEnd) (A.Spec mstr (A.Specification mspec nm (A.Rep m rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do s <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
e <- addDummyNode m
|
||||
pId' <- getNextParEdgeId
|
||||
nodes <- buildStructuredPar pId' (s,e) str (route33 route A.Spec)
|
||||
case nodes of
|
||||
Left False -> addEdge ESeq s e
|
||||
Left True -> return ()
|
||||
Right (s',e') -> do addEdge (EStartPar pId') s s'
|
||||
addEdge (EEndPar pId') e' e
|
||||
return $ Right (s,e)
|
||||
buildStructuredPar pId (nStart, nEnd) (A.Spec m spec str) route
|
||||
= do (n,n') <- addSpecNodes spec route
|
||||
pId' <- getNextParEdgeId
|
||||
|
|
@ -209,18 +218,6 @@ buildStructuredPar pId (nStart, nEnd) (A.Spec m spec str) route
|
|||
Right (s,e) -> do addEdge ESeq n s
|
||||
addEdge ESeq e n'
|
||||
return $ Right (n,n')
|
||||
buildStructuredPar pId (nStart, nEnd) (A.Rep m rep str) route
|
||||
= let alter = AlterReplicator $ route23 route A.Rep in
|
||||
do s <- addNode' (findMeta rep) labelReplicator rep alter
|
||||
e <- addDummyNode m
|
||||
pId' <- getNextParEdgeId
|
||||
nodes <- buildStructuredPar pId' (s,e) str (route33 route A.Rep)
|
||||
case nodes of
|
||||
Left False -> addEdge ESeq s e
|
||||
Left True -> return ()
|
||||
Right (s',e') -> do addEdge (EStartPar pId') s s'
|
||||
addEdge (EEndPar pId') e' e
|
||||
return $ Right (s,e)
|
||||
buildStructuredPar _ _ (A.Only _ p) route = buildProcess p (route22 route A.Only) >>* Right
|
||||
buildStructuredPar pId (nStart, nEnd) (A.ProcThen m p str) route
|
||||
= do (ps, pe) <- buildProcess p (route23 route A.ProcThen)
|
||||
|
|
@ -249,7 +246,6 @@ buildStructuredCase (nStart, nEnd) (A.Spec _ spec str) route
|
|||
addEdge ESeq nStart n
|
||||
addEdge ESeq n' nEnd
|
||||
buildStructuredCase (n, n') str (route33 route A.Spec)
|
||||
buildStructuredCase _ s _ = throwError $ "Unexpected element in CASE statement: " ++ show s
|
||||
|
||||
buildStructuredIf :: forall mLabel mAlter label structType. (Monad mLabel, Monad mAlter) => (Node, Node) -> A.Structured A.Choice -> ASTModifier mAlter (A.Structured A.Choice) structType ->
|
||||
GraphMaker mLabel mAlter label structType Node
|
||||
|
|
@ -264,6 +260,13 @@ buildStructuredIf (prev, end) (A.ProcThen _ p str) route
|
|||
buildStructuredIf (pe, end) str (route33 route A.ProcThen)
|
||||
buildStructuredIf (prev, end) (A.Only _ c) route
|
||||
= buildOnlyChoice (prev, end) (route22 route A.Only) c
|
||||
buildStructuredIf (prev, end) (A.Spec _ (A.Specification _ nm (A.Rep _ rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do repNode <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
lastNode <- buildStructuredIf (repNode, end) str (route33 route A.Spec)
|
||||
addEdge ESeq prev repNode
|
||||
addEdge ESeq lastNode repNode
|
||||
return repNode
|
||||
buildStructuredIf (prev, end) (A.Spec _ spec str) route
|
||||
-- Specs are tricky in IFs, because they can scope out either
|
||||
-- at the end of a choice-block, or when moving on to the next
|
||||
|
|
@ -280,12 +283,6 @@ buildStructuredIf (prev, end) (A.Spec _ spec str) route
|
|||
addEdge ESeq nOutBlock end
|
||||
addEdge ESeq last nOutNext
|
||||
return nOutNext
|
||||
buildStructuredIf (prev, end) (A.Rep _ rep str) route
|
||||
= do repNode <- addNode' (findMeta rep) labelReplicator rep (AlterReplicator $ route23 route A.Rep)
|
||||
lastNode <- buildStructuredIf (repNode, end) str (route33 route A.Rep)
|
||||
addEdge ESeq prev repNode
|
||||
addEdge ESeq lastNode repNode
|
||||
return repNode
|
||||
|
||||
buildOnlyChoice :: (Monad mLabel, Monad mAlter) => (Node, Node) -> ASTModifier mAlter A.Choice structType -> A.Choice -> GraphMaker mLabel mAlter label structType Node
|
||||
buildOnlyChoice (cPrev, cEnd) route (A.Choice m exp p)
|
||||
|
|
|
|||
|
|
@ -81,6 +81,10 @@ sm9 = A.Skip m9
|
|||
sm10 = A.Skip m10
|
||||
sm11 = A.Skip m11
|
||||
|
||||
rep :: Data a => Meta -> A.Structured a -> A.Structured a
|
||||
rep m = A.Spec mU (A.Specification mU (simpleName "i") (A.Rep m (A.For m undefined
|
||||
undefined)))
|
||||
|
||||
-- | Shows a graph as a node and edge list.
|
||||
showGraph :: (Graph g, Show a, Show b) => g a b -> String
|
||||
showGraph g = " Nodes: " ++ show (labNodes g) ++ " Edges: " ++ show (labEdges g)
|
||||
|
|
@ -187,19 +191,19 @@ testSeq = TestLabel "testSeq" $ TestList
|
|||
-- Replicated SEQ:
|
||||
|
||||
,testSeq' 100 [(0,m10), (1,m3), (2,m5)] [(0,1,ESeq), (1,2,ESeq), (2,0,ESeq)]
|
||||
(A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
(rep m10 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
|
||||
,testSeq'' 101 [(0,m8), (1,m3), (2,m5),(3,m9),(4,m11)] [3] [(3,0,ESeq),(0,1,ESeq), (1,2,ESeq), (2,0,ESeq),(0,4,ESeq)]
|
||||
(A.Only mU $ A.Seq m6 $ A.Several m7
|
||||
[A.Only mU sm9
|
||||
,(A.Rep m8 (A.For m8 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
,(rep m8 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
,A.Only mU sm11])
|
||||
|
||||
,testSeq' 102 [(0,m10), (1,m1)] [(0,1,ESeq), (1,0,ESeq)]
|
||||
(A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m1 [])
|
||||
(rep m10 $ A.Several m1 [])
|
||||
|
||||
,testSeq' 103 [(1,m10), (0,m1), (2,m2), (3,m3)] [(0,1,ESeq),(1,3,ESeq), (3,1,ESeq),(1,2,ESeq)]
|
||||
(A.Several mU [A.Only mU sm1, (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m3 []), A.Only mU sm2])
|
||||
(A.Several mU [A.Only mU sm1, (rep m10 $ A.Several m3 []), A.Only mU sm2])
|
||||
|
||||
]
|
||||
where
|
||||
|
|
@ -246,7 +250,7 @@ testPar = TestLabel "testPar" $ TestList
|
|||
|
||||
,testPar' 100 [(1,m6), (2,m3), (3,m5), (4, sub m6 1)]
|
||||
[(0,1,EStartPar 0), (1,2,EStartPar 1), (2,4,EEndPar 1), (1,3,EStartPar 1), (3,4,EEndPar 1), (4,99,EEndPar 0)]
|
||||
(A.Rep m6 (A.For m6 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
(rep m6 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
|
||||
|
||||
,testPar' 101 [(1,m1), (2,m2), (3,m3), (11,sub m1 1), (4,m4), (5,m5), (6,m6), (7,m7), (15, sub m5 1)]
|
||||
-- The links in the main PAR:
|
||||
|
|
@ -257,13 +261,13 @@ testPar = TestLabel "testPar" $ TestList
|
|||
,(5,6,EStartPar 2), (6,15,EEndPar 2), (5,7,EStartPar 2), (7,15,EEndPar 2)]
|
||||
|
||||
(A.Several mU
|
||||
[(A.Rep m1 (A.For m1 undefined undefined undefined) $ A.Several mU [A.Only mU sm2,A.Only mU sm3])
|
||||
[(rep m1 $ A.Several mU [A.Only mU sm2,A.Only mU sm3])
|
||||
,A.Only mU sm4
|
||||
,(A.Rep m5 (A.For m5 undefined undefined undefined) $ A.Several mU [A.Only mU sm6,A.Only mU sm7])])
|
||||
,(rep m5 $ A.Several mU [A.Only mU sm6,A.Only mU sm7])])
|
||||
|
||||
,testPar' 102 [(1,m6), (4, sub m6 1)]
|
||||
[(0,1,EStartPar 0), (1,4,ESeq), (4,99,EEndPar 0)]
|
||||
(A.Rep m6 (A.For m6 undefined undefined undefined) $ A.Several mU [])
|
||||
(rep m6 $ A.Several mU [])
|
||||
]
|
||||
where
|
||||
testPar' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
|
||||
|
|
@ -316,16 +320,16 @@ testIf = TestLabel "testIf" $ TestList
|
|||
|
||||
,testGraph "testIf 10" [(0,m0), (1,sub m0 1), (2,m2), (3,m3), (5, m5)] [0]
|
||||
[(0,5,ESeq), (5,2,ESeq), (2,3,ESeq), (3,1,ESeq), (2, 5, ESeq)]
|
||||
(A.If m0 $ A.Rep mU (A.For m5 undefined (A.True mU) (A.True mU)) $ ifs mU [(A.True m2, sm3)])
|
||||
(A.If m0 $ rep m5 $ ifs mU [(A.True m2, sm3)])
|
||||
|
||||
,testGraph "testIf 11" [(0,m0), (1,sub m0 1), (2,m2), (3,m3), (5, m5), (6, m6), (7, m7)] [0]
|
||||
[(0,5,ESeq), (5,2,ESeq), (2,3,ESeq), (3,1,ESeq), (2, 6, ESeq), (6,7,ESeq), (7,1,ESeq), (6, 5, ESeq)]
|
||||
(A.If m0 $ A.Rep mU (A.For m5 undefined (A.True mU) (A.True mU)) $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)])
|
||||
(A.If m0 $ rep m5 $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)])
|
||||
|
||||
,testGraph "testIf 12" [(0,m0), (1,sub m0 1), (2,m2), (3,m3), (5, m5), (6, m6), (7, m7), (8, m8), (9, m9)] [0]
|
||||
[(0,5,ESeq), (5,2,ESeq), (2,3,ESeq), (3,1,ESeq), (2, 6, ESeq), (6,7,ESeq), (7,1,ESeq), (6, 5, ESeq), (5,8,ESeq),
|
||||
(8,9,ESeq), (9,1,ESeq)]
|
||||
(A.If m0 $ A.Several mU [A.Rep mU (A.For m5 undefined (A.True mU) (A.True mU)) $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)]
|
||||
(A.If m0 $ A.Several mU [rep m5 $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)]
|
||||
, ifs mU [(A.True m8, sm9)]])
|
||||
]
|
||||
where
|
||||
|
|
@ -643,13 +647,14 @@ genOption' :: (Int, Int -> GenL A.Option)
|
|||
genOption' = (1, genOption)
|
||||
|
||||
genReplicator :: GenL A.Replicator
|
||||
genReplicator = nextIdT >>* makeMeta' >>= \m -> genElem4 A.For m (comb0 $ simpleName "i") genExpression genExpression
|
||||
genReplicator = nextIdT >>* makeMeta' >>= \m -> genElem3 A.For m genExpression genExpression
|
||||
|
||||
class ReplicatorAnnotation a where
|
||||
replicatorItem :: (Int, Int -> GenL a) -> Maybe (Int, Int -> GenL (A.Structured a))
|
||||
|
||||
replicatorItem' :: (ReplicatorAnnotation a, Data a) => (Int, Int -> GenL a) -> (Int, Int -> GenL (A.Structured a))
|
||||
replicatorItem' x = (4, comb2 (A.Rep emptyMeta) genReplicator . genStructured x . sub3)
|
||||
replicatorItem' x = (4, comb2 (A.Spec emptyMeta . A.Specification emptyMeta
|
||||
(simpleName "i") . A.Rep emptyMeta) genReplicator . genStructured x . sub3)
|
||||
|
||||
--Replicators are allowed in ALTs, IFs, SEQs and PARs:
|
||||
instance ReplicatorAnnotation A.Process where replicatorItem = Just . replicatorItem'
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ data Monad m => GraphLabelFuncs m label = GLF {
|
|||
,labelAlternative :: A.Alternative -> m label
|
||||
,labelExpression :: A.Expression -> m label
|
||||
,labelExpressionList :: A.ExpressionList -> m label
|
||||
,labelReplicator :: A.Replicator -> m label
|
||||
,labelReplicator :: (A.Name, A.Replicator) -> m label
|
||||
,labelScopeIn :: A.Specification -> m label
|
||||
,labelScopeOut :: A.Specification -> m label
|
||||
}
|
||||
|
|
|
|||
|
|
@ -54,11 +54,11 @@ fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
|
|||
(applyDepthM doExpression)
|
||||
where
|
||||
doExpression :: A.Expression -> PassM A.Expression
|
||||
doExpression (A.ExprConstr m (A.RepConstr m' _ rep expr))
|
||||
doExpression (A.ExprConstr m (A.RepConstr m' _ n rep expr))
|
||||
= do t <- astTypeOf expr
|
||||
let count = countReplicator rep
|
||||
t' = A.Array [A.Dimension count] t
|
||||
return $ A.ExprConstr m $ A.RepConstr m' t' rep expr
|
||||
return $ A.ExprConstr m $ A.RepConstr m' t' n rep expr
|
||||
doExpression e = return e
|
||||
|
||||
-- | Handle ambiguities in the occam syntax that the parser can't resolve.
|
||||
|
|
|
|||
|
|
@ -710,7 +710,7 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
doArrayConstr ac
|
||||
= case ac of
|
||||
A.RangeConstr m t _ _ -> inSubscriptedContext m $ descend ac
|
||||
A.RepConstr m t _ _ -> inSubscriptedContext m $ descend ac
|
||||
A.RepConstr m t _ _ _ -> inSubscriptedContext m $ descend ac
|
||||
|
||||
doExpressionList :: [A.Type] -> Transform A.ExpressionList
|
||||
doExpressionList ts el
|
||||
|
|
@ -726,8 +726,8 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
doReplicator :: Transform A.Replicator
|
||||
doReplicator rep
|
||||
= case rep of
|
||||
A.For _ _ _ _ -> inTypeContext (Just A.Int) $ descend rep
|
||||
A.ForEach _ _ _ -> noTypeContext $ descend rep
|
||||
A.For _ _ _ -> inTypeContext (Just A.Int) $ descend rep
|
||||
A.ForEach _ _ -> noTypeContext $ descend rep
|
||||
|
||||
doAlternative :: Transform A.Alternative
|
||||
doAlternative a = inTypeContext (Just A.Bool) $ descend a
|
||||
|
|
@ -1014,8 +1014,8 @@ checkTypes = occamOnlyPass "Check types"
|
|||
( checkVariables >.>
|
||||
checkExpressions >.>
|
||||
checkSpecTypes >.>
|
||||
checkProcesses >.>
|
||||
checkReplicators)
|
||||
checkProcesses
|
||||
)
|
||||
|
||||
--{{{ checkVariables
|
||||
|
||||
|
|
@ -1173,6 +1173,13 @@ checkSpecTypes = checkDepthM doSpecType
|
|||
checkRetypes m fromT t
|
||||
checkValAM m am
|
||||
checkAbbrev m A.ValAbbrev am
|
||||
doSpecType (A.Rep _ (A.For _ start count))
|
||||
= do checkExpressionInt start
|
||||
checkExpressionInt count
|
||||
doSpecType (A.Rep _ (A.ForEach _ e))
|
||||
= do t <- astTypeOf e
|
||||
checkSequence (findMeta e) t
|
||||
|
||||
|
||||
checkValAM :: Meta -> A.AbbrevMode -> PassM ()
|
||||
checkValAM m am
|
||||
|
|
@ -1321,20 +1328,6 @@ checkProcesses = checkDepthM doProcess
|
|||
A.Any -> checkCommunicable (findMeta e) t
|
||||
_ -> checkType (findMeta e) wantT t
|
||||
|
||||
--}}}
|
||||
--{{{ checkReplicators
|
||||
|
||||
checkReplicators :: PassType
|
||||
checkReplicators = checkDepthM doReplicator
|
||||
where
|
||||
doReplicator :: Check A.Replicator
|
||||
doReplicator (A.For _ _ start count)
|
||||
= do checkExpressionInt start
|
||||
checkExpressionInt count
|
||||
doReplicator (A.ForEach _ _ e)
|
||||
= do t <- astTypeOf e
|
||||
checkSequence (findMeta e) t
|
||||
|
||||
--}}}
|
||||
|
||||
--}}}
|
||||
|
|
|
|||
|
|
@ -288,12 +288,12 @@ testOccamTypes = TestList
|
|||
, testFail 1186 $ A.Input m tim $ A.InputTimerFor m realE
|
||||
|
||||
-- Replicators
|
||||
, testOK 1200 $ testRep $ A.For m i intE intE
|
||||
, testFail 1201 $ testRep $ A.For m i realE intE
|
||||
, testFail 1202 $ testRep $ A.For m i intE realE
|
||||
, testOK 1203 $ testRep $ A.ForEach m i twoIntsE
|
||||
, testOK 1204 $ testRep $ A.ForEach m i listE
|
||||
, testFail 1205 $ testRep $ A.ForEach m i intE
|
||||
, testOK 1200 $ testRep i $ A.For m intE intE
|
||||
, testFail 1201 $ testRep i $ A.For m realE intE
|
||||
, testFail 1202 $ testRep i $ A.For m intE realE
|
||||
, testOK 1203 $ testRep i $ A.ForEach m twoIntsE
|
||||
, testOK 1204 $ testRep i $ A.ForEach m listE
|
||||
, testFail 1205 $ testRep i $ A.ForEach m intE
|
||||
|
||||
-- Choices
|
||||
, testOK 1300 $ testChoice $ A.Choice m boolE skip
|
||||
|
|
@ -591,7 +591,7 @@ testOccamTypes = TestList
|
|||
vari tag iis = A.Variant m (simpleName tag) iis skip
|
||||
outputSimple c ois = A.Output m c ois
|
||||
outputCase c tag ois = A.OutputCase m c (simpleName tag) ois
|
||||
testRep r = A.Seq m (A.Rep m r sskip)
|
||||
testRep n r = A.Seq m $ A.Spec m (A.Specification m n (A.Rep m r)) sskip
|
||||
testChoice c = A.If m $ A.Only m c
|
||||
testOption e o = A.Case m e $ A.Only m o
|
||||
inv = A.InVariable m
|
||||
|
|
|
|||
|
|
@ -382,13 +382,12 @@ scopeOut n@(A.Name m _)
|
|||
(_:rest) -> put $ st { csLocalNames = rest }
|
||||
_ -> dieInternal (Just m, "scoping out name when stack is empty")
|
||||
|
||||
scopeInRep :: A.Replicator -> OccParser A.Replicator
|
||||
scopeInRep (A.For m n b c)
|
||||
= do n' <- scopeIn n VariableName (A.Declaration m A.Int) A.ValAbbrev
|
||||
return $ A.For m n' b c
|
||||
scopeInRep :: A.Name -> OccParser A.Name
|
||||
scopeInRep n
|
||||
= scopeIn n VariableName (A.Declaration (A.nameMeta n) A.Int) A.ValAbbrev
|
||||
|
||||
scopeOutRep :: A.Replicator -> OccParser ()
|
||||
scopeOutRep (A.For m n b c) = scopeOut n
|
||||
scopeOutRep :: A.Name -> OccParser ()
|
||||
scopeOutRep n = scopeOut n
|
||||
|
||||
-- | A specification, along with the 'NameType' of the name it defines.
|
||||
type NameSpec = (A.Specification, NameType)
|
||||
|
|
@ -698,13 +697,13 @@ arrayConstructor :: OccParser A.Expression
|
|||
arrayConstructor
|
||||
= do m <- md
|
||||
sLeft
|
||||
r <- replicator
|
||||
(n, r) <- replicator
|
||||
sBar
|
||||
r' <- scopeInRep r
|
||||
n' <- scopeInRep n
|
||||
e <- expression
|
||||
scopeOutRep r'
|
||||
scopeOutRep n'
|
||||
sRight
|
||||
return $ A.ExprConstr m $ A.RepConstr m A.Infer r' e
|
||||
return $ A.ExprConstr m $ A.RepConstr m A.Infer n' r e
|
||||
<?> "array constructor expression"
|
||||
|
||||
associativeOpExpression :: OccParser A.Expression
|
||||
|
|
@ -895,14 +894,14 @@ taggedProtocol
|
|||
<?> "tagged protocol"
|
||||
--}}}
|
||||
--{{{ replicators
|
||||
replicator :: OccParser A.Replicator
|
||||
replicator :: OccParser (A.Name, A.Replicator)
|
||||
replicator
|
||||
= do m <- md
|
||||
n <- tryVX newVariableName sEq
|
||||
b <- expression
|
||||
sFOR
|
||||
c <- expression
|
||||
return $ A.For m n b c
|
||||
return (n, A.For m b c)
|
||||
<?> "replicator"
|
||||
--}}}
|
||||
--{{{ specifications, declarations, allocations
|
||||
|
|
@ -1368,7 +1367,9 @@ seqProcess
|
|||
= do m <- md
|
||||
sSEQ
|
||||
do { eol; ps <- maybeIndentedList m "empty SEQ" process; return $ A.Seq m (A.Several m (map (A.Only m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Seq m (A.Rep m r' (A.Only m p)) }
|
||||
<|> do { (n, r) <- replicator; eol; indent;
|
||||
n' <- scopeInRep n; p <- process; scopeOutRep n'; outdent;
|
||||
return $ A.Seq m (A.Spec m (A.Specification m n' (A.Rep m r)) (A.Only m p)) }
|
||||
<?> "SEQ process"
|
||||
--}}}
|
||||
--{{{ IF
|
||||
|
|
@ -1384,7 +1385,9 @@ conditional
|
|||
= do m <- md
|
||||
sIF
|
||||
do { eol; cs <- maybeIndentedList m "empty IF" ifChoice; return $ A.Several m cs }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; c <- ifChoice; scopeOutRep r'; outdent; return $ A.Rep m r' c }
|
||||
<|> do { (n, r) <- replicator; eol; indent;
|
||||
n' <- scopeInRep n; c <- ifChoice; scopeOutRep n'; outdent;
|
||||
return $ A.Spec m (A.Specification m n' (A.Rep m r)) c }
|
||||
<?> "conditional"
|
||||
|
||||
ifChoice :: OccParser (A.Structured A.Choice)
|
||||
|
|
@ -1453,7 +1456,10 @@ parallel
|
|||
= do m <- md
|
||||
isPri <- parKeyword
|
||||
do { eol; ps <- maybeIndentedList m "empty PAR" process; return $ A.Par m isPri (A.Several m (map (A.Only m) ps)) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; p <- process; scopeOutRep r'; outdent; return $ A.Par m isPri (A.Rep m r' (A.Only m p)) }
|
||||
<|> do { (n, r) <- replicator; eol; indent;
|
||||
n' <- scopeInRep n; p <- process; scopeOutRep n'; outdent;
|
||||
return $ A.Par m isPri (A.Spec m (A.Specification m n'
|
||||
(A.Rep m r)) (A.Only m p)) }
|
||||
<|> processor
|
||||
<?> "PAR process"
|
||||
|
||||
|
|
@ -1489,7 +1495,9 @@ alternation
|
|||
= do m <- md
|
||||
isPri <- altKeyword
|
||||
do { eol; as <- maybeIndentedList m "empty ALT" alternative; return (isPri, A.Several m as) }
|
||||
<|> do { r <- replicator; eol; indent; r' <- scopeInRep r; a <- alternative; scopeOutRep r'; outdent; return (isPri, A.Rep m r' a) }
|
||||
<|> do { (n, r) <- replicator; eol; indent;
|
||||
n' <- scopeInRep n; a <- alternative; scopeOutRep n'; outdent;
|
||||
return (isPri, A.Spec m (A.Specification m n' (A.Rep m r)) a) }
|
||||
<?> "alternation"
|
||||
|
||||
altKeyword :: OccParser Bool
|
||||
|
|
|
|||
|
|
@ -380,9 +380,10 @@ assignOp
|
|||
|
||||
each :: RainParser A.Process
|
||||
each = do { m <- sPareach ; sLeftR ; n <- name ; sColon ; exp <- expression ; sRightR ; st <- block ;
|
||||
return $ A.Par m A.PlainPar $ A.Rep m (A.ForEach m n exp) $ A.Only m st }
|
||||
return $ A.Par m A.PlainPar $ A.Spec m (A.Specification m n $
|
||||
A.Rep m (A.ForEach m exp)) $ A.Only m st }
|
||||
<|> do { m <- sSeqeach ; sLeftR ; n <- name ; sColon ; exp <- expression ; sRightR ; st <- block ;
|
||||
return $ A.Seq m $ A.Rep m (A.ForEach m n exp) $ A.Only m st }
|
||||
return $ A.Seq m $ A.Spec m (A.Specification m n $ A.Rep m (A.ForEach m exp)) $ A.Only m st }
|
||||
|
||||
comm :: Bool -> RainParser A.Process
|
||||
comm isAlt
|
||||
|
|
|
|||
|
|
@ -472,10 +472,12 @@ testEach :: [ParseTest A.Process]
|
|||
testEach =
|
||||
[
|
||||
pass ("seqeach (c : \"1\") par {c = 7;}", RP.statement,
|
||||
assertPatternMatch "Each Test 0" (pat $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "1")) $
|
||||
assertPatternMatch "Each Test 0" (pat $ A.Seq m $ A.Spec m (A.Specification
|
||||
m (simpleName "c") $ A.Rep m (A.ForEach m (makeLiteralStringRain "1"))) $
|
||||
A.Only m $ makePar [makeAssign (variable "c") (intLiteral 7)] ))
|
||||
,pass ("pareach (c : \"345\") {c = 1; c = 2;}", RP.statement,
|
||||
assertPatternMatch "Each Test 1" $ pat $ A.Par m A.PlainPar $ A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "345")) $
|
||||
assertPatternMatch "Each Test 1" $ pat $ A.Par m A.PlainPar $ A.Spec m
|
||||
(A.Specification m (simpleName "c") $ A.Rep m (A.ForEach m (makeLiteralStringRain "345"))) $
|
||||
A.Only m $ makeSeq[makeAssign (variable "c") (intLiteral 1),makeAssign (variable "c") (intLiteral 2)] )
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,6 @@ rainPasses =
|
|||
, rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return
|
||||
, transformInt
|
||||
, uniquifyAndResolveVars
|
||||
, recordInfNameTypes
|
||||
, performTypeUnification
|
||||
, constantFoldPass
|
||||
] ++ enablePassesWhen ((== FrontendRain) . csFrontend) simplifyTypes ++
|
||||
|
|
@ -86,16 +85,7 @@ uniquifyAndResolveVars = rainOnlyPass
|
|||
(applyDepthSM uniquifyAndResolveVars')
|
||||
where
|
||||
uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
|
||||
--Variable declarations:
|
||||
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl@(A.Declaration {})) scope)
|
||||
= do n' <- makeNonce $ A.nameName n
|
||||
defineName (n {A.nameName = n'}) A.NameDef {A.ndMeta = m', A.ndName = n', A.ndOrigName = A.nameName n,
|
||||
A.ndSpecType = decl,
|
||||
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
|
||||
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope
|
||||
return $ A.Spec m (A.Specification m' n {A.nameName = n'} decl) scope'
|
||||
|
||||
|
||||
--Processes:
|
||||
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n (A.Proc m'' procMode params procBody)) scope)
|
||||
= do (params',procBody') <- doFormals params procBody
|
||||
|
|
@ -114,12 +104,15 @@ uniquifyAndResolveVars = rainOnlyPass
|
|||
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
|
||||
return $ A.Spec m (A.Specification m' n newFunc) scope
|
||||
|
||||
-- replicator names have their types recorded later, but are
|
||||
-- uniquified and resolved here
|
||||
uniquifyAndResolveVars' (A.Rep m (A.ForEach m' n e) scope)
|
||||
--Variable declarations and replicators:
|
||||
uniquifyAndResolveVars' (A.Spec m (A.Specification m' n decl) scope)
|
||||
= do n' <- makeNonce $ A.nameName n
|
||||
defineName (n {A.nameName = n'}) A.NameDef {A.ndMeta = m', A.ndName = n', A.ndOrigName = A.nameName n,
|
||||
A.ndSpecType = decl,
|
||||
A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
|
||||
let scope' = everywhere (mkT $ replaceNameName (A.nameName n) n') scope
|
||||
return $ A.Rep m (A.ForEach m' (n {A.nameName = n'}) e) scope'
|
||||
return $ A.Spec m (A.Specification m' n {A.nameName = n'} decl) scope'
|
||||
|
||||
--Other:
|
||||
uniquifyAndResolveVars' s = return s
|
||||
|
||||
|
|
@ -189,16 +182,16 @@ checkIntegral _ = Nothing
|
|||
transformEachRange :: Pass
|
||||
transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR"
|
||||
(Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed]
|
||||
(applyDepthSM doStructured)
|
||||
(applyDepthM doSpec)
|
||||
where
|
||||
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr
|
||||
_ (A.RangeConstr _ _ begin end))) body)
|
||||
doSpec :: A.Specification -> PassM A.Specification
|
||||
doSpec (A.Specification mspec loopVar (A.Rep repMeta (A.ForEach eachMeta (A.ExprConstr
|
||||
_ (A.RangeConstr _ _ begin end)))))
|
||||
= do -- Need to change the stored abbreviation mode to original:
|
||||
modifyName loopVar $ \nd -> nd { A.ndAbbrevMode = A.Original }
|
||||
return $ A.Rep repMeta (A.For eachMeta loopVar begin
|
||||
(addOne $ subExprs end begin)) body
|
||||
doStructured s = return s
|
||||
return $ A.Specification mspec loopVar $ A.Rep repMeta $ A.For eachMeta begin
|
||||
(addOne $ subExprs end begin)
|
||||
doSpec s = return s
|
||||
|
||||
-- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions
|
||||
--
|
||||
|
|
@ -214,8 +207,8 @@ transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into mo
|
|||
doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
|
||||
= do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev
|
||||
let count = addOne $ subExprs end begin
|
||||
return $ A.ExprConstr m $ A.RepConstr m t
|
||||
(A.For m rep begin count)
|
||||
return $ A.ExprConstr m $ A.RepConstr m t rep
|
||||
(A.For m begin count)
|
||||
(A.ExprVariable m $ A.Variable m rep)
|
||||
doExpression e = return e
|
||||
|
||||
|
|
@ -253,14 +246,15 @@ pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
|
|||
(applyDepthSM doStructured)
|
||||
where
|
||||
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
|
||||
doStructured (A.Spec mstr (A.Specification mspec loopVar (A.Rep m (A.ForEach m' loopExp))) s)
|
||||
= do (extra, loopExp') <- case loopExp of
|
||||
A.ExprVariable {} -> return (id, loopExp)
|
||||
_ -> do t <- astTypeOf loopExp
|
||||
spec@(A.Specification _ n _) <- makeNonceIsExpr
|
||||
"loop_expr" m' t loopExp
|
||||
return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n))
|
||||
return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s
|
||||
return $ extra $ A.Spec mstr (A.Specification mspec loopVar $ A.Rep m $
|
||||
A.ForEach m' loopExp') s
|
||||
doStructured s = return s
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -69,46 +69,46 @@ makeRange b e = A.Dyadic emptyMeta A.Add (intLiteral 1)
|
|||
testEachRangePass0 :: Test
|
||||
testEachRangePass0 = TestCase $ testPass "testEachRangePass0" exp transformEachRange orig (return ())
|
||||
where
|
||||
orig = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m
|
||||
undefined (intLiteral 0) (intLiteral 9))))
|
||||
orig = A.Par m A.PlainPar $ A.Spec m (A.Specification m (simpleName "x")
|
||||
$ A.Rep m (A.ForEach m (A.ExprConstr m (A.RangeConstr m
|
||||
undefined (intLiteral 0) (intLiteral 9)))))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 0) (makeRange 0 9))
|
||||
exp = A.Par m A.PlainPar $ A.Spec m (A.Specification m (simpleName "x")
|
||||
$ A.Rep m (A.For m (intLiteral 0) (makeRange 0 9)))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass1 :: Test
|
||||
testEachRangePass1 = TestCase $ testPass "testEachRangePass1" exp transformEachRange orig (return ())
|
||||
where
|
||||
orig = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral (-5)) (intLiteral (-2)))))
|
||||
orig = A.Par m A.PlainPar $ A.Spec m (A.Specification m (simpleName "x")
|
||||
$ A.Rep m (A.ForEach m (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral (-5)) (intLiteral (-2))))))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Par m A.PlainPar $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral (-5)) (makeRange (-5)
|
||||
(-2)))
|
||||
exp = A.Par m A.PlainPar $ A.Spec m (A.Specification m (simpleName "x")
|
||||
$ A.Rep m (A.For m (intLiteral (-5)) (makeRange (-5)
|
||||
(-2))))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass2 :: Test
|
||||
testEachRangePass2 = TestCase $ testPass "testEachRangePass2" exp transformEachRange orig (return ())
|
||||
where
|
||||
orig = A.Seq m $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral 6) (intLiteral 6))))
|
||||
orig = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Rep m
|
||||
(A.ForEach m (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral 6) (intLiteral 6)))))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Seq m $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 6) (makeRange 6 6))
|
||||
exp = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Rep m
|
||||
(A.For m (intLiteral 6) (makeRange 6 6)))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
testEachRangePass3 :: Test
|
||||
testEachRangePass3 = TestCase $ testPass "testEachRangePass3" exp transformEachRange orig (return ())
|
||||
where
|
||||
orig = A.Seq m $ A.Rep m
|
||||
(A.ForEach m (simpleName "x") (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral 6) (intLiteral 0))))
|
||||
orig = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Rep m
|
||||
(A.ForEach m (A.ExprConstr m (A.RangeConstr m undefined
|
||||
(intLiteral 6) (intLiteral 0)))))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
exp = A.Seq m $ A.Rep m
|
||||
(A.For m (simpleName "x") (intLiteral 6) (makeRange 6 0))
|
||||
exp = A.Seq m $ A.Spec m (A.Specification m (simpleName "x") $ A.Rep m
|
||||
(A.For m (intLiteral 6) (makeRange 6 0)))
|
||||
(A.Only m (makeSimpleAssign "c" "x"))
|
||||
|
||||
|
||||
|
|
@ -207,46 +207,6 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp uniquifyA
|
|||
-- TODO check that declaring a new proc with the same name as an old one does give an error
|
||||
|
||||
|
||||
-- | checks that c's type is recorded in: ***each (c : "hello") {}
|
||||
testRecordInfNames0 :: Test
|
||||
testRecordInfNames0 = TestCase $ testPassWithStateCheck "testRecordInfNames0" exp recordInfNameTypes orig (return ()) check
|
||||
where
|
||||
orig = (A.Rep m (A.ForEach m (simpleName "c") (makeLiteralStringRain "hello")) skipP)
|
||||
exp = orig
|
||||
check state = assertVarDef "testRecordInfNames0" state "c"
|
||||
(tag6 A.NameDef DontCare "c" "c"
|
||||
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
|
||||
|
||||
-- | checks that c's type is recorded in: ***each (c : str) {}, where str is known to be of type string
|
||||
testRecordInfNames1 :: Test
|
||||
testRecordInfNames1 = TestCase $ testPassWithStateCheck "testRecordInfNames1" exp recordInfNameTypes orig (startState') check
|
||||
where
|
||||
startState' :: State CompState ()
|
||||
startState' = do defineName (simpleName "str") $ simpleDef "str" (A.Declaration m (A.List A.Byte) )
|
||||
orig = (A.Rep m (A.ForEach m (simpleName "c") (exprVariable "str")) skipP)
|
||||
exp = orig
|
||||
check state = assertVarDef "testRecordInfNames1" state "c"
|
||||
(tag6 A.NameDef DontCare "c" "c"
|
||||
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName "c") A.Abbrev A.Unplaced)
|
||||
|
||||
-- | checks that c's and d's type are recorded in: ***each (c : multi) { seqeach (d : c) {} } where multi is known to be of type [string]
|
||||
testRecordInfNames2 :: Test
|
||||
testRecordInfNames2 = TestCase $ testPassWithStateCheck "testRecordInfNames2" exp recordInfNameTypes orig (startState') check
|
||||
where
|
||||
startState' :: State CompState ()
|
||||
startState' = do defineName (simpleName "multi") $ simpleDef "multi" (A.Declaration m (A.List $ A.List A.Byte) )
|
||||
orig = A.Rep m (A.ForEach m (simpleName "c") (exprVariable "multi")) $
|
||||
A.Only m $ A.Seq m $ A.Rep m (A.ForEach m (simpleName "d") (exprVariable "c")) skipP
|
||||
exp = orig
|
||||
check state = do assertVarDef "testRecordInfNames2" state "c"
|
||||
(tag6 A.NameDef DontCare "c" "c"
|
||||
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
|
||||
"c") A.Abbrev A.Unplaced)
|
||||
assertVarDef "testRecordInfNames2" state "d"
|
||||
(tag6 A.NameDef DontCare "d" "d"
|
||||
(A.Declaration m $ A.UnknownVarType $ Left $ simpleName
|
||||
"d") A.Abbrev A.Unplaced)
|
||||
|
||||
--Easy way to string two passes together; creates a pass-like function that applies the left-hand pass then the right-hand pass. Associative.
|
||||
(>>>) :: Pass -> Pass -> Pass
|
||||
(>>>) f0 f1 = Pass {passCode = passCode f1 <.< passCode f0}
|
||||
|
|
@ -395,8 +355,8 @@ testRangeRepPass0 :: Test
|
|||
testRangeRepPass0 = TestCase $ testPass "testRangeRepPass0" exp transformRangeRep orig (return())
|
||||
where
|
||||
orig = A.ExprConstr m $ A.RangeConstr m A.Byte (intLiteral 0) (intLiteral 1)
|
||||
exp = tag2 A.ExprConstr DontCare $ mRepConstr A.Byte
|
||||
(mFor ("repIndex"@@DontCare) (intLiteral 0) (makeRange 0 1))
|
||||
exp = tag2 A.ExprConstr DontCare $ mRepConstr A.Byte ("repIndex"@@DontCare)
|
||||
(mFor (intLiteral 0) (makeRange 0 1))
|
||||
(tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare $ "repIndex"@@DontCare)
|
||||
|
||||
--TODO consider/test pulling up the definitions of variables involved in return statements in functions
|
||||
|
|
@ -455,9 +415,6 @@ tests = TestLabel "RainPassesTest" $ TestList
|
|||
,testUnique2b
|
||||
,testUnique3
|
||||
,testUnique4
|
||||
,testRecordInfNames0
|
||||
,testRecordInfNames1
|
||||
,testRecordInfNames2
|
||||
,testFindMain0
|
||||
,testFindMain1
|
||||
,testFindMain2
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along
|
|||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
module RainTypes (constantFoldPass,performTypeUnification,recordInfNameTypes) where
|
||||
module RainTypes (constantFoldPass, performTypeUnification) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
|
|
@ -139,30 +139,13 @@ substituteUnknownTypes mt = applyDepthM sub
|
|||
Just t -> return t
|
||||
Nothing -> dieP m "Could not deduce type"
|
||||
|
||||
-- | A pass that records inferred types. Currently the only place where types are inferred is in seqeach\/pareach loops.
|
||||
recordInfNameTypes :: Pass
|
||||
recordInfNameTypes = rainOnlyPass "Record inferred name types in dictionary"
|
||||
(Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) [Prop.inferredTypesRecorded]
|
||||
(checkDepthM recordInfNameTypes')
|
||||
where
|
||||
recordInfNameTypes' :: Check A.Replicator
|
||||
recordInfNameTypes' input@(A.ForEach m n e)
|
||||
= let innerT = A.UnknownVarType $ Left n in
|
||||
defineName n A.NameDef { A.ndMeta = m
|
||||
, A.ndName = A.nameName n
|
||||
, A.ndOrigName = A.nameName n
|
||||
, A.ndSpecType = A.Declaration m innerT
|
||||
, A.ndAbbrevMode = A.Abbrev
|
||||
, A.ndPlacement = A.Unplaced
|
||||
}
|
||||
recordInfNameTypes' _ = return ()
|
||||
|
||||
markReplicators :: PassType
|
||||
markReplicators = checkDepthM mark
|
||||
where
|
||||
mark :: Check A.Replicator
|
||||
mark (A.ForEach _m n e)
|
||||
mark :: Check A.Specification
|
||||
mark (A.Specification _ n (A.Rep _ (A.ForEach _m e)))
|
||||
= astTypeOf n >>= \t -> markUnify (A.List t) e
|
||||
mark _ = return ()
|
||||
|
||||
-- | Folds all constants.
|
||||
constantFoldPass :: Pass
|
||||
|
|
@ -223,7 +206,7 @@ markExpressionTypes = checkDepthM checkExpression
|
|||
A.RangeConstr _ t e e' ->
|
||||
do astTypeOf e >>= markUnify t . A.List
|
||||
astTypeOf e' >>= markUnify t . A.List
|
||||
A.RepConstr _ t _ e ->
|
||||
A.RepConstr _ t n _ e ->
|
||||
astTypeOf e >>= markUnify t . A.List
|
||||
checkExpression _ = return ()
|
||||
|
||||
|
|
|
|||
|
|
@ -181,7 +181,6 @@ debugAST p
|
|||
transformOnly :: (Monad m, Data a, Data b) =>
|
||||
(Meta -> a -> m (A.Structured b))
|
||||
-> A.Structured a -> m (A.Structured b)
|
||||
transformOnly f (A.Rep m r s) = transformOnly f s >>* A.Rep m r
|
||||
transformOnly f (A.Spec m sp s) = transformOnly f s >>* A.Spec m sp
|
||||
transformOnly f (A.ProcThen m p s) = transformOnly f s >>* A.ProcThen m p
|
||||
transformOnly f (A.Several m ss) = mapM (transformOnly f) ss >>* A.Several m
|
||||
|
|
|
|||
|
|
@ -292,7 +292,6 @@ findParWithProcess (A.Par _ _ s) = findParProcess s
|
|||
findParProcess :: A.Structured A.Process -> Bool
|
||||
findParProcess (A.Only _ (A.ProcCall {})) = False
|
||||
findParProcess (A.Only {}) = True
|
||||
findParProcess (A.Rep _ _ s) = findParProcess s
|
||||
findParProcess (A.ProcThen _ _ s) = findParProcess s
|
||||
findParProcess (A.Spec _ _ s) = findParProcess s
|
||||
findParProcess (A.Several _ ss) = or $ map findParProcess ss
|
||||
|
|
|
|||
|
|
@ -211,7 +211,7 @@ testTransformConstr0 = TestCase $ testPass "transformConstr0" exp transformConst
|
|||
|
||||
orig = A.Spec m (A.Specification m (simpleName "arr") $
|
||||
A.IsExpr m A.ValAbbrev t $ A.ExprConstr m $
|
||||
A.RepConstr m t (A.For m (simpleName "x") (intLiteral 0) (intLiteral 10))
|
||||
A.RepConstr m t (simpleName "x") (A.For m (intLiteral 0) (intLiteral 10))
|
||||
(exprVariable "x")) skipP
|
||||
exp = nameAndStopCaringPattern "indexVar" "i" $ mkPattern exp'
|
||||
exp' = A.Spec m (A.Specification m (simpleName "arr") (A.Declaration m t)) $
|
||||
|
|
@ -220,7 +220,7 @@ testTransformConstr0 = TestCase $ testPass "transformConstr0" exp transformConst
|
|||
(A.Declaration m A.Int)) $
|
||||
A.Several m [A.Only m $ A.Assign m [variable "i"] $
|
||||
A.ExpressionList m [intLiteral 0],
|
||||
A.Rep m (A.For m (simpleName "x") (intLiteral 0) (intLiteral 10)) $
|
||||
A.Spec m (A.Specification m (simpleName "x") $ A.Rep m (A.For m (intLiteral 0) (intLiteral 10))) $
|
||||
A.Only m $ A.Seq m $ A.Several m
|
||||
[A.Only m $ A.Assign m
|
||||
[A.SubscriptedVariable m (A.Subscript m A.NoCheck $
|
||||
|
|
@ -579,20 +579,25 @@ testPullRepCounts = TestList
|
|||
,TestCase $ testPass "testPullRepCounts 5"
|
||||
(nameAndStopCaringPattern "nonce" "nonce" $ mkPattern $ A.Seq emptyMeta $
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "nonce") (A.IsExpr emptyMeta A.ValAbbrev A.Int $ intLiteral 6)) $
|
||||
A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (exprVariable "nonce")) $ A.Several emptyMeta [])
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "i") $
|
||||
A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "nonce"))) $ A.Several emptyMeta [])
|
||||
|
||||
pullRepCounts (A.Seq emptyMeta $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 6)) $ A.Several emptyMeta [])
|
||||
pullRepCounts (A.Seq emptyMeta $ A.Spec emptyMeta (A.Specification emptyMeta
|
||||
(simpleName "i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6))) $ A.Several emptyMeta [])
|
||||
(return ())
|
||||
|
||||
,TestCase $ testPass "testPullRepCounts 6"
|
||||
(nameAndStopCaringPattern "nonce" "nonce" $ nameAndStopCaringPattern "nonce2" "nonce2" $ mkPattern $ A.Seq emptyMeta $
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "nonce") (A.IsExpr emptyMeta A.ValAbbrev A.Int $ intLiteral 6)) $
|
||||
A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (exprVariable "nonce")) $
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "i")
|
||||
$ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "nonce"))) $
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "nonce2") (A.IsExpr emptyMeta A.ValAbbrev A.Int $ intLiteral 8)) $
|
||||
A.Rep emptyMeta (A.For emptyMeta (simpleName "j") (intLiteral 0) (exprVariable "nonce2")) $ A.Several emptyMeta [])
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "j")
|
||||
$ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (exprVariable "nonce2"))) $ A.Several emptyMeta [])
|
||||
|
||||
pullRepCounts (A.Seq emptyMeta $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 6)) $
|
||||
A.Rep emptyMeta (A.For emptyMeta (simpleName "j") (intLiteral 0) (intLiteral 8)) $ A.Several emptyMeta [])
|
||||
pullRepCounts (A.Seq emptyMeta $ A.Spec emptyMeta (A.Specification emptyMeta
|
||||
(simpleName "i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 6))) $
|
||||
A.Spec emptyMeta (A.Specification emptyMeta (simpleName "j") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 8))) $ A.Several emptyMeta [])
|
||||
(return ())
|
||||
]
|
||||
where
|
||||
|
|
@ -603,7 +608,8 @@ testPullRepCounts = TestList
|
|||
pullRepCounts code
|
||||
(return ())
|
||||
where
|
||||
code = (f $ A.Rep emptyMeta (A.For emptyMeta (simpleName "i") (intLiteral 0) (intLiteral 5)) $ A.Several emptyMeta [])
|
||||
code = (f $ A.Spec emptyMeta (A.Specification emptyMeta (simpleName
|
||||
"i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 5))) $ A.Several emptyMeta [])
|
||||
|
||||
|
||||
--Returns the list of tests:
|
||||
|
|
|
|||
|
|
@ -167,6 +167,13 @@ pullRepCounts = pass "Pull up replicator counts for SEQs"
|
|||
|
||||
pullRepCountSeq :: A.Structured A.Process -> PassM (A.Structured A.Process)
|
||||
pullRepCountSeq s@(A.Only _ _) = return s
|
||||
pullRepCountSeq (A.Spec m (A.Specification mspec n (A.Rep mrep (A.For mfor
|
||||
from for))) scope)
|
||||
= do t <- astTypeOf for
|
||||
spec@(A.Specification _ nonceName _) <- makeNonceIsExpr "rep_for" mspec t for
|
||||
return $ A.Spec mspec spec $
|
||||
A.Spec m (A.Specification mspec n (A.Rep mrep
|
||||
(A.For mfor from (A.ExprVariable mspec $ A.Variable mspec nonceName)))) scope
|
||||
pullRepCountSeq (A.Spec m sp str)
|
||||
= do str' <- pullRepCountSeq str
|
||||
return $ A.Spec m sp str'
|
||||
|
|
@ -174,15 +181,6 @@ pullRepCounts = pass "Pull up replicator counts for SEQs"
|
|||
= do s' <- pullRepCountSeq s
|
||||
return $ A.ProcThen m p s'
|
||||
pullRepCountSeq (A.Several m ss) = mapM pullRepCountSeq ss >>* A.Several m
|
||||
pullRepCountSeq (A.Rep m (A.For m' n from for) s)
|
||||
= do t <- astTypeOf for
|
||||
spec@(A.Specification _ nonceName _) <- makeNonceIsExpr "rep_for" m' t for
|
||||
s' <- pullRepCountSeq s
|
||||
return $ A.Spec m spec $ A.Rep m (A.For m' n from (A.ExprVariable m' $ A.Variable m' nonceName)) s'
|
||||
-- Other replicators (such as ForEach)
|
||||
pullRepCountSeq (A.Rep m rep s)
|
||||
= do s' <- pullRepCountSeq s
|
||||
return $ A.Rep m rep s'
|
||||
|
||||
transformConstr :: Pass
|
||||
transformConstr = pass "Transform array constructors into initialisation code"
|
||||
|
|
@ -211,7 +209,8 @@ transformConstr = pass "Transform array constructors into initialisation code"
|
|||
-- SEQ i = rep
|
||||
-- name += [expr]
|
||||
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
||||
doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _ expr@(A.ExprConstr m'' (A.RepConstr _ t rep exp)))) scope)
|
||||
doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _
|
||||
expr@(A.ExprConstr m'' (A.RepConstr _ t repn rep exp)))) scope)
|
||||
= do case t of
|
||||
A.Array {} ->
|
||||
do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.Original
|
||||
|
|
@ -220,7 +219,7 @@ transformConstr = pass "Transform array constructors into initialisation code"
|
|||
return $ declDest $ A.ProcThen m''
|
||||
(A.Seq m'' $ A.Spec m'' indexVarSpec $
|
||||
A.Several m'' [assignIndex0 indexVar,
|
||||
A.Rep m'' rep $ A.Only m'' $ A.Seq m'' $
|
||||
replicateCode $ A.Only m'' $ A.Seq m'' $
|
||||
A.Several m''
|
||||
[ assignItem indexVar
|
||||
, incrementIndex indexVar ]
|
||||
|
|
@ -228,7 +227,7 @@ transformConstr = pass "Transform array constructors into initialisation code"
|
|||
scope
|
||||
A.List {} ->
|
||||
return $ declDest $ A.ProcThen m''
|
||||
(A.Seq m'' $ A.Rep m'' rep $ appendItem)
|
||||
(A.Seq m'' $ replicateCode $ appendItem)
|
||||
scope
|
||||
_ -> diePC m $ formatCode "Unsupported type for array constructor: %" t
|
||||
where
|
||||
|
|
@ -254,6 +253,9 @@ transformConstr = pass "Transform array constructors into initialisation code"
|
|||
(A.ExprVariable m'' $ A.Variable m'' n)
|
||||
(A.Literal m'' t $ A.ListLiteral m'' [exp])]
|
||||
|
||||
replicateCode :: Data a => A.Structured a -> A.Structured a
|
||||
replicateCode = A.Spec m'' (A.Specification m'' repn (A.Rep m'' rep))
|
||||
|
||||
doStructured s = return s
|
||||
|
||||
-- | Find things that need to be moved up to their enclosing Structured, and do
|
||||
|
|
|
|||
|
|
@ -122,8 +122,7 @@ flattenAssign = pass "Flatten assignment"
|
|||
-- inside.
|
||||
do counter <- makeNonceCounter "i" m
|
||||
let zero = A.Literal m A.Int $ A.IntLiteral m "0"
|
||||
let rep = A.For m counter zero
|
||||
(A.SizeVariable m srcV)
|
||||
let rep = A.For m zero (A.SizeVariable m srcV)
|
||||
itemT <- trivialSubscriptType m t
|
||||
-- Don't need to check bounds, as we'll always be within bounds
|
||||
let sub = A.Subscript m A.NoCheck (A.ExprVariable m
|
||||
|
|
@ -132,7 +131,7 @@ flattenAssign = pass "Flatten assignment"
|
|||
(A.SubscriptedVariable m sub destV) m'
|
||||
(A.ExprVariable m'
|
||||
(A.SubscriptedVariable m' sub srcV))
|
||||
return $ A.Rep m rep $ A.Only m inner
|
||||
return $ A.Spec m (A.Specification m counter (A.Rep m rep)) $ A.Only m inner
|
||||
A.Record n ->
|
||||
return $ A.Only m $ A.ProcCall m (n {A.nameName = "copy_" ++ A.nameName n})
|
||||
[A.ActualVariable destV, A.ActualVariable srcV]
|
||||
|
|
|
|||
|
|
@ -61,7 +61,6 @@ freeNamesIn = doGeneric
|
|||
doName n = Map.singleton (A.nameName n) n
|
||||
|
||||
doStructured :: Data a => A.Structured a -> NameMap
|
||||
doStructured (A.Rep _ rep s) = doRep rep s
|
||||
doStructured (A.Spec _ spec s) = doSpec spec s
|
||||
doStructured s = doGeneric s
|
||||
|
||||
|
|
@ -71,17 +70,12 @@ freeNamesIn = doGeneric
|
|||
where
|
||||
fns = freeNamesIn st
|
||||
|
||||
doRep :: Data t => A.Replicator -> t -> NameMap
|
||||
doRep rep child
|
||||
= Map.union fns $ Map.delete (A.nameName repName) $ freeNamesIn child
|
||||
where
|
||||
(repName, fns) = case rep of
|
||||
A.For _ n b c -> (n, Map.union (freeNamesIn b) (freeNamesIn c))
|
||||
A.ForEach _ n b -> (n, freeNamesIn b)
|
||||
|
||||
doSpecType :: A.SpecType -> NameMap
|
||||
doSpecType (A.Proc _ _ fs p) = Map.difference (freeNamesIn p) (freeNamesIn fs)
|
||||
doSpecType (A.Function _ _ _ fs vp) = Map.difference (freeNamesIn vp) (freeNamesIn fs)
|
||||
doSpecType (A.Rep _ rep) = case rep of
|
||||
A.For _ b c -> Map.union (freeNamesIn b) (freeNamesIn c)
|
||||
A.ForEach _ b -> freeNamesIn b
|
||||
doSpecType st = doGeneric st
|
||||
|
||||
-- | Replace names.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user