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

12
backends/GenerateCPPCSP.hs
View File

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

24
common/Types.hs
View File

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

58
frontends/RainPasses.hs
View File

@ -1,6 +1,6 @@
{- {-
Tock: a compiler for parallel languages 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 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 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 qualified Properties as Prop
import RainTypes import RainTypes
import SimplifyTypes import SimplifyTypes
import Traversal
import TreeUtils import TreeUtils
import Types 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' -- | A pass that transforms all instances of 'A.Int' into 'A.Int64'
transformInt :: Data t => t -> PassM t transformInt :: PassType
transformInt = everywhereM (mkM transformInt') transformInt = applyDepthM transformInt'
where where
transformInt' :: A.Type -> PassM A.Type transformInt' :: A.Type -> PassM A.Type
transformInt' A.Int = return A.Int64 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 -- This pass works because everywhereM goes bottom-up, so declarations are
--resolved from the bottom upwards. --resolved from the bottom upwards.
uniquifyAndResolveVars :: Data t => t -> PassM t uniquifyAndResolveVars :: PassType
uniquifyAndResolveVars = everywhereM (mk1M uniquifyAndResolveVars') uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
where where
uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a) 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 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). -- | 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 --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" --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 --in the CompState, and pull it out into csMainLocals
findMain x = do newMainName <- makeNonce "main_" findMain x = do newMainName <- makeNonce "main_"
modify (findMain' newMainName) modify (findMain' newMainName)
everywhereM (mkM $ return . (replaceNameName "main" newMainName)) x applyDepthM (return . (replaceNameName "main" newMainName)) x
where where
--We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++) --We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++)
findMain' :: String -> CompState -> CompState findMain' :: String -> CompState -> CompState
@ -183,32 +184,25 @@ checkIntegral (A.ByteLiteral _ s) = Nothing -- TODO support char literals
checkIntegral _ = Nothing checkIntegral _ = Nothing
-- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops -- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops
transformEachRange :: Data t => t -> PassM t transformEachRange :: PassType
transformEachRange = doGeneric `ext1M` doStructured transformEachRange = applyDepthSM doStructured
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformEachRange
doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr
_ (A.RangeConstr _ _ begin end))) body) _ (A.RangeConstr _ _ begin end))) body)
= do body' <- doStructured body = do -- Need to change the stored abbreviation mode to original:
-- Need to change the stored abbreviation mode to original:
modifyName loopVar $ \nd -> nd { A.ndAbbrevMode = A.Original } modifyName loopVar $ \nd -> nd { A.ndAbbrevMode = A.Original }
return $ A.Rep repMeta (A.For eachMeta loopVar begin return $ A.Rep repMeta (A.For eachMeta loopVar begin
(addOne $ subExprs end begin)) body' (addOne $ subExprs end begin)) body
doStructured s = doGeneric s doStructured s = return s
-- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions -- | 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 -- TODO make sure when the range has a bad order that an empty list is
-- returned -- returned
transformRangeRep :: Data t => t -> PassM t transformRangeRep :: PassType
transformRangeRep = doGeneric `extM` doExpression transformRangeRep = applyDepthM doExpression
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformRangeRep
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression (A.ExprConstr _ (A.RangeConstr m t begin end)) doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
= do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.VariableName A.ValAbbrev = 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 return $ A.ExprConstr m $ A.RepConstr m t
(A.For m rep begin count) (A.For m rep begin count)
(A.ExprVariable m $ A.Variable m rep) (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 -- TODO this is almost certainly better figured out from the CFG
checkFunction :: Data t => t -> PassM t checkFunction :: PassType
checkFunction = return -- everywhereM (mkM checkFunction') checkFunction = return -- applyDepthM checkFunction'
where where
checkFunction' :: A.Specification -> PassM A.Specification checkFunction' :: A.Specification -> PassM A.Specification
checkFunction' spec@(A.Specification _ n (A.Function m _ _ _ (Right body))) 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 -- 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 -- C++); these will only be valid if exactly the same list is used
-- throughout the loop. -- throughout the loop.
pullUpForEach :: Data t => t -> PassM t pullUpForEach :: PassType
pullUpForEach = doGeneric `ext1M` doStructured pullUpForEach = applyDepthSM doStructured
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric pullUpForEach
doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s) doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
= do (extra, loopExp') <- case loopExp of = do (extra, loopExp') <- case loopExp of
@ -260,13 +251,12 @@ pullUpForEach = doGeneric `ext1M` doStructured
spec@(A.Specification _ n _) <- makeNonceIsExpr spec@(A.Specification _ n _) <- makeNonceIsExpr
"loop_expr" m' t loopExp "loop_expr" m' t loopExp
return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n)) 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
return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s' doStructured s = return s
doStructured s = doGeneric s
pullUpParDeclarations :: Data t => t -> PassM t pullUpParDeclarations :: PassType
pullUpParDeclarations = everywhereM (mkM pullUpParDeclarations') pullUpParDeclarations = applyDepthM pullUpParDeclarations'
where where
pullUpParDeclarations' :: A.Process -> PassM A.Process pullUpParDeclarations' :: A.Process -> PassM A.Process
pullUpParDeclarations' p@(A.Par m mode inside) pullUpParDeclarations' p@(A.Par m mode inside)

24
frontends/RainTypes.hs
View File

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

24
pass/Pass.hs
View File

@ -1,6 +1,6 @@
{- {-
Tock: a compiler for parallel languages 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 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 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 qualified AST as A
import CompState import CompState
import Errors import Errors
import Metadata
import PrettyShow import PrettyShow
import TreeUtils import TreeUtils
import Utils import Utils
@ -52,7 +51,13 @@ instance Warn PassM where
instance Warn PassMR where instance Warn PassMR where
warnReport w = lift $ lift $ modify (++ [w]) 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 { data Monad m => Pass_ m = Pass {
passCode :: A.AST -> m A.AST passCode :: A.AST -> m A.AST
,passName :: String ,passName :: String
@ -67,10 +72,10 @@ instance Monad m => Eq (Pass_ m) where
instance Monad m => Ord (Pass_ m) where instance Monad m => Ord (Pass_ m) where
compare x y = compare (passName x) (passName y) compare x y = compare (passName x) (passName y)
type Pass = Pass_ PassM type Pass = Pass_ PassM
type PassR = Pass_ PassMR type PassR = Pass_ PassMR
-- | A property that can be asserted and tested against the AST.
data Property = Property { data Property = Property {
propName :: String propName :: String
,propCheck :: A.AST -> PassMR () ,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.Several m ss) = mapM (applyToOnly f) ss >>* A.Several m
applyToOnly f (A.Only m o) = f o >>* A.Only 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 :: (Data a, CSMR m) => [Constr] -> a -> m a
excludeConstr cons x 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) = if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x)
where where
items = checkTreeForConstr cons x 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. -- | Traversal strategies over the AST and other data types.
module Traversal ( module Traversal (
ExplicitTrans, Transform, Check OpsM, Ops
, transformToExplicitDepth, checkToTransform , TransformM, Transform
, baseX, extX, extD, extC, applyX , CheckM, Check
, applyDepthM, applyDepthM2 , baseOp, extOp, extOpS
, makeDepth, extOpD, extOpSD
, makeCheck, extOpC
, RecurseM, Recurse, makeRecurse
, DescendM, Descend, makeDescend
, applyDepthM, applyDepthSM, applyDepthM2
, checkDepthM, checkDepthM2 , checkDepthM, checkDepthM2
) where ) where
import Data.Generics import Data.Generics
import qualified AST as A
import GenericUtils import GenericUtils
import NavAST
import Pass import Pass
-- | A transformation for a single 'Data' type with explicit descent. -- | A set of generic operations.
-- The first argument passed is a function that can be called to explicitly type OpsM m = ([TypeKey], DescendM m -> RecurseM m)
-- descend into a generic value.
type ExplicitTrans t = (forall s. Data s => s -> PassM s) -> t -> PassM t
-- | A transformation for a single 'Data' type with implicit descent. -- | As 'OpsM', but specialised for 'PassM'.
-- This can be applied recursively throughout a data structure. type Ops = OpsM PassM
type Transform t = t -> PassM t
-- | 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 -- This is like 'Transform', but it doesn't change the value; it may fail or
-- modify the state, though. -- 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. -- | As 'CheckM', but specialised for 'PassM'.
transformToExplicitDepth :: Data t => Transform t -> ExplicitTrans t type Check t = CheckM PassM t
transformToExplicitDepth f descend x = descend x >>= f
-- | Make a 'Transform' that applies a 'Check'. -- | An empty set of operations.
checkToTransform :: Data t => Check t -> Transform t baseOp :: forall m. Monad m => OpsM m
checkToTransform f x = f x >> return x baseOp = ([], id)
-- | A set of generic transformations. -- | Add a 'TransformM' to a set, to be applied with explicit descent
type InfoX = ([TypeKey], -- (that is, the transform will be responsible for recursing into child
(forall dgt. Data dgt => dgt -> PassM dgt) -- elements itself).
-> (forall t1. Data t1 => t1 -> PassM t1) extOp :: forall m t. (Monad m, Data t) => OpsM m -> TransformM m t -> OpsM m
-> (forall t2. Data t2 => t2 -> PassM t2)) extOp (tks, g) f = ((typeKey (undefined :: t)) : tks,
(\descend -> g descend `extM` f))
-- | An empty set of transformations. -- | As 'extOp', but for transformations that work on all 'A.Structured' types.
baseX :: InfoX extOpS :: forall m. Monad m =>
baseX = ([], (\doGeneric t -> t)) 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. -- | Generate an operation that applies a 'TransformM' with automatic
extX :: forall t. Data t => InfoX -> ExplicitTrans t -> InfoX -- depth-first descent.
extX (tks, g) f = ((typeKey (undefined :: t)) : tks, makeDepth :: (Monad m, Data t) => OpsM m -> TransformM m t -> TransformM m t
(\doGeneric t -> (g doGeneric t) `extM` (f doGeneric))) makeDepth ops f v = descend v >>= f
where
descend = makeDescend ops
-- | Add a 'Transform' to a set, to be applied depth-first. -- | Add a 'TransformM' to a set, to be applied with automatic depth-first
extD :: forall t. Data t => InfoX -> Transform t -> InfoX -- descent.
extD info f = extX info (transformToExplicitDepth f) 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. -- | As 'extOpD', but for transformations that work on all 'A.Structured' types.
extC :: forall t. Data t => InfoX -> Check t -> InfoX extOpSD :: forall m. Monad m =>
extC info f = extD info (checkToTransform f) 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. -- | Generate an operation that applies a 'CheckM' with automatic
applyX :: Data s => InfoX -> s -> PassM s -- depth-first descent.
applyX info@(tks, maker) = trans 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 where
ts :: TypeSet ts :: TypeSet
ts = makeTypeSet tks ts = makeTypeSet tks
trans :: Data s => s -> PassM s recurse :: RecurseM m
trans = maker doGeneric doGeneric recurse = makeRecurse ops
doGeneric :: Data t => t -> PassM t
doGeneric = gmapMFor ts trans
-- | Apply a transformation, recursing depth-first. -- | Apply a transformation, recursing depth-first.
applyDepthM :: forall t1 s. (Data t1, Data s) => applyDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
Transform t1 -> s -> PassM s TransformM m t1 -> s -> m s
applyDepthM f1 applyDepthM f1 = makeRecurse ops
= applyX $ baseX `extD` f1 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. -- | Apply two transformations, recursing depth-first.
applyDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) => applyDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
Transform t1 -> Transform t2 -> s -> PassM s TransformM m t1 -> TransformM m t2 -> s -> m s
applyDepthM2 f1 f2 applyDepthM2 f1 f2 = makeRecurse ops
= applyX $ baseX `extD` f1 `extD` f2 where
ops :: OpsM m
ops = baseOp `extOp` makeDepth ops f1
`extOp` makeDepth ops f2
-- | Apply a check, recursing depth-first. -- | Apply a check, recursing depth-first.
checkDepthM :: forall t1 s. (Data t1, Data s) => checkDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
Check t1 -> s -> PassM s CheckM m t1 -> s -> m s
checkDepthM f1 checkDepthM f1 = makeRecurse ops
= applyX $ baseX `extC` f1 where
ops :: OpsM m
ops = baseOp `extOp` makeCheck ops f1
-- | Apply two checks, recursing depth-first. -- | Apply two checks, recursing depth-first.
checkDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) => checkDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) =>
Check t1 -> Check t2 -> s -> PassM s CheckM m t1 -> CheckM m t2 -> s -> m s
checkDepthM2 f1 f2 checkDepthM2 f1 f2 = makeRecurse ops
= applyX $ baseX `extC` f1 `extC` f2 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 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 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 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 module SimplifyComms where
import Control.Monad.State import Control.Monad.State
import Data.Generics
import Data.List import Data.List
import qualified AST as A import qualified AST as A
@ -28,6 +27,7 @@ import CompState
import Metadata import Metadata
import Pass import Pass
import qualified Properties as Prop import qualified Properties as Prop
import Traversal
import Types import Types
import Utils 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]) ,("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 :: PassType
outExprs = doGeneric `extM` doProcess outExprs = applyDepthM doProcess
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric outExprs
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Output m c ois) doProcess (A.Output m c ois)
= do (ois', specs) <- mapAndUnzipM changeItem ois = do (ois', specs) <- mapAndUnzipM changeItem ois
@ -53,7 +50,7 @@ outExprs = doGeneric `extM` doProcess
= do (ois', specs) <- mapAndUnzipM changeItem ois = do (ois', specs) <- mapAndUnzipM changeItem ois
let foldedSpec = foldFuncs specs let foldedSpec = foldFuncs specs
return $ A.Seq m (foldedSpec $ A.Only m $ A.OutputCase m c tag ois') 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.OutputItem -> PassM (A.OutputItem, A.Structured A.Process -> A.Structured A.Process)
changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e
@ -133,12 +130,9 @@ ALT
-- process D -- process D
-} -}
transformInputCase :: Data t => t -> PassM t transformInputCase :: PassType
transformInputCase = doGeneric `extM` doProcess transformInputCase = applyDepthM doProcess
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformInputCase
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputCase m' s)) 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 = 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) doProcess (A.Alt m pri s)
= do s' <- doStructuredA s = do s' <- doStructuredA s
return (A.Alt m pri 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 -- 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) doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
-- These entries all just burrow deeper into the structured: -- These entries all just burrow deeper into the structured:
doStructuredV v (A.ProcThen m p s) doStructuredV v (A.ProcThen m p s)
= do s' <- doStructuredV v 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) doStructuredV v (A.Spec m sp st)
= do st' <- doStructuredV v st = do st' <- doStructuredV v st
return (A.Spec m sp 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)) doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
= do (Right items) <- protocolItems chanVar = do (Right items) <- protocolItems chanVar
let (Just idx) = elemIndex n (fst $ unzip items) let (Just idx) = elemIndex n (fst $ unzip items)
p' <- doProcess p
return $ A.Only m $ A.Option m' [makeConstant m' idx] $ return $ A.Only m $ A.Option m' [makeConstant m' idx] $
if (length iis == 0) if (length iis == 0)
then p' then p
else A.Seq m' $ A.Several m' else A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis) [A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
,A.Only (findMeta p') p'] A.Only (findMeta p) p]
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative) 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) doStructuredA (A.ProcThen m p s)
= do s' <- doStructuredA 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) doStructuredA (A.Spec m sp st)
= do st' <- doStructuredA st = do st' <- doStructuredA st
return (A.Spec m sp st') return (A.Spec m sp st')
@ -206,22 +197,18 @@ transformInputCase = doGeneric `extM` doProcess
-- Leave other guards (and parts of Structured) untouched: -- Leave other guards (and parts of Structured) untouched:
doStructuredA s = return s doStructuredA s = return s
transformProtocolInput :: Data t => t -> PassM t transformProtocolInput :: PassType
transformProtocolInput = doGeneric `extM` doProcess `extM` doAlternative transformProtocolInput = applyDepthM2 doProcess doAlternative
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric transformProtocolInput
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_))) doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_)))
= return $ A.Seq m $ A.Several m $ = return $ A.Seq m $ A.Several m $
map (A.Only m . A.Input m v . A.InputSimple m' . singleton) iis 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 -> PassM A.Alternative
doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_)))) body) 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 map (A.Only m' . A.Input m' v . A.InputSimple m' . singleton) otherIIS
++ [A.Only m' body'] ++ [A.Only m' body]
doAlternative s = doGeneric s doAlternative s = return s

143
transformations/SimplifyExprs.hs
View File

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

54
transformations/SimplifyProcs.hs
View File

@ -1,6 +1,6 @@
{- {-
Tock: a compiler for parallel languages 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 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 under the terms of the GNU General Public License as published by the
@ -28,6 +28,7 @@ import CompState
import Metadata import Metadata
import Pass import Pass
import qualified Properties as Prop import qualified Properties as Prop
import Traversal
import Types import Types
simplifyProcs :: [Pass] simplifyProcs :: [Pass]
@ -38,47 +39,37 @@ simplifyProcs = makePassesDep
] ]
-- | Wrap the subprocesses of PARs in no-arg PROCs. -- | Wrap the subprocesses of PARs in no-arg PROCs.
parsToProcs :: Data t => t -> PassM t parsToProcs :: PassType
parsToProcs = doGeneric `extM` doProcess parsToProcs = applyDepthM doProcess
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric parsToProcs
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Par m pm s) doProcess (A.Par m pm s)
= do s' <- doStructured s = do s' <- doStructured s
return $ A.Par m pm s' return $ A.Par m pm s'
doProcess p = doGeneric p doProcess p = return p
-- FIXME This should be generic and in Pass. -- FIXME This should be generic and in Pass.
doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process) doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
doStructured (A.Rep m r s) doStructured (A.Rep m r s)
= do r' <- parsToProcs r = do s' <- doStructured s
s' <- doStructured s return $ A.Rep m r s'
return $ A.Rep m r' s'
doStructured (A.Spec m spec s) doStructured (A.Spec m spec s)
= do spec' <- parsToProcs spec = do s' <- doStructured s
s' <- doStructured s return $ A.Spec m spec s'
return $ A.Spec m spec' s'
doStructured (A.ProcThen m p s) doStructured (A.ProcThen m p s)
= do p' <- parsToProcs p = do s' <- doStructured s
s' <- doStructured s return $ A.ProcThen m p s'
return $ A.ProcThen m p' s'
doStructured (A.Only m p) doStructured (A.Only m p)
= do p' <- parsToProcs p = do s@(A.Specification _ n _) <- makeNonceProc m p
s@(A.Specification _ n _) <- makeNonceProc m p'
modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) }) modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
return $ A.Spec m s (A.Only m (A.ProcCall m n [])) return $ A.Spec m s (A.Only m (A.ProcCall m n []))
doStructured (A.Several m ss) doStructured (A.Several m ss)
= liftM (A.Several m) $ mapM doStructured ss = liftM (A.Several m) $ mapM doStructured ss
-- | Turn parallel assignment into multiple single assignments through temporaries. -- | Turn parallel assignment into multiple single assignments through temporaries.
removeParAssign :: Data t => t -> PassM t removeParAssign :: PassType
removeParAssign = doGeneric `extM` doProcess removeParAssign = applyDepthM doProcess
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric removeParAssign
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
= do ts <- mapM astTypeOf vs = 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 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] 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 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. -- | Turn assignment of arrays and records into multiple assignments.
flattenAssign :: Data t => t -> PassM t flattenAssign :: PassType
flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured flattenAssign = makeRecurse ops
where where
doGeneric :: Data t => t -> PassM t ops :: Ops
doGeneric = makeGeneric flattenAssign ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.Assign m [v] (A.ExpressionList m' [e])) doProcess (A.Assign m [v] (A.ExpressionList m' [e]))
= do t <- astTypeOf v = do t <- astTypeOf v
assign m t v m' e 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 :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Spec m (A.Specification m' n t@(A.RecordType _ _ fs)) s) doStructured (A.Spec m (A.Specification m' n t@(A.RecordType _ _ fs)) s)
= do procSpec <- recordCopyProc n m fs = do procSpec <- recordCopyProc n m fs
s' <- doStructured s return $ A.Spec m (A.Specification m' n t) (procSpec s)
return $ A.Spec m (A.Specification m' n t) (procSpec s') doStructured s = return s
doStructured s = doGeneric s
assign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process 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 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 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 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 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 module SimplifyTypes (simplifyTypes) where
import Control.Monad.State import Control.Monad.State
import Data.Generics
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified AST as A import qualified AST as A
import Metadata import Metadata
import Pass import Pass
import qualified Properties as Prop import qualified Properties as Prop
import Traversal
import Types import Types
simplifyTypes :: [Pass] simplifyTypes :: [Pass]
@ -41,12 +41,9 @@ resolveAllNamedTypes = Pass
,passEnabled = const True} ,passEnabled = const True}
-- | Turn named data types into their underlying types. -- | Turn named data types into their underlying types.
resolveNamedTypes :: Data t => t -> PassM t resolveNamedTypes :: PassType
resolveNamedTypes = doGeneric `extM` doType resolveNamedTypes = applyDepthM doType
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric resolveNamedTypes
doType :: A.Type -> PassM A.Type doType :: A.Type -> PassM A.Type
doType t@(A.UserDataType _) = underlyingType emptyMeta t 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 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 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 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. -- | Flatten nested declarations.
module Unnest (unnest) where module Unnest (unnest) where
import Control.Monad.Identity
import Control.Monad.State import Control.Monad.State
import Data.Generics import Data.Generics
import Data.List import Data.List
@ -32,6 +33,7 @@ import EvalConstants
import Metadata import Metadata
import Pass import Pass
import qualified Properties as Prop import qualified Properties as Prop
import Traversal
import Types import Types
unnest :: [Pass] unnest :: [Pass]
@ -86,33 +88,21 @@ freeNamesIn = doGeneric
-- | Replace names. -- | Replace names.
replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
replaceNames map = doGeneric `extT` doName replaceNames map v = runIdentity $ applyDepthM doName v
where where
doGeneric :: Data t => t -> t smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
doGeneric = (gmapT (replaceNames map))
`extT` (id :: String -> String)
`extT` (id :: Meta -> Meta)
smap = [(A.nameName f, t) | (f, t) <- map]
doName :: A.Name -> A.Name doName :: A.Name -> Identity A.Name
doName n doName n = return $ Map.findWithDefault n (A.nameName n) smap
= case lookup (A.nameName n) smap of
Just n' -> n'
Nothing -> n
-- | Turn free names in PROCs into arguments. -- | Turn free names in PROCs into arguments.
removeFreeNames :: Data t => t -> PassM t removeFreeNames :: PassType
removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess removeFreeNames = applyDepthM2 doSpecification doProcess
where where
doGeneric :: Data t => t -> PassM t
doGeneric = makeGeneric removeFreeNames
doSpecification :: A.Specification -> PassM A.Specification doSpecification :: A.Specification -> PassM A.Specification
doSpecification spec = case spec of doSpecification spec = case spec of
A.Specification m n st@(A.Proc _ _ _ _) -> A.Specification m n st@(A.Proc mp sm fs p) ->
do st'@(A.Proc mp sm fs p) <- removeFreeNames st do -- If this is the top-level process, we shouldn't add new args --
-- 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 -- we know it's not going to be moved by removeNesting, so anything
-- that it had in scope originally will still be in scope. -- that it had in scope originally will still be in scope.
ps <- get ps <- get
@ -120,7 +110,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
let isTLP = (snd $ head $ csMainLocals ps) == n let isTLP = (snd $ head $ csMainLocals ps) == n
-- Figure out the free names. -- 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', let freeNames'' = [n | n <- freeNames',
case A.nameType n of case A.nameType n of
A.ChannelName -> True A.ChannelName -> True
@ -145,12 +135,12 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
-- Add formals for each of the free names -- Add formals for each of the free names
let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames] 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 st' = A.Proc mp sm (fs ++ newFs) $ replaceNames (zip freeNames newNames) p
let spec' = A.Specification m n st'' let spec' = A.Specification m n st'
-- Update the definition of the proc -- Update the definition of the proc
nameDef <- lookupName n 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 -- Note that we should add extra arguments to calls of this proc
-- when we find them -- 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) }) modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })
return spec' return spec'
_ -> doGeneric spec _ -> return spec
-- | Add the extra arguments we recorded when we saw the definition. -- | Add the extra arguments we recorded when we saw the definition.
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess p@(A.ProcCall m n as) doProcess p@(A.ProcCall m n as)
= do st <- get = do st <- get
case Map.lookup (A.nameName n) (csAdditionalArgs st) of case Map.lookup (A.nameName n) (csAdditionalArgs st) of
Just add -> doGeneric $ A.ProcCall m n (as ++ add) Just add -> return $ A.ProcCall m n (as ++ add)
Nothing -> doGeneric p Nothing -> return p
doProcess p = doGeneric p doProcess p = return p
-- | Pull nested declarations to the top level. -- | Pull nested declarations to the top level.
removeNesting :: forall a. Data a => A.Structured a -> PassM (A.Structured a) removeNesting :: Data t => Transform (A.Structured t)
removeNesting p removeNesting s
= do pushPullContext = do pushPullContext
p' <- pullSpecs p s' <- (makeRecurse ops) s >>= applyPulled
s <- applyPulled p'
popPullContext popPullContext
return s return s'
where where
pullSpecs :: Data t => t -> PassM t ops :: Ops
pullSpecs = doGeneric `ext1M` doStructured ops = baseOp `extOpS` doStructured
doGeneric :: Data t => t -> PassM t recurse :: Recurse
doGeneric = makeGeneric pullSpecs recurse = makeRecurse ops
descend :: Descend
descend = makeDescend ops
doStructured :: Data t => A.Structured t -> PassM (A.Structured t) doStructured :: Data t => Transform (A.Structured t)
doStructured s@(A.Spec m spec@(A.Specification _ n st) subS) doStructured s@(A.Spec m spec subS)
= do isConst <- isConstantName n = do spec'@(A.Specification _ n st) <- recurse spec
isConst <- isConstantName n
if isConst || canPull st then if isConst || canPull st then
do debug $ "removeNesting: pulling up " ++ show n do debug $ "removeNesting: pulling up " ++ show n
spec' <- doGeneric spec
addPulled $ (m, Left spec') addPulled $ (m, Left spec')
doStructured subS doStructured subS
else doGeneric s else descend s
doStructured s = doGeneric s doStructured s = descend s
canPull :: A.SpecType -> Bool canPull :: A.SpecType -> Bool
canPull (A.Proc _ _ _ _) = True canPull (A.Proc _ _ _ _) = True