suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rework Traversal, and convert all passes to use it.

Browse Source 
This changes the Traversal API to the one that I've been working on in
the Polyplate branch, but implemented in terms of Data. The
performance isn't as good as the Polyplate version, but the code is a
lot simpler because it doesn't need all the type constraints (and it
doesn't make GHC struggle).

This also reworks all the passes in Tock to use the new API, including
those that previously used makeGeneric (which I've now removed) or
everywhereM. Most of the passes are simpler because of this, and I
suspect it's fixed a few subtle bugs resulting from missing recursion
in makeGeneric code.

I haven't yet profiled this, but subjectively it seems about the same
as the old Traversal (and thus faster for all the passes that didn't
yet use it).
This commit is contained in:
Adam Sampson 2008-05-25 20:13:57 +00:00
parent b413cf3dc2
commit 6debf9292f
13 changed files with 461 additions and 472 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
backends/BackendPasses.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -30,6 +30,7 @@ import Metadata
import Pass
import PrettyShow
import qualified Properties as Prop
import Traversal
import Types
import Utils
@ -44,19 +45,16 @@ squashArrays = makePassesDep
where
prereq = Prop.agg_namesDone ++ Prop.agg_typesDone ++ Prop.agg_functionsGone ++ [Prop.subscriptsPulledUp, Prop.arrayLiteralsExpanded]
transformWaitFor :: Data t => t -> PassM t
transformWaitFor = doGeneric `extM` doAlt
transformWaitFor :: PassType
transformWaitFor = applyDepthM doAlt
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformWaitFor
doAlt :: A.Process -> PassM A.Process
doAlt a@(A.Alt m pri s)
= do (s',(specs,code)) <- runStateT (applyToOnly doWaitFor s) ([],[])
if (null specs && null code)
then return a
else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.Only m $ A.Alt m pri s'])) specs
doAlt p = doGeneric p
doAlt p = return p
addSpec :: Data a => (A.Structured a -> A.Structured a) -> A.Structured a -> A.Structured a
addSpec spec inner = spec inner
@ -81,8 +79,8 @@ append_sizes n = n {A.nameName = A.nameName n ++ "_sizes"}
-- | Declares a _sizes array for every array, statically sized or dynamically sized.
-- For each record type it declares a _sizes array too.
declareSizesArray :: Data t => t -> PassM t
declareSizesArray = doGeneric `ext1M` doStructured
declareSizesArray :: PassType
declareSizesArray = applyDepthSM doStructured
where
defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM ()
defineSizesName m n spec
@ -175,10 +173,6 @@ declareSizesArray = doGeneric `ext1M` doStructured
defineSizesName m n_sizes sizeSpecType
return $ A.Specification m n_sizes sizeSpecType
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric declareSizesArray
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured str@(A.Spec m sp@(A.Specification m' n spec) s)
= do t <- typeOfSpec spec
@ -207,14 +201,12 @@ declareSizesArray = doGeneric `ext1M` doStructured
sizeSpec = A.Specification m' n_sizes sizeSpecType
defineSizesName m' n_sizes sizeSpecType
return sizeSpec
s' <- doStructured s
return (A.Spec m sizeSpec $ A.Spec m sp $ s')
return (A.Spec m sizeSpec $ A.Spec m sp $ s)
(A.RecordType m _ fs, _) ->
do s' <- doStructured s
fieldDeclarations <- foldM (declareFieldSizes (A.nameName n) m) s' fs
do fieldDeclarations <- foldM (declareFieldSizes (A.nameName n) m) s fs
return $ A.Spec m sp fieldDeclarations
_ -> doGeneric str
doStructured s = doGeneric s
_ -> return str
doStructured s = return s
makeStaticSizeSpec :: Meta -> A.Name -> [A.Dimension] -> A.SpecType
makeStaticSizeSpec m n ds = makeDynamicSizeSpec m n es
@ -238,21 +230,17 @@ declareSizesArray = doGeneric `ext1M` doStructured
-- | A pass for adding _sizes parameters to PROC arguments
-- TODO in future, only add _sizes for variable-sized parameters
addSizesFormalParameters :: Data t => t -> PassM t
addSizesFormalParameters = doGeneric `extM` doSpecification
addSizesFormalParameters :: PassType
addSizesFormalParameters = applyDepthM doSpecification
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric addSizesFormalParameters
doSpecification :: A.Specification -> PassM A.Specification
doSpecification (A.Specification m n (A.Proc m' sm args body))
= do (args', newargs) <- transformFormals m args
body' <- doGeneric body
let newspec = A.Proc m' sm args' body'
let newspec = A.Proc m' sm args' body
modify (\cs -> cs {csNames = Map.adjust (\nd -> nd { A.ndSpecType = newspec }) (A.nameName n) (csNames cs)})
mapM_ (recordArg m') newargs
return $ A.Specification m n newspec
doSpecification st = doGeneric st
doSpecification st = return st
recordArg :: Meta -> A.Formal -> PassM ()
recordArg m (A.Formal am t n)
@ -277,15 +265,12 @@ addSizesFormalParameters = doGeneric `extM` doSpecification
return (f : rest, new)
-- | A pass for adding _sizes parameters to actuals in PROC calls
addSizesActualParameters :: Data t => t -> PassM t
addSizesActualParameters = doGeneric `extM` doProcess
addSizesActualParameters :: PassType
addSizesActualParameters = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric addSizesActualParameters
doProcess :: A.Process -> PassM A.Process
doProcess (A.ProcCall m n params) = concatMapM transformActual params >>* A.ProcCall m n
doProcess p = doGeneric p
doProcess p = return p
transformActual :: A.Actual -> PassM [A.Actual]
transformActual a@(A.ActualVariable v)
@ -306,25 +291,16 @@ addSizesActualParameters = doGeneric `extM` doProcess
transformActualVariable a _ = return [a]
-- | Transforms all slices into the FromFor form.
simplifySlices :: Data t => t -> PassM t
simplifySlices = doGeneric `extM` doVariable
simplifySlices :: PassType
simplifySlices = applyDepthM doVariable
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric simplifySlices
-- We recurse into the subscripts in case they contain subscripts:
doVariable :: A.Variable -> PassM A.Variable
doVariable (A.SubscriptedVariable m (A.SubscriptFor m' for) v)
= do for' <- doGeneric for
v' <- doGeneric v
return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for') v')
= return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for) v)
doVariable (A.SubscriptedVariable m (A.SubscriptFrom m' from) v)
= do v' <- doGeneric v
A.Array (d:_) _ <- astTypeOf v'
= do A.Array (d:_) _ <- astTypeOf v
limit <- case d of
A.Dimension n -> return n
A.UnknownDimension -> return $ A.SizeVariable m' v'
from' <- doGeneric from
return (A.SubscriptedVariable m (A.SubscriptFromFor m' from' (A.Dyadic m A.Subtr limit from')) v')
-- We must recurse, to handle nested variables, and variables inside subscripts!
doVariable v = doGeneric v
A.UnknownDimension -> return $ A.SizeVariable m' v
return (A.SubscriptedVariable m (A.SubscriptFromFor m' from (A.Dyadic m A.Subtr limit from)) v)
doVariable v = return v

12
backends/GenerateCPPCSP.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -47,6 +47,7 @@ import Pass
import qualified Properties as Prop
import ShowCode
import TLP
import Traversal
import Types
import Utils
@ -93,7 +94,7 @@ genCPPCSPPasses = makePassesDep' ((== BackendCPPCSP) . csBackend)
[ ("Transform channels to ANY", chansToAny, [Prop.processTypesChecked], [Prop.allChansToAnyOrProtocol])
]
chansToAny :: Data t => t -> PassM t
chansToAny :: PassType
chansToAny x = do st <- get
case csFrontend st of
FrontendOccam ->
@ -104,13 +105,10 @@ chansToAny x = do st <- get
chansToAny' :: A.Type -> PassM A.Type
chansToAny' c@(A.Chan _ _ (A.UserProtocol {})) = return c
chansToAny' (A.Chan a b _) = return $ A.Chan a b A.Any
chansToAny' t = doGeneric t
chansToAny' t = return t
chansToAnyM :: Data t => t -> PassM t
chansToAnyM = doGeneric `extM` chansToAny'
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric chansToAnyM
chansToAnyM = applyDepthM chansToAny'
chansToAnyInCompState :: PassM ()
chansToAnyInCompState = do st <- get

24
common/Types.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -48,9 +48,9 @@ import Errors
import EvalLiterals
import Intrinsics
import Metadata
import Pass
import PrettyShow
import ShowCode
import Traversal
import TypeSizes
import Utils
@ -311,22 +311,14 @@ abbrevModeOfSpec s
-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
-- type, then return the underlying real type. This will recurse.
underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
underlyingType m = underlyingType'
underlyingType m = applyDepthM doType
where
underlyingType' :: Data t => t -> m t
underlyingType' = doGeneric `extM` underlyingType''
doGeneric :: Data t => t -> m t
doGeneric = makeGeneric underlyingType'
underlyingType'' :: A.Type -> m A.Type
underlyingType'' t@(A.UserDataType _)
= resolveUserType m t >>= underlyingType m
underlyingType'' (A.Array ds t)
= underlyingType m t >>* addDimensions ds
underlyingType'' t = doGeneric t
doType :: A.Type -> m A.Type
-- This is fairly subtle: after resolving a user type, we have to recurse
-- on the resulting type.
doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m
doType t = return t
-- | Like underlyingType, but only do the "outer layer": if you give this a
-- user type that's an array of user types, then you'll get back an array of

164
frontends/OccamTypes.hs
View File

@ -616,25 +616,33 @@ inSubscriptedContext m body
--{{{ inferTypes
-- | Infer types.
inferTypes :: Data t => t -> PassM t
inferTypes = applyX $ baseX
`extX` doExpression
`extX` doDimension
`extX` doSubscript
`extX` doArrayConstr
`extX` doReplicator
`extX` doAlternative
`extX` doInputMode
`extX` doSpecification
`extX` doProcess
`extX` doVariable
inferTypes :: PassType
inferTypes = recurse
where
doExpression :: ExplicitTrans A.Expression
doExpression descend outer
ops :: Ops
ops = baseOp
`extOp` doExpression
`extOp` doDimension
`extOp` doSubscript
`extOp` doArrayConstr
`extOp` doReplicator
`extOp` doAlternative
`extOp` doInputMode
`extOp` doSpecification
`extOp` doProcess
`extOp` doVariable
recurse :: Recurse
recurse = makeRecurse ops
descend :: Descend
descend = makeDescend ops
doExpression :: Transform A.Expression
doExpression outer
= case outer of
-- Literals are what we're really looking for here.
A.Literal m t lr ->
do t' <- inferTypes t
do t' <- recurse t
ctx <- getTypeContext
let wantT = case (ctx, t') of
-- No type specified on the literal,
@ -643,7 +651,7 @@ inferTypes = applyX $ baseX
-- Use the explicit type of the literal, or the
-- default.
_ -> t'
(realT, realLR) <- doLiteral descend (wantT, lr)
(realT, realLR) <- doLiteral (wantT, lr)
return $ A.Literal m realT realLR
-- Expressions that aren't literals, but that modify the type
@ -651,14 +659,14 @@ inferTypes = applyX $ baseX
A.Dyadic m op le re ->
let -- Both types are the same.
bothSame
= do lt <- inferTypes le >>= astTypeOf
rt <- inferTypes re >>= astTypeOf
= do lt <- recurse le >>= astTypeOf
rt <- recurse re >>= astTypeOf
inTypeContext (Just $ betterType lt rt) $
descend outer
-- The RHS type is always A.Int.
intOnRight
= do le' <- inferTypes le
re' <- inTypeContext (Just A.Int) $ inferTypes re
= do le' <- recurse le
re' <- inTypeContext (Just A.Int) $ recurse re
return $ A.Dyadic m op le' re'
in case classifyOp op of
ComparisonOp -> noTypeContext $ bothSame
@ -675,9 +683,9 @@ inferTypes = applyX $ baseX
ctx' <- case ctx of
Just t -> unsubscriptType s t >>* Just
Nothing -> return Nothing
e' <- inTypeContext ctx' $ inferTypes e
e' <- inTypeContext ctx' $ recurse e
t <- astTypeOf e'
s' <- inferTypes s >>= fixSubscript t
s' <- recurse s >>= fixSubscript t
return $ A.SubscriptedExpr m s' e'
A.BytesInExpr _ _ -> noTypeContext $ descend outer
-- FIXME: ExprConstr
@ -694,19 +702,19 @@ inferTypes = applyX $ baseX
doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a]
doActuals m n fs as
= do checkActualCount m n fs as
sequence [inTypeContext (Just t) $ inferTypes a
sequence [inTypeContext (Just t) $ recurse a
| (A.Formal _ t _, a) <- zip fs as]
doDimension :: ExplicitTrans A.Dimension
doDimension descend dim = inTypeContext (Just A.Int) $ descend dim
doDimension :: Transform A.Dimension
doDimension dim = inTypeContext (Just A.Int) $ descend dim
doSubscript :: ExplicitTrans A.Subscript
doSubscript descend s = inTypeContext (Just A.Int) $ descend s
doSubscript :: Transform A.Subscript
doSubscript s = inTypeContext (Just A.Int) $ descend s
-- FIXME: RepConstr shouldn't contain the type -- and this won't fill it in.
-- (That is, it should just be a kind of literal.)
doArrayConstr :: ExplicitTrans A.ArrayConstr
doArrayConstr descend ac
doArrayConstr :: Transform A.ArrayConstr
doArrayConstr ac
= case ac of
A.RangeConstr m t _ _ -> inSubscriptedContext m $ descend ac
A.RepConstr m t _ _ -> inSubscriptedContext m $ descend ac
@ -718,46 +726,46 @@ inferTypes = applyX $ baseX
do es' <- doFunctionCall m n es
return $ A.FunctionCallList m n es'
A.ExpressionList m es ->
do es' <- sequence [inTypeContext (Just t) $ inferTypes e
do es' <- sequence [inTypeContext (Just t) $ recurse e
| (t, e) <- zip ts es]
return $ A.ExpressionList m es'
doReplicator :: ExplicitTrans A.Replicator
doReplicator descend rep
doReplicator :: Transform A.Replicator
doReplicator rep
= case rep of
A.For _ _ _ _ -> inTypeContext (Just A.Int) $ descend rep
A.ForEach _ _ _ -> noTypeContext $ descend rep
doAlternative :: ExplicitTrans A.Alternative
doAlternative descend a = inTypeContext (Just A.Bool) $ descend a
doAlternative :: Transform A.Alternative
doAlternative a = inTypeContext (Just A.Bool) $ descend a
doInputMode :: ExplicitTrans A.InputMode
doInputMode descend im = inTypeContext (Just A.Int) $ descend im
doInputMode :: Transform A.InputMode
doInputMode im = inTypeContext (Just A.Int) $ descend im
-- FIXME: This should be shared with foldConstants.
doSpecification :: ExplicitTrans A.Specification
doSpecification descend s@(A.Specification m n st)
= do st' <- doSpecType descend st
doSpecification :: Transform A.Specification
doSpecification s@(A.Specification m n st)
= do st' <- doSpecType st
-- Update the definition of each name after we handle it.
modifyName n (\nd -> nd { A.ndSpecType = st' })
return $ A.Specification m n st'
doSpecType :: ExplicitTrans A.SpecType
doSpecType descend st
doSpecType :: Transform A.SpecType
doSpecType st
= case st of
A.Place _ _ -> inTypeContext (Just A.Int) $ descend st
A.Is m am t v ->
do am' <- inferTypes am
t' <- inferTypes t
v' <- inTypeContext (Just t') $ inferTypes v
do am' <- recurse am
t' <- recurse t
v' <- inTypeContext (Just t') $ recurse v
t'' <- case t' of
A.Infer -> astTypeOf v'
_ -> return t'
return $ A.Is m am' t'' v'
A.IsExpr m am t e ->
do am' <- inferTypes am
t' <- inferTypes t
e' <- inTypeContext (Just t') $ inferTypes e
do am' <- recurse am
t' <- recurse t
e' <- inTypeContext (Just t') $ recurse e
t'' <- case t' of
A.Infer -> astTypeOf e'
_ -> return t'
@ -765,8 +773,8 @@ inferTypes = applyX $ baseX
A.IsChannelArray m t vs ->
-- No expressions in this -- but we may need to infer the type
-- of the variable if it's something like "cs IS [c]:".
do t' <- inferTypes t
vs' <- mapM inferTypes vs
do t' <- recurse t
vs' <- mapM recurse vs
let dim = makeDimension m $ length vs'
t'' <- case (t', vs') of
(A.Infer, (v:_)) ->
@ -777,9 +785,9 @@ inferTypes = applyX $ baseX
_ -> return $ applyDimension dim t'
return $ A.IsChannelArray m t'' vs'
A.Function m sm ts fs (Left sel) ->
do sm' <- inferTypes sm
ts' <- inferTypes ts
fs' <- inferTypes fs
do sm' <- recurse sm
ts' <- recurse ts
fs' <- recurse fs
sel' <- doFuncDef ts sel
return $ A.Function m sm' ts' fs' (Left sel')
A.RetypesExpr _ _ _ _ -> noTypeContext $ descend st
@ -791,27 +799,27 @@ inferTypes = applyX $ baseX
-- form.)
doFuncDef :: [A.Type] -> Transform (A.Structured A.ExpressionList)
doFuncDef ts (A.Spec m spec s)
= do spec' <- inferTypes spec
= do spec' <- recurse spec
s' <- doFuncDef ts s
return $ A.Spec m spec' s'
doFuncDef ts (A.ProcThen m p s)
= do p' <- inferTypes p
= do p' <- recurse p
s' <- doFuncDef ts s
return $ A.ProcThen m p' s'
doFuncDef ts (A.Only m el)
= do el' <- doExpressionList ts el
return $ A.Only m el'
doProcess :: ExplicitTrans A.Process
doProcess descend p
doProcess :: Transform A.Process
doProcess p
= case p of
A.Assign m vs el ->
do vs' <- inferTypes vs
do vs' <- recurse vs
ts <- mapM astTypeOf vs'
el' <- doExpressionList ts el
return $ A.Assign m vs' el'
A.Output m v ois ->
do v' <- inferTypes v
do v' <- recurse v
-- At this point we must resolve the "c ! x" ambiguity:
-- we definitely know what c is, and we must know what x is
-- before trying to infer its type.
@ -828,14 +836,14 @@ inferTypes = applyX $ baseX
else do ois' <- doOutputItems m v' Nothing ois
return $ A.Output m v' ois'
A.OutputCase m v tag ois ->
do v' <- inferTypes v
do v' <- recurse v
ois' <- doOutputItems m v' (Just tag) ois
return $ A.OutputCase m v' tag ois'
A.If _ _ -> inTypeContext (Just A.Bool) $ descend p
A.Case m e so ->
do e' <- inferTypes e
do e' <- recurse e
t <- astTypeOf e'
so' <- inTypeContext (Just t) $ inferTypes so
so' <- inTypeContext (Just t) $ recurse so
return $ A.Case m e' so'
A.While _ _ _ -> inTypeContext (Just A.Bool) $ descend p
A.Processor _ _ _ -> inTypeContext (Just A.Int) $ descend p
@ -867,19 +875,19 @@ inferTypes = applyX $ baseX
doOutputItem :: A.Type -> Transform A.OutputItem
doOutputItem (A.Counted ct at) (A.OutCounted m ce ae)
= do ce' <- inTypeContext (Just ct) $ inferTypes ce
ae' <- inTypeContext (Just at) $ inferTypes ae
= do ce' <- inTypeContext (Just ct) $ recurse ce
ae' <- inTypeContext (Just at) $ recurse ae
return $ A.OutCounted m ce' ae'
doOutputItem A.Any o = noTypeContext $ inferTypes o
doOutputItem t o = inTypeContext (Just t) $ inferTypes o
doOutputItem A.Any o = noTypeContext $ recurse o
doOutputItem t o = inTypeContext (Just t) $ recurse o
doVariable :: ExplicitTrans A.Variable
doVariable descend (A.SubscriptedVariable m s v)
= do v' <- inferTypes v
doVariable :: Transform A.Variable
doVariable (A.SubscriptedVariable m s v)
= do v' <- recurse v
t <- astTypeOf v'
s' <- inferTypes s >>= fixSubscript t
s' <- recurse s >>= fixSubscript t
return $ A.SubscriptedVariable m s' v'
doVariable descend v = descend v
doVariable v = descend v
-- | Resolve the @v[s]@ ambiguity: this takes the type that @v@ is, and
-- returns the correct 'Subscript'.
@ -901,8 +909,8 @@ inferTypes = applyX $ baseX
-- | Process a 'LiteralRepr', taking the type it's meant to represent or
-- 'Infer', and returning the type it really is.
doLiteral :: ExplicitTrans (A.Type, A.LiteralRepr)
doLiteral descend (wantT, lr)
doLiteral :: Transform (A.Type, A.LiteralRepr)
doLiteral (wantT, lr)
= case lr of
A.ArrayLiteral m aes ->
do (t, A.ArrayElemArray aes') <-
@ -960,7 +968,7 @@ inferTypes = applyX $ baseX
return (bestT, aes')
-- An expression: descend into it with the right context.
doArrayElem wantT (A.ArrayElemExpr e)
= do e' <- inTypeContext (Just wantT) $ doExpression descend e
= do e' <- inTypeContext (Just wantT) $ doExpression e
t <- astTypeOf e'
checkType (findMeta e') wantT t
return (t, A.ArrayElemExpr e')
@ -1005,7 +1013,7 @@ inferTypes = applyX $ baseX
-- | Check the AST for type consistency.
-- This is actually a series of smaller passes that check particular types
-- inside the AST, but it doesn't really make sense to split it up.
checkTypes :: Data t => t -> PassM t
checkTypes :: PassType
checkTypes t =
checkVariables t >>=
checkExpressions >>=
@ -1014,7 +1022,7 @@ checkTypes t =
--{{{ checkVariables
checkVariables :: Data t => t -> PassM t
checkVariables :: PassType
checkVariables = checkDepthM doVariable
where
doVariable :: Check A.Variable
@ -1036,7 +1044,7 @@ checkVariables = checkDepthM doVariable
--}}}
--{{{ checkExpressions
checkExpressions :: Data t => t -> PassM t
checkExpressions :: PassType
checkExpressions = checkDepthM doExpression
where
doExpression :: Check A.Expression
@ -1091,7 +1099,7 @@ checkExpressions = checkDepthM doExpression
--}}}
--{{{ checkSpecTypes
checkSpecTypes :: Data t => t -> PassM t
checkSpecTypes :: PassType
checkSpecTypes = checkDepthM doSpecType
where
doSpecType :: Check A.SpecType
@ -1170,7 +1178,7 @@ checkSpecTypes = checkDepthM doSpecType
--}}}
--{{{ checkProcesses
checkProcesses :: Data t => t -> PassM t
checkProcesses :: PassType
checkProcesses = checkDepthM doProcess
where
doProcess :: Check A.Process

58
frontends/RainPasses.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -32,6 +32,7 @@ import Pass
import qualified Properties as Prop
import RainTypes
import SimplifyTypes
import Traversal
import TreeUtils
import Types
@ -69,8 +70,8 @@ rainPasses = let f = makePassesDep' ((== FrontendRain) . csFrontend) in f
]
-- | A pass that transforms all instances of 'A.Int' into 'A.Int64'
transformInt :: Data t => t -> PassM t
transformInt = everywhereM (mkM transformInt')
transformInt :: PassType
transformInt = applyDepthM transformInt'
where
transformInt' :: A.Type -> PassM A.Type
transformInt' A.Int = return A.Int64
@ -89,8 +90,8 @@ transformInt = everywhereM (mkM transformInt')
--
-- This pass works because everywhereM goes bottom-up, so declarations are
--resolved from the bottom upwards.
uniquifyAndResolveVars :: Data t => t -> PassM t
uniquifyAndResolveVars = everywhereM (mk1M uniquifyAndResolveVars')
uniquifyAndResolveVars :: PassType
uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
where
uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
@ -158,13 +159,13 @@ replaceNameName ::
replaceNameName find replace n = if (A.nameName n) == find then n {A.nameName = replace} else n
-- | A pass that finds and tags the main process, and also mangles its name (to avoid problems in the C\/C++ backends with having a function called main).
findMain :: Data t => t -> PassM t
findMain :: PassType
--Because findMain runs after uniquifyAndResolveVars, the types of all the process will have been recorded
--Therefore this pass doesn't actually need to walk the tree, it just has to look for a process named "main"
--in the CompState, and pull it out into csMainLocals
findMain x = do newMainName <- makeNonce "main_"
modify (findMain' newMainName)
everywhereM (mkM $ return . (replaceNameName "main" newMainName)) x
applyDepthM (return . (replaceNameName "main" newMainName)) x
where
--We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++)
findMain' :: String -> CompState -> CompState
@ -183,32 +184,25 @@ checkIntegral (A.ByteLiteral _ s) = Nothing -- TODO support char literals
checkIntegral _ = Nothing
-- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops
transformEachRange :: Data t => t -> PassM t
transformEachRange = doGeneric `ext1M` doStructured
transformEachRange :: PassType
transformEachRange = applyDepthSM doStructured
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformEachRange
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)
= do body' <- doStructured body
-- Need to change the stored abbreviation mode to original:
= 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 = doGeneric s
(addOne $ subExprs end begin)) body
doStructured s = return s
-- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions
--
-- TODO make sure when the range has a bad order that an empty list is
-- returned
transformRangeRep :: Data t => t -> PassM t
transformRangeRep = doGeneric `extM` doExpression
transformRangeRep :: PassType
transformRangeRep = applyDepthM doExpression
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformRangeRep
doExpression :: A.Expression -> PassM A.Expression
doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
= do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.VariableName A.ValAbbrev
@ -216,11 +210,11 @@ transformRangeRep = doGeneric `extM` doExpression
return $ A.ExprConstr m $ A.RepConstr m t
(A.For m rep begin count)
(A.ExprVariable m $ A.Variable m rep)
doExpression e = doGeneric e
doExpression e = return e
-- TODO this is almost certainly better figured out from the CFG
checkFunction :: Data t => t -> PassM t
checkFunction = return -- everywhereM (mkM checkFunction')
checkFunction :: PassType
checkFunction = return -- applyDepthM checkFunction'
where
checkFunction' :: A.Specification -> PassM A.Specification
checkFunction' spec@(A.Specification _ n (A.Function m _ _ _ (Right body)))
@ -246,12 +240,9 @@ checkFunction = return -- everywhereM (mkM checkFunction')
-- backend we need it to be a variable so we can use begin() and end() (in
-- C++); these will only be valid if exactly the same list is used
-- throughout the loop.
pullUpForEach :: Data t => t -> PassM t
pullUpForEach = doGeneric `ext1M` doStructured
pullUpForEach :: PassType
pullUpForEach = applyDepthSM doStructured
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric pullUpForEach
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
= do (extra, loopExp') <- case loopExp of
@ -260,13 +251,12 @@ pullUpForEach = doGeneric `ext1M` doStructured
spec@(A.Specification _ n _) <- makeNonceIsExpr
"loop_expr" m' t loopExp
return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n))
s' <- doStructured s
return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s'
doStructured s = doGeneric s
return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s
doStructured s = return s
pullUpParDeclarations :: Data t => t -> PassM t
pullUpParDeclarations = everywhereM (mkM pullUpParDeclarations')
pullUpParDeclarations :: PassType
pullUpParDeclarations = applyDepthM pullUpParDeclarations'
where
pullUpParDeclarations' :: A.Process -> PassM A.Process
pullUpParDeclarations' p@(A.Par m mode inside)

24
frontends/RainTypes.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -86,7 +86,7 @@ markUnify x y
modify $ \st -> st {csUnifyPairs = (tex,tey) : csUnifyPairs st}
performTypeUnification :: Data t => t -> PassM t
performTypeUnification :: PassType
performTypeUnification x
= do -- First, we copy the known types into the unify map:
st <- get
@ -122,7 +122,7 @@ performTypeUnification x
name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d, A.nameType
= A.ndNameType d}
substituteUnknownTypes :: Data t => Map.Map UnifyIndex A.Type -> t -> PassM t
substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType
substituteUnknownTypes mt = applyDepthM sub
where
sub :: A.Type -> PassM A.Type
@ -137,8 +137,8 @@ substituteUnknownTypes mt = applyDepthM sub
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 :: Data t => t -> PassM t
recordInfNameTypes = everywhereM (mkM recordInfNameTypes')
recordInfNameTypes :: PassType
recordInfNameTypes = applyDepthM recordInfNameTypes'
where
recordInfNameTypes' :: A.Replicator -> PassM A.Replicator
recordInfNameTypes' input@(A.ForEach m n e)
@ -149,7 +149,7 @@ recordInfNameTypes = everywhereM (mkM recordInfNameTypes')
return input
recordInfNameTypes' r = return r
markReplicators :: Data t => t -> PassM t
markReplicators :: PassType
markReplicators = checkDepthM mark
where
mark :: Check A.Replicator
@ -157,7 +157,7 @@ markReplicators = checkDepthM mark
= astTypeOf n >>= \t -> markUnify (A.List t) e
-- | Folds all constants.
constantFoldPass :: Data t => t -> PassM t
constantFoldPass :: PassType
constantFoldPass = applyDepthM doExpression
where
doExpression :: A.Expression -> PassM A.Expression
@ -166,7 +166,7 @@ constantFoldPass = applyDepthM doExpression
-- | A pass that finds all the 'A.ProcCall' and 'A.FunctionCall' in the
-- AST, and checks that the actual parameters are valid inputs, given
-- the 'A.Formal' parameters in the process's type
markParamPass :: Data t => t -> PassM t
markParamPass :: PassType
markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
where
--Picks out the parameters of a process call, checks the number is correct, and maps doParam over them
@ -197,7 +197,7 @@ markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
matchParamPassFunc _ = return ()
-- | Checks the types in expressions
markExpressionTypes :: Data t => t -> PassM t
markExpressionTypes :: PassType
markExpressionTypes = checkDepthM checkExpression
where
-- TODO also check in a later pass that the op is valid
@ -217,7 +217,7 @@ markExpressionTypes = checkDepthM checkExpression
checkExpression _ = return ()
-- | Checks the types in assignments
markAssignmentTypes :: Data t => t -> PassM t
markAssignmentTypes :: PassType
markAssignmentTypes = checkDepthM checkAssignment
where
checkAssignment :: Check A.Process
@ -238,7 +238,7 @@ markAssignmentTypes = checkDepthM checkAssignment
checkAssignment st = return ()
-- | Checks the types in if and while conditionals
markConditionalTypes :: Data t => t -> PassM t
markConditionalTypes :: PassType
markConditionalTypes = checkDepthM2 checkWhile checkIf
where
checkWhile :: Check A.Process
@ -251,7 +251,7 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf
= markUnify exp A.Bool
-- | Checks the types in inputs and outputs, including inputs in alts
markCommTypes :: Data t => t -> PassM t
markCommTypes :: PassType
markCommTypes = checkDepthM2 checkInputOutput checkAltInput
where
checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM ()

24
pass/Pass.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -31,7 +31,6 @@ import System.IO
import qualified AST as A
import CompState
import Errors
import Metadata
import PrettyShow
import TreeUtils
import Utils
@ -52,7 +51,13 @@ instance Warn PassM where
instance Warn PassMR where
warnReport w = lift $ lift $ modify (++ [w])
-- | The type of an AST-mangling pass.
-- | The type of a pass function.
-- This is as generic as possible. Passes are used on 'A.AST' in normal use,
-- but for explicit descent and testing it's useful to be able to run them
-- against AST fragments of other types as well.
type PassType = (forall s. Data s => s -> PassM s)
-- | A description of an AST-mangling pass.
data Monad m => Pass_ m = Pass {
passCode :: A.AST -> m A.AST
,passName :: String
@ -67,10 +72,10 @@ instance Monad m => Eq (Pass_ m) where
instance Monad m => Ord (Pass_ m) where
compare x y = compare (passName x) (passName y)
type Pass = Pass_ PassM
type PassR = Pass_ PassMR
-- | A property that can be asserted and tested against the AST.
data Property = Property {
propName :: String
,propCheck :: A.AST -> PassMR ()
@ -157,19 +162,8 @@ applyToOnly f (A.ProcThen m p s) = applyToOnly f s >>* A.ProcThen m p
applyToOnly f (A.Several m ss) = mapM (applyToOnly f) ss >>* A.Several m
applyToOnly f (A.Only m o) = f o >>* A.Only m
-- | Make a generic rule for a pass.
makeGeneric :: forall m t. (Data t, Monad m) => (forall s. Data s => s -> m s) -> t -> m t
makeGeneric top
= (gmapM top)
`extM` (return :: String -> m String)
`extM` (return :: Meta -> m Meta)
excludeConstr :: (Data a, CSMR m) => [Constr] -> a -> m a
excludeConstr cons x
= if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x)
where
items = checkTreeForConstr cons x
mk1M :: (Monad m, Data a, Typeable1 t) => (forall d . Data d => t d -> m (t d)) -> a -> m a
mk1M = ext1M return

209
pass/Traversal.hs
View File

@ -18,98 +18,183 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Traversal strategies over the AST and other data types.
module Traversal (
ExplicitTrans, Transform, Check
, transformToExplicitDepth, checkToTransform
, baseX, extX, extD, extC, applyX
, applyDepthM, applyDepthM2
OpsM, Ops
, TransformM, Transform
, CheckM, Check
, baseOp, extOp, extOpS
, makeDepth, extOpD, extOpSD
, makeCheck, extOpC
, RecurseM, Recurse, makeRecurse
, DescendM, Descend, makeDescend
, applyDepthM, applyDepthSM, applyDepthM2
, checkDepthM, checkDepthM2
) where
import Data.Generics
import qualified AST as A
import GenericUtils
import NavAST
import Pass
-- | A transformation for a single 'Data' type with explicit descent.
-- The first argument passed is a function that can be called to explicitly
-- descend into a generic value.
type ExplicitTrans t = (forall s. Data s => s -> PassM s) -> t -> PassM t
-- | A set of generic operations.
type OpsM m = ([TypeKey], DescendM m -> RecurseM m)
-- | A transformation for a single 'Data' type with implicit descent.
-- This can be applied recursively throughout a data structure.
type Transform t = t -> PassM t
-- | As 'OpsM', but specialised for 'PassM'.
type Ops = OpsM PassM
-- | A check for a single 'Data' type with implicit descent.
-- | A transformation for a single 'Data' type.
type TransformM m t = t -> m t
-- | As 'TransformM', but specialised for 'PassM'.
type Transform t = TransformM PassM t
-- | A check for a single 'Data' type.
-- This is like 'Transform', but it doesn't change the value; it may fail or
-- modify the state, though.
type Check t = t -> PassM ()
type CheckM m t = t -> m ()
-- | Make an 'ExplicitTrans' that applies a 'Transform', recursing depth-first.
transformToExplicitDepth :: Data t => Transform t -> ExplicitTrans t
transformToExplicitDepth f descend x = descend x >>= f
-- | As 'CheckM', but specialised for 'PassM'.
type Check t = CheckM PassM t
-- | Make a 'Transform' that applies a 'Check'.
checkToTransform :: Data t => Check t -> Transform t
checkToTransform f x = f x >> return x
-- | An empty set of operations.
baseOp :: forall m. Monad m => OpsM m
baseOp = ([], id)
-- | A set of generic transformations.
type InfoX = ([TypeKey],
(forall dgt. Data dgt => dgt -> PassM dgt)
-> (forall t1. Data t1 => t1 -> PassM t1)
-> (forall t2. Data t2 => t2 -> PassM t2))
-- | Add a 'TransformM' to a set, to be applied with explicit descent
-- (that is, the transform will be responsible for recursing into child
-- elements itself).
extOp :: forall m t. (Monad m, Data t) => OpsM m -> TransformM m t -> OpsM m
extOp (tks, g) f = ((typeKey (undefined :: t)) : tks,
(\descend -> g descend `extM` f))
-- | An empty set of transformations.
baseX :: InfoX
baseX = ([], (\doGeneric t -> t))
-- | As 'extOp', but for transformations that work on all 'A.Structured' types.
extOpS :: forall m. Monad m =>
OpsM m
-> (forall t. Data t => TransformM m (A.Structured t))
-> OpsM m
extOpS ops f
= ops
`extOp` (f :: TransformM m (A.Structured A.Variant))
`extOp` (f :: TransformM m (A.Structured A.Process))
`extOp` (f :: TransformM m (A.Structured A.Option))
`extOp` (f :: TransformM m (A.Structured A.ExpressionList))
`extOp` (f :: TransformM m (A.Structured A.Choice))
`extOp` (f :: TransformM m (A.Structured A.Alternative))
`extOp` (f :: TransformM m (A.Structured ()))
-- | Add an 'ExplicitTrans' to a set.
extX :: forall t. Data t => InfoX -> ExplicitTrans t -> InfoX
extX (tks, g) f = ((typeKey (undefined :: t)) : tks,
(\doGeneric t -> (g doGeneric t) `extM` (f doGeneric)))
-- | Generate an operation that applies a 'TransformM' with automatic
-- depth-first descent.
makeDepth :: (Monad m, Data t) => OpsM m -> TransformM m t -> TransformM m t
makeDepth ops f v = descend v >>= f
where
descend = makeDescend ops
-- | Add a 'Transform' to a set, to be applied depth-first.
extD :: forall t. Data t => InfoX -> Transform t -> InfoX
extD info f = extX info (transformToExplicitDepth f)
-- | Add a 'TransformM' to a set, to be applied with automatic depth-first
-- descent.
extOpD :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> TransformM m t -> OpsM m
extOpD ops ops0 f = ops `extOp` (makeDepth ops0 f)
-- | Add a 'Check' to a set, to be applied depth-first.
extC :: forall t. Data t => InfoX -> Check t -> InfoX
extC info f = extD info (checkToTransform f)
-- | As 'extOpD', but for transformations that work on all 'A.Structured' types.
extOpSD :: forall m. Monad m =>
OpsM m
-> OpsM m
-> (forall t. Data t => TransformM m (A.Structured t))
-> OpsM m
extOpSD ops ops0 f = ops `extOpS` (makeDepth ops0 f)
-- | Apply a set of transformations.
applyX :: Data s => InfoX -> s -> PassM s
applyX info@(tks, maker) = trans
-- | Generate an operation that applies a 'CheckM' with automatic
-- depth-first descent.
makeCheck :: (Monad m, Data t) => OpsM m -> CheckM m t -> TransformM m t
makeCheck ops f v = descend v >> f v >> return v
where
descend = makeDescend ops
-- | Add a 'CheckM' to a set, to be applied with automatic depth-first descent.
extOpC :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> CheckM m t -> OpsM m
extOpC ops ops0 f = ops `extOp` (makeCheck ops0 f)
-- | A function that applies a generic operation.
-- This applies the operations in the set to the provided value.
--
-- This is the type of function that you want to use to apply a generic
-- operation; a pass in Tock is usually the application of a 'RecurseM' to the
-- AST. It's also what you should use when you're writing a pass that uses
-- explicit descent, and you want to explicitly recurse into one of the
-- children of a value that one of your transformations has been applied to.
type RecurseM m = (forall t. Data t => t -> m t)
-- | As 'RecurseM', but specialised for 'PassM'.
type Recurse = RecurseM PassM
-- | Build a 'RecurseM' function from a set of operations.
makeRecurse :: forall m. Monad m => OpsM m -> RecurseM m
makeRecurse ops@(_, f) = f descend
where
descend :: DescendM m
descend = makeDescend ops
-- | A function that applies a generic operation.
-- This applies the operations in the set to the immediate children of the
-- provided value, but not to the value itself.
--
-- You should use this type of operation when you're writing a traversal with
-- explicit descent, and you want to descend into all the children of a value
-- that one of your transformations has been applied to.
type DescendM m = (forall t. Data t => t -> m t)
-- | As 'DescendM', but specialised for 'PassM'.
type Descend = DescendM PassM
-- | Build a 'DescendM' function from a set of operations.
makeDescend :: forall m. Monad m => OpsM m -> DescendM m
makeDescend ops@(tks, _) = gmapMFor ts recurse
where
ts :: TypeSet
ts = makeTypeSet tks
trans :: Data s => s -> PassM s
trans = maker doGeneric doGeneric
doGeneric :: Data t => t -> PassM t
doGeneric = gmapMFor ts trans
recurse :: RecurseM m
recurse = makeRecurse ops
-- | Apply a transformation, recursing depth-first.
applyDepthM :: forall t1 s. (Data t1, Data s) =>
Transform t1 -> s -> PassM s
applyDepthM f1
= applyX $ baseX `extD` f1
applyDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
TransformM m t1 -> s -> m s
applyDepthM f1 = makeRecurse ops
where
ops :: OpsM m
ops = baseOp `extOp` makeDepth ops f1
-- | As 'applyDepthM', but for transformations that work on all 'A.Structured'
-- types.
applyDepthSM :: forall m s. (Monad m, Data s) =>
(forall t. Data t => TransformM m (A.Structured t)) -> s -> m s
applyDepthSM f1 = makeRecurse ops
where
ops :: OpsM m
ops = extOpSD baseOp ops f1
-- | Apply two transformations, recursing depth-first.
applyDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) =>
Transform t1 -> Transform t2 -> s -> PassM s
applyDepthM2 f1 f2
= applyX $ baseX `extD` f1 `extD` f2
applyDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
TransformM m t1 -> TransformM m t2 -> s -> m s
applyDepthM2 f1 f2 = makeRecurse ops
where
ops :: OpsM m
ops = baseOp `extOp` makeDepth ops f1
`extOp` makeDepth ops f2
-- | Apply a check, recursing depth-first.
checkDepthM :: forall t1 s. (Data t1, Data s) =>
Check t1 -> s -> PassM s
checkDepthM f1
= applyX $ baseX `extC` f1
checkDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
CheckM m t1 -> s -> m s
checkDepthM f1 = makeRecurse ops
where
ops :: OpsM m
ops = baseOp `extOp` makeCheck ops f1
-- | Apply two checks, recursing depth-first.
checkDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) =>
Check t1 -> Check t2 -> s -> PassM s
checkDepthM2 f1 f2
= applyX $ baseX `extC` f1 `extC` f2
checkDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
CheckM m t1 -> CheckM m t2 -> s -> m s
checkDepthM2 f1 f2 = makeRecurse ops
where
ops :: OpsM m
ops = baseOp `extOp` makeCheck ops f1
`extOp` makeCheck ops f2

53
transformations/SimplifyComms.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -20,7 +20,6 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module SimplifyComms where
import Control.Monad.State
import Data.Generics
import Data.List
import qualified AST as A
@ -28,6 +27,7 @@ import CompState
import Metadata
import Pass
import qualified Properties as Prop
import Traversal
import Types
import Utils
@ -38,12 +38,9 @@ simplifyComms = makePassesDep
,("Flatten sequential protocol inputs into multiple inputs", transformProtocolInput, Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved], [Prop.seqInputsFlattened])
]
outExprs :: Data t => t -> PassM t
outExprs = doGeneric `extM` doProcess
outExprs :: PassType
outExprs = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric outExprs
doProcess :: A.Process -> PassM A.Process
doProcess (A.Output m c ois)
= do (ois', specs) <- mapAndUnzipM changeItem ois
@ -53,7 +50,7 @@ outExprs = doGeneric `extM` doProcess
= do (ois', specs) <- mapAndUnzipM changeItem ois
let foldedSpec = foldFuncs specs
return $ A.Seq m (foldedSpec $ A.Only m $ A.OutputCase m c tag ois')
doProcess p = doGeneric p
doProcess p = return p
changeItem :: A.OutputItem -> PassM (A.OutputItem, A.Structured A.Process -> A.Structured A.Process)
changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e
@ -133,12 +130,9 @@ ALT
-- process D
-}
transformInputCase :: Data t => t -> PassM t
transformInputCase = doGeneric `extM` doProcess
transformInputCase :: PassType
transformInputCase = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformInputCase
doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputCase m' s))
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original
@ -149,15 +143,14 @@ transformInputCase = doGeneric `extM` doProcess
doProcess (A.Alt m pri s)
= do s' <- doStructuredA s
return (A.Alt m pri s')
doProcess p = doGeneric p
doProcess p = return p
-- Can't easily use generics here as we're switching from one type of Structured to another
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
-- These entries all just burrow deeper into the structured:
doStructuredV v (A.ProcThen m p s)
= do s' <- doStructuredV v s
p' <- doProcess p
return (A.ProcThen m p' s')
return (A.ProcThen m p s')
doStructuredV v (A.Spec m sp st)
= do st' <- doStructuredV v st
return (A.Spec m sp st')
@ -171,20 +164,18 @@ transformInputCase = doGeneric `extM` doProcess
doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
= do (Right items) <- protocolItems chanVar
let (Just idx) = elemIndex n (fst $ unzip items)
p' <- doProcess p
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
if (length iis == 0)
then p'
then p
else A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis)
,A.Only (findMeta p') p']
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
A.Only (findMeta p) p]
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
-- TODO use generics instead of this boilerplate, but don't omit the doProcess call in ProcThen!
-- TODO use generics instead of this boilerplate
doStructuredA (A.ProcThen m p s)
= do s' <- doStructuredA s
p' <- doProcess p
return (A.ProcThen m p' s')
return (A.ProcThen m p s')
doStructuredA (A.Spec m sp st)
= do st' <- doStructuredA st
return (A.Spec m sp st')
@ -206,22 +197,18 @@ transformInputCase = doGeneric `extM` doProcess
-- Leave other guards (and parts of Structured) untouched:
doStructuredA s = return s
transformProtocolInput :: Data t => t -> PassM t
transformProtocolInput = doGeneric `extM` doProcess `extM` doAlternative
transformProtocolInput :: PassType
transformProtocolInput = applyDepthM2 doProcess doAlternative
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformProtocolInput
doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_)))
= return $ A.Seq m $ A.Several m $
map (A.Only m . A.Input m v . A.InputSimple m' . singleton) iis
doProcess p = doGeneric p
doProcess p = return p
doAlternative :: A.Alternative -> PassM A.Alternative
doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_)))) body)
= do body' <- doProcess body
return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $
= return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $
map (A.Only m' . A.Input m' v . A.InputSimple m' . singleton) otherIIS
++ [A.Only m' body']
doAlternative s = doGeneric s
++ [A.Only m' body]
doAlternative s = return s

143
transformations/SimplifyExprs.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -31,6 +31,7 @@ import Metadata
import Pass
import qualified Properties as Prop
import ShowCode
import Traversal
import Types
import Utils
@ -48,12 +49,9 @@ simplifyExprs = makePassesDep
-- ++ makePassesDep' ((== BackendCPPCSP) . csBackend) [("Pull up definitions (C++)", pullUp True, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.functionsRemoved, Prop.processTypesChecked,Prop.seqInputsFlattened], [Prop.functionCallsRemoved, Prop.subscriptsPulledUp])]
-- | Convert FUNCTION declarations to PROCs.
functionsToProcs :: Data t => t -> PassM t
functionsToProcs = doGeneric `extM` doSpecification
functionsToProcs :: PassType
functionsToProcs = applyDepthM doSpecification
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric functionsToProcs
doSpecification :: A.Specification -> PassM A.Specification
doSpecification (A.Specification m n (A.Function mf sm rts fs evp))
= do -- Create new names for the return values.
@ -76,8 +74,8 @@ functionsToProcs = doGeneric `extM` doSpecification
A.ndPlacement = A.Unplaced
}
defineName n nd
doGeneric spec
doSpecification s = doGeneric s
return spec
doSpecification s = return s
vpToSeq :: Meta -> A.Name -> Either (A.Structured A.ExpressionList) A.Process -> [A.Variable] -> A.Process
vpToSeq m n (Left el) vs = A.Seq m $ vpToSeq' el vs
@ -101,40 +99,32 @@ functionsToProcs = doGeneric `extM` doSpecification
-- | Convert AFTER expressions to the equivalent using MINUS (which is how the
-- occam 3 manual defines AFTER).
removeAfter :: Data t => t -> PassM t
removeAfter = doGeneric `extM` doExpression
removeAfter :: PassType
removeAfter = applyDepthM doExpression
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric removeAfter
doExpression :: A.Expression -> PassM A.Expression
doExpression (A.Dyadic m A.After a b)
= do a' <- removeAfter a
b' <- removeAfter b
t <- astTypeOf a'
= do t <- astTypeOf a
case t of
A.Byte -> do let one = A.Literal m t $ A.IntLiteral m "1"
oneTwoSeven = A.Literal m t $ A.IntLiteral m "127"
return $ A.Dyadic m A.Less (A.Dyadic m A.Minus (A.Dyadic m A.Minus a' b') one) oneTwoSeven
return $ A.Dyadic m A.Less (A.Dyadic m A.Minus (A.Dyadic m A.Minus a b) one) oneTwoSeven
_ -> do let zero = A.Literal m t $ A.IntLiteral m "0"
return $ A.Dyadic m A.More (A.Dyadic m A.Minus a' b') zero
doExpression e = doGeneric e
return $ A.Dyadic m A.More (A.Dyadic m A.Minus a b) zero
doExpression e = return e
-- | For array literals that include other arrays, burst them into their elements.
expandArrayLiterals :: Data t => t -> PassM t
expandArrayLiterals = doGeneric `extM` doArrayElem
-- | For array literals that include other arrays, burst them into their
-- elements.
expandArrayLiterals :: PassType
expandArrayLiterals = applyDepthM doArrayElem
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric expandArrayLiterals
doArrayElem :: A.ArrayElem -> PassM A.ArrayElem
doArrayElem ae@(A.ArrayElemExpr e)
= do e' <- expandArrayLiterals e
t <- astTypeOf e'
= do t <- astTypeOf e
case t of
A.Array ds _ -> expand ds e
_ -> doGeneric ae
doArrayElem ae = doGeneric ae
_ -> return ae
doArrayElem ae = return ae
expand :: [A.Dimension] -> A.Expression -> PassM A.ArrayElem
expand [] e = return $ A.ArrayElemExpr e
@ -159,26 +149,21 @@ expandArrayLiterals = doGeneric `extM` doArrayElem
-- Therefore, we only need to pull up the counts for sequential replicators
--
-- TODO for simplification, we could avoid pulling up replication counts that are known to be constants
pullRepCounts :: Data t => t -> PassM t
pullRepCounts = doGeneric `extM` doProcess
pullRepCounts :: PassType
pullRepCounts = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric pullRepCounts
doProcess :: A.Process -> PassM A.Process
doProcess (A.Seq m s) = pullRepCountSeq s >>* A.Seq m
doProcess p = doGeneric p
doProcess p = return p
pullRepCountSeq :: A.Structured A.Process -> PassM (A.Structured A.Process)
pullRepCountSeq (A.Only m p) = doProcess p >>* A.Only m
pullRepCountSeq s@(A.Only _ _) = return s
pullRepCountSeq (A.Spec m sp str)
= do sp' <- pullRepCounts sp
str' <- pullRepCountSeq str
return $ A.Spec m sp' str'
= do str' <- pullRepCountSeq str
return $ A.Spec m sp str'
pullRepCountSeq (A.ProcThen m p s)
= do p' <- doProcess p
s' <- pullRepCountSeq s
return $ A.ProcThen m p' s'
= 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
@ -190,12 +175,9 @@ pullRepCounts = doGeneric `extM` doProcess
= do s' <- pullRepCountSeq s
return $ A.Rep m rep s'
transformConstr :: Data t => t -> PassM t
transformConstr = doGeneric `ext1M` doStructured
transformConstr :: PassType
transformConstr = applyDepthSM doStructured
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformConstr
-- For arrays, this takes a constructor expression:
-- VAL type name IS [i = rep | expr]:
-- ...
@ -218,8 +200,7 @@ transformConstr = doGeneric `ext1M` doStructured
-- 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)
= do scope' <- transformConstr scope
case t of
= do case t of
A.Array {} ->
do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.VariableName A.Original
let indexVar = A.Variable m'' indexName
@ -232,11 +213,11 @@ transformConstr = doGeneric `ext1M` doStructured
[ assignItem indexVar
, incrementIndex indexVar ]
])
scope'
scope
A.List {} ->
return $ declDest $ A.ProcThen m''
(A.Seq m'' $ A.Rep m'' rep $ appendItem)
scope'
scope
_ -> diePC m $ formatCode "Unsupported type for array constructor: %" t
where
declDest :: Data a => A.Structured a -> A.Structured a
@ -261,26 +242,26 @@ transformConstr = doGeneric `ext1M` doStructured
(A.ExprVariable m'' $ A.Variable m'' n)
(A.Literal m'' t $ A.ListLiteral m'' [exp])]
doStructured s = doGeneric s
doStructured s = return s
-- | Find things that need to be moved up to their enclosing Structured, and do
-- so.
pullUp :: Data t => Bool -> t -> PassM t
pullUp pullUpArraysInsideRecords
= doGeneric
`ext1M` doStructured
`extM` doProcess
`extM` doSpecification
`extM` doLiteralRepr
`extM` doExpression
`extM` doVariable
`extM` doExpressionList
pullUp :: Bool -> PassType
pullUp pullUpArraysInsideRecords = recurse
where
pullUpRecur :: Data t => t -> PassM t
pullUpRecur = pullUp pullUpArraysInsideRecords
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric pullUpRecur
ops :: Ops
ops = baseOp
`extOpS` doStructured
`extOp` doProcess
`extOp` doSpecification
`extOp` doLiteralRepr
`extOp` doExpression
`extOp` doVariable
`extOp` doExpressionList
recurse :: Recurse
recurse = makeRecurse ops
descend :: Descend
descend = makeDescend ops
-- | When we encounter a Structured, create a new pulled items state,
-- recurse over it, then apply whatever pulled items we found to it.
@ -288,7 +269,7 @@ pullUp pullUpArraysInsideRecords
doStructured s
= do pushPullContext
-- Recurse over the body, then apply the pulled items to it
s' <- doGeneric s >>= applyPulled
s' <- descend s >>= applyPulled
-- ... and restore the original pulled items
popPullContext
return s'
@ -298,7 +279,7 @@ pullUp pullUpArraysInsideRecords
doProcess :: A.Process -> PassM A.Process
doProcess p
= do pushPullContext
p' <- doGeneric p
p' <- descend p
pulled <- havePulled
p'' <- if pulled
then liftM (A.Seq emptyMeta) $ applyPulled (A.Only emptyMeta p')
@ -310,11 +291,11 @@ pullUp pullUpArraysInsideRecords
doSpecification :: A.Specification -> PassM A.Specification
-- Iss might be SubscriptedVars -- which is fine; the backend can deal with that.
doSpecification (A.Specification m n (A.Is m' am t v))
= do v' <- doGeneric v -- note doGeneric rather than pullUp
= do v' <- descend v -- note descend rather than pullUp
return $ A.Specification m n (A.Is m' am t v')
-- IsExprs might be SubscriptedExprs, and if so we have to convert them.
doSpecification (A.Specification m n (A.IsExpr m' am t e))
= do e' <- doExpression' e -- note doExpression' rather than pullUp
= do e' <- doExpression' e -- note doExpression' rather than recurse
return $ A.Specification m n (A.IsExpr m' am t e')
-- Convert RetypesExpr into Retypes of a variable.
doSpecification (A.Specification m n (A.RetypesExpr m' am toT e))
@ -323,7 +304,7 @@ pullUp pullUpArraysInsideRecords
spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e'
addPulled $ (m', Left spec)
return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n'))
doSpecification s = doGeneric s
doSpecification s = descend s
-- | Filter what can be pulled in LiteralReprs.
doLiteralRepr :: A.LiteralRepr -> PassM A.LiteralRepr
@ -331,9 +312,9 @@ pullUp pullUpArraysInsideRecords
-- for nested array literals.
-- Don't pull up array expressions that are fields of record literals.
doLiteralRepr (A.RecordLiteral m es)
= do es' <- mapM (if pullUpArraysInsideRecords then doExpression else doExpression') es -- note doExpression' rather than pullUp
= do es' <- mapM (if pullUpArraysInsideRecords then doExpression else doExpression') es -- note doExpression' rather than recurse
return $ A.RecordLiteral m es'
doLiteralRepr lr = doGeneric lr
doLiteralRepr lr = descend lr
-- | Pull array expressions that aren't already non-subscripted variables.
-- Also pull lists that are literals or constructed
@ -366,7 +347,7 @@ pullUp pullUpArraysInsideRecords
-- | Pull any variable subscript that results in an array.
doVariable :: A.Variable -> PassM A.Variable
doVariable v@(A.SubscriptedVariable m _ _)
= do v' <- doGeneric v
= do v' <- descend v
t <- astTypeOf v'
case t of
A.Array _ _ ->
@ -376,12 +357,12 @@ pullUp pullUpArraysInsideRecords
addPulled $ (m, Left spec)
return $ A.Variable m n
_ -> return v'
doVariable v = doGeneric v
doVariable v = descend v
-- | Convert a FUNCTION call into some variables and a PROC call.
convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable]
convertFuncCall m n es
= do es' <- pullUpRecur es
= do es' <- recurse es
ets <- sequence [astTypeOf e | e <- es']
ps <- get
@ -403,18 +384,18 @@ pullUp pullUpArraysInsideRecords
return $ A.ExprVariable m v
-- Convert SubscriptedExprs into SubscriptedVariables.
doExpression' (A.SubscriptedExpr m s e)
= do e' <- pullUpRecur e
s' <- pullUpRecur s
= do e' <- recurse e
s' <- recurse s
t <- astTypeOf e'
spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e'
addPulled $ (m, Left spec)
return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n))
doExpression' e = doGeneric e
doExpression' e = descend e
doExpressionList :: A.ExpressionList -> PassM A.ExpressionList
-- Convert multi-valued function calls.
doExpressionList (A.FunctionCallList m n es)
= do vs <- convertFuncCall m n es
return $ A.ExpressionList m [A.ExprVariable m v | v <- vs]
doExpressionList el = doGeneric el
doExpressionList el = descend el

56
transformations/SimplifyProcs.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -28,6 +28,7 @@ import CompState
import Metadata
import Pass
import qualified Properties as Prop
import Traversal
import Types
simplifyProcs :: [Pass]
@ -38,47 +39,37 @@ simplifyProcs = makePassesDep
]
-- | Wrap the subprocesses of PARs in no-arg PROCs.
parsToProcs :: Data t => t -> PassM t
parsToProcs = doGeneric `extM` doProcess
parsToProcs :: PassType
parsToProcs = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric parsToProcs
doProcess :: A.Process -> PassM A.Process
doProcess (A.Par m pm s)
= do s' <- doStructured s
return $ A.Par m pm s'
doProcess p = doGeneric p
doProcess p = return p
-- FIXME This should be generic and in Pass.
doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
doStructured (A.Rep m r s)
= do r' <- parsToProcs r
s' <- doStructured s
return $ A.Rep m r' s'
= do s' <- doStructured s
return $ A.Rep m r s'
doStructured (A.Spec m spec s)
= do spec' <- parsToProcs spec
s' <- doStructured s
return $ A.Spec m spec' s'
= do s' <- doStructured s
return $ A.Spec m spec s'
doStructured (A.ProcThen m p s)
= do p' <- parsToProcs p
s' <- doStructured s
return $ A.ProcThen m p' s'
= do s' <- doStructured s
return $ A.ProcThen m p s'
doStructured (A.Only m p)
= do p' <- parsToProcs p
s@(A.Specification _ n _) <- makeNonceProc m p'
= do s@(A.Specification _ n _) <- makeNonceProc m p
modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
return $ A.Spec m s (A.Only m (A.ProcCall m n []))
doStructured (A.Several m ss)
= liftM (A.Several m) $ mapM doStructured ss
-- | Turn parallel assignment into multiple single assignments through temporaries.
removeParAssign :: Data t => t -> PassM t
removeParAssign = doGeneric `extM` doProcess
removeParAssign :: PassType
removeParAssign = applyDepthM doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric removeParAssign
doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
= do ts <- mapM astTypeOf vs
@ -87,27 +78,26 @@ removeParAssign = doGeneric `extM` doProcess
let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps]
return $ A.Seq m $ foldl (\s spec -> A.Spec m spec s) (A.Several m (map (A.Only m) (first ++ second))) specs
doProcess p = doGeneric p
doProcess p = return p
-- | Turn assignment of arrays and records into multiple assignments.
flattenAssign :: Data t => t -> PassM t
flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured
flattenAssign :: PassType
flattenAssign = makeRecurse ops
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric flattenAssign
ops :: Ops
ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess
doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m [v] (A.ExpressionList m' [e]))
= do t <- astTypeOf v
assign m t v m' e
doProcess p = doGeneric p
doProcess p = return p
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Spec m (A.Specification m' n t@(A.RecordType _ _ fs)) s)
= do procSpec <- recordCopyProc n m fs
s' <- doStructured s
return $ A.Spec m (A.Specification m' n t) (procSpec s')
doStructured s = doGeneric s
return $ A.Spec m (A.Specification m' n t) (procSpec s)
doStructured s = return s
assign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process
assign m t@(A.Array _ _) v m' e = complexAssign m t v m' e

13
transformations/SimplifyTypes.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -20,13 +20,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module SimplifyTypes (simplifyTypes) where
import Control.Monad.State
import Data.Generics
import qualified Data.Set as Set
import qualified AST as A
import Metadata
import Pass
import qualified Properties as Prop
import Traversal
import Types
simplifyTypes :: [Pass]
@ -41,12 +41,9 @@ resolveAllNamedTypes = Pass
,passEnabled = const True}
-- | Turn named data types into their underlying types.
resolveNamedTypes :: Data t => t -> PassM t
resolveNamedTypes = doGeneric `extM` doType
resolveNamedTypes :: PassType
resolveNamedTypes = applyDepthM doType
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric resolveNamedTypes
doType :: A.Type -> PassM A.Type
doType t@(A.UserDataType _) = underlyingType emptyMeta t
doType t = doGeneric t
doType t = return t

79
transformations/Unnest.hs
View File

@ -1,6 +1,6 @@
{-
Tock: a compiler for parallel languages
Copyright (C) 2007 University of Kent
Copyright (C) 2007, 2008 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
@ -19,6 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Flatten nested declarations.
module Unnest (unnest) where
import Control.Monad.Identity
import Control.Monad.State
import Data.Generics
import Data.List
@ -32,6 +33,7 @@ import EvalConstants
import Metadata
import Pass
import qualified Properties as Prop
import Traversal
import Types
unnest :: [Pass]
@ -86,33 +88,21 @@ freeNamesIn = doGeneric
-- | Replace names.
replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
replaceNames map = doGeneric `extT` doName
replaceNames map v = runIdentity $ applyDepthM doName v
where
doGeneric :: Data t => t -> t
doGeneric = (gmapT (replaceNames map))
`extT` (id :: String -> String)
`extT` (id :: Meta -> Meta)
smap = [(A.nameName f, t) | (f, t) <- map]
smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
doName :: A.Name -> A.Name
doName n
= case lookup (A.nameName n) smap of
Just n' -> n'
Nothing -> n
doName :: A.Name -> Identity A.Name
doName n = return $ Map.findWithDefault n (A.nameName n) smap
-- | Turn free names in PROCs into arguments.
removeFreeNames :: Data t => t -> PassM t
removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
removeFreeNames :: PassType
removeFreeNames = applyDepthM2 doSpecification doProcess
where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric removeFreeNames
doSpecification :: A.Specification -> PassM A.Specification
doSpecification spec = case spec of
A.Specification m n st@(A.Proc _ _ _ _) ->
do st'@(A.Proc mp sm fs p) <- removeFreeNames st
-- If this is the top-level process, we shouldn't add new args --
A.Specification m n st@(A.Proc mp sm fs p) ->
do -- If this is the top-level process, we shouldn't add new args --
-- we know it's not going to be moved by removeNesting, so anything
-- that it had in scope originally will still be in scope.
ps <- get
@ -120,7 +110,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
let isTLP = (snd $ head $ csMainLocals ps) == n
-- Figure out the free names.
let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st'
let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st
let freeNames'' = [n | n <- freeNames',
case A.nameType n of
A.ChannelName -> True
@ -145,12 +135,12 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
-- Add formals for each of the free names
let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames]
let st'' = A.Proc mp sm (fs ++ newFs) $ replaceNames (zip freeNames newNames) p
let spec' = A.Specification m n st''
let st' = A.Proc mp sm (fs ++ newFs) $ replaceNames (zip freeNames newNames) p
let spec' = A.Specification m n st'
-- Update the definition of the proc
nameDef <- lookupName n
defineName n (nameDef { A.ndSpecType = st'' })
defineName n (nameDef { A.ndSpecType = st' })
-- Note that we should add extra arguments to calls of this proc
-- when we find them
@ -163,42 +153,43 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })
return spec'
_ -> doGeneric spec
_ -> return spec
-- | Add the extra arguments we recorded when we saw the definition.
doProcess :: A.Process -> PassM A.Process
doProcess p@(A.ProcCall m n as)
= do st <- get
case Map.lookup (A.nameName n) (csAdditionalArgs st) of
Just add -> doGeneric $ A.ProcCall m n (as ++ add)
Nothing -> doGeneric p
doProcess p = doGeneric p
Just add -> return $ A.ProcCall m n (as ++ add)
Nothing -> return p
doProcess p = return p
-- | Pull nested declarations to the top level.
removeNesting :: forall a. Data a => A.Structured a -> PassM (A.Structured a)
removeNesting p
removeNesting :: Data t => Transform (A.Structured t)
removeNesting s
= do pushPullContext
p' <- pullSpecs p
s <- applyPulled p'
s' <- (makeRecurse ops) s >>= applyPulled
popPullContext
return s
return s'
where
pullSpecs :: Data t => t -> PassM t
pullSpecs = doGeneric `ext1M` doStructured
ops :: Ops
ops = baseOp `extOpS` doStructured
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric pullSpecs
recurse :: Recurse
recurse = makeRecurse ops
descend :: Descend
descend = makeDescend ops
doStructured :: Data t => A.Structured t -> PassM (A.Structured t)
doStructured s@(A.Spec m spec@(A.Specification _ n st) subS)
= do isConst <- isConstantName n
doStructured :: Data t => Transform (A.Structured t)
doStructured s@(A.Spec m spec subS)
= do spec'@(A.Specification _ n st) <- recurse spec
isConst <- isConstantName n
if isConst || canPull st then
do debug $ "removeNesting: pulling up " ++ show n
spec' <- doGeneric spec
addPulled $ (m, Left spec')
doStructured subS
else doGeneric s
doStructured s = doGeneric s
else descend s
doStructured s = descend s
canPull :: A.SpecType -> Bool
canPull (A.Proc _ _ _ _) = True