From 890e7ea9a69dec09777d891494ea9142ae1a23f5 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 2 Dec 2008 18:06:10 +0000 Subject: [PATCH] Fixed many of the modules to use the new Polyplate-based Traversal system --- common/Types.hs | 22 +++++++++++++++++ pass/Traversal.hs | 16 +++++++++++-- transformations/SimplifyComms.hs | 14 +++++------ transformations/SimplifyExprs.hs | 38 +++++++++++++++++------------ transformations/SimplifyProcs.hs | 18 +++++++------- transformations/Unnest.hs | 41 +++++++++++++------------------- 6 files changed, 91 insertions(+), 58 deletions(-) diff --git a/common/Types.hs b/common/Types.hs index 3060699..74137ea 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -363,6 +363,28 @@ abbrevModeOfSpec s A.RetypesExpr _ am _ _ -> am _ -> A.Original +-- | Resolve a datatype into its underlying type -- i.e. if it's a named data +-- type, then return the underlying real type. This will recurse. +underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type +underlyingType m = applyDepthM doType + where + doType :: A.Type -> m A.Type + -- This is fairly subtle: after resolving a user type, we have to recurse + -- on the resulting type. + doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m + doType t = return t + +-- | Like underlyingType, but only do the "outer layer": if you give this a +-- user type that's an array of user types, then you'll get back an array of +-- user types. +resolveUserType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type +resolveUserType m (A.UserDataType n) + = do st <- specTypeOfName n + case st of + A.DataType _ t -> resolveUserType m t + _ -> dieP m $ "Not a type name: " ++ show n +resolveUserType _ t = return t + -- | Add array dimensions to a type; if it's already an array it'll just add -- the new dimensions to the existing array. addDimensions :: [A.Dimension] -> A.Type -> A.Type diff --git a/pass/Traversal.hs b/pass/Traversal.hs index 06f5040..4aaa855 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -16,11 +16,13 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} --- | Traversal strategies over the AST and other data types. +-- | Traversal strategies over the AST and other data types. This is now mainly +-- a collection of extra Tock-specific utilities that go on top of Polyplate module Traversal ( - TransformM, Transform + TransformM, Transform, TransformStructured , CheckM, Check , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS + , applyBottomUpMS , module Data.Generics.Polyplate , module Data.Generics.Polyplate.Schemes ) where @@ -95,3 +97,13 @@ extOpMS ops (_, f) `extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative)) `extOpM` (f :: A.Structured () -> m (A.Structured ())) +applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) => + (forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) => + (A.Structured a -> PassM (A.Structured a))) + -> t -> PassM t +applyBottomUpMS f = makeRecurseM ops + where + ops = baseOp `extOpMS` (ops, makeBottomUpM ops f) + +type TransformStructured ops + = (PolyplateM (A.Structured t) () ops PassM, Data t) => Transform (A.Structured t) diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index c9c165c..e92e805 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -31,18 +31,18 @@ import Traversal import Types import Utils -simplifyComms :: [Pass] +simplifyComms :: [Pass A.AST] simplifyComms = [ outExprs , transformInputCase , transformProtocolInput ] -outExprs :: Pass +outExprs :: PassOn A.Process outExprs = pass "Define temporary variables for outputting expressions" (Prop.agg_namesDone ++ Prop.agg_typesDone) [Prop.outExpressionRemoved] - (applyDepthM doProcess) + (applyBottomUpM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Output m c ois) @@ -135,11 +135,11 @@ ALT -- process D -} -transformInputCase :: Pass +transformInputCase :: PassOn A.Process transformInputCase = pass "Transform ? CASE statements/guards into plain CASE" (Prop.agg_namesDone ++ Prop.agg_typesDone) [Prop.inputCaseRemoved] - (applyDepthM doProcess) + (applyBottomUpM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputCase m' s)) @@ -182,11 +182,11 @@ transformInputCase = pass "Transform ? CASE statements/guards into plain CASE" -- Leave other guards untouched. doAlternative m a = return $ A.Only m a -transformProtocolInput :: Pass +transformProtocolInput :: PassOn2 A.Process A.Alternative transformProtocolInput = pass "Flatten sequential protocol inputs into multiple inputs" (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved]) [Prop.seqInputsFlattened] - (applyDepthM2 doProcess doAlternative) + (applyBottomUpM2 doProcess doAlternative) where doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_))) diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index a55e6f6..898a82d 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -35,7 +35,7 @@ import Traversal import Types import Utils -simplifyExprs :: [Pass] +simplifyExprs :: [Pass A.AST] simplifyExprs = [ functionsToProcs , removeAfter @@ -51,7 +51,7 @@ builtInOperatorFunction = (`elem` occamBuiltInOperatorFunctions) . A.nameName -- | Convert FUNCTION declarations to PROCs. -functionsToProcs :: Pass +functionsToProcs :: PassOn A.Specification functionsToProcs = pass "Convert FUNCTIONs to PROCs" (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked, Prop.functionTypesChecked]) @@ -106,11 +106,11 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" -- | Convert AFTER expressions to the equivalent using MINUS (which is how the -- occam 3 manual defines AFTER). -removeAfter :: Pass +removeAfter :: PassOn A.Expression removeAfter = pass "Convert AFTER to MINUS" [Prop.expressionTypesChecked] [Prop.afterRemoved] - (applyDepthM2 doExpression doExpressionList) + (applyDepthM doExpression) where doFunctionCall :: (Meta -> A.Name -> [A.Expression] -> a) -> Meta -> A.Name -> [A.Expression] -> PassM a @@ -145,11 +145,11 @@ removeAfter = pass "Convert AFTER to MINUS" -- | For array literals that include other arrays, burst them into their -- elements. -expandArrayLiterals :: Pass +expandArrayLiterals :: PassOn A.ArrayElem expandArrayLiterals = pass "Expand array literals" [Prop.expressionTypesChecked, Prop.processTypesChecked] [Prop.arrayLiteralsExpanded] - (applyDepthM doArrayElem) + (applyBottomUpM doArrayElem) where doArrayElem :: A.Structured A.Expression -> PassM (A.Structured A.Expression) doArrayElem ae@(A.Only _ e) @@ -189,13 +189,14 @@ expandArrayLiterals = pass "Expand array literals" -- Therefore, we only need to pull up the counts for SEQ, PAR and ALT -- -- TODO for simplification, we could avoid pulling up replication counts that are known to be constants --- --- TODO we should also pull up the step counts pullRepCounts :: Pass pullRepCounts = pass "Pull up replicator counts for SEQs, PARs and ALTs" (Prop.agg_namesDone ++ Prop.agg_typesDone) [] - (applyDepthM pullRepCountProc) + (applyDepthM2 + (pullRepCount :: A.Structured A.Process -> PassM (A.Structured A.Process)) + (pullRepCount :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)) + ) where pullRepCountStr :: Data a => Bool -> A.Structured a -> StateT (A.Structured A.Process -> A.Structured A.Process) @@ -221,11 +222,11 @@ pullRepCounts = pass "Pull up replicator counts for SEQs, PARs and ALTs" return $ A.Seq m $ spec $ A.Only m $ A.Par m p body' pullRepCountProc p = return p -transformConstr :: Pass +transformConstr :: PassOnOps (ExtOpMSP BaseOp) transformConstr = pass "Transform array constructors into initialisation code" (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp]) [Prop.arrayConstructorsRemoved] - (applyDepthSM doStructured) + (applyBottomUpMS doStructured) where -- For arrays, this takes a constructor expression: -- VAL type name IS [i = rep | expr]: @@ -329,19 +330,26 @@ transformConstr = pass "Transform array constructors into initialisation code" doStructured s = return s +type PullUpOps = ExtOpMSP BaseOp + `ExtOpMP` A.Process + `ExtOpMP` A.Specification + `ExtOpMP` A.LiteralRepr + `ExtOpMP` A.Expression + `ExtOpMP` A.Variable + `ExtOpMP` A.ExpressionList + -- | Find things that need to be moved up to their enclosing Structured, and do -- so. -pullUp :: Bool -> Pass +pullUp :: Bool -> PassOnOps PullUpOps pullUp pullUpArraysInsideRecords = pass "Pull up definitions" (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.functionsRemoved, Prop.seqInputsFlattened]) [Prop.functionCallsRemoved, Prop.subscriptsPulledUp] recurse where - ops :: Ops + ops :: PullUpOps ops = baseOp `extOpS` doStructured `extOp` doProcess - `extOp` doRepArray `extOp` doSpecification `extOp` doLiteralRepr `extOp` doExpression @@ -354,7 +362,7 @@ pullUp pullUpArraysInsideRecords = pass "Pull up definitions" -- | When we encounter a Structured, create a new pulled items state, -- recurse over it, then apply whatever pulled items we found to it. - doStructured :: Data a => A.Structured a -> PassM (A.Structured a) + doStructured :: TransformStructured PullUpOps doStructured s = do pushPullContext -- Recurse over the body, then apply the pulled items to it diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 5f7466a..9d948b3 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -34,7 +34,7 @@ import Traversal import Types import Utils -simplifyProcs :: [Pass] +simplifyProcs :: [Pass A.AST] simplifyProcs = [ parsToProcs , removeParAssign @@ -42,11 +42,11 @@ simplifyProcs = ] -- | Wrap the subprocesses of PARs in no-arg PROCs. -parsToProcs :: Pass +parsToProcs :: PassOn A.Process parsToProcs = pass "Wrap PAR subprocesses in PROCs" [Prop.parUsageChecked] [Prop.parsWrapped] - (applyDepthM doProcess) + (applyBottomUpM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Par m pm s) @@ -64,11 +64,11 @@ parsToProcs = pass "Wrap PAR subprocesses in PROCs" return $ A.Spec m s (A.Only m (A.ProcCall m n [])) -- | Turn parallel assignment into multiple single assignments through temporaries. -removeParAssign :: Pass +removeParAssign :: PassOn A.Process removeParAssign = pass "Remove parallel assignment" [Prop.parUsageChecked, Prop.functionsRemoved, Prop.functionCallsRemoved] [Prop.assignParRemoved] - (applyDepthM doProcess) + (applyBottomUpM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) @@ -81,14 +81,14 @@ removeParAssign = pass "Remove parallel assignment" doProcess p = return p -- | Turn assignment of arrays and records into multiple assignments. -flattenAssign :: Pass +flattenAssign :: PassOnOps (ExtOpMSP BaseOp `ExtOpMP` A.Process) flattenAssign = pass "Flatten assignment" (Prop.agg_typesDone ++ [Prop.assignParRemoved]) [Prop.assignFlattened] - (makeRecurse ops) + (makeRecurseM ops) where - ops :: Ops - ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess + ops = baseOp `extOpMS` (ops, makeBottomUpM ops doStructured) + `extOpM` makeBottomUpM ops doProcess doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m [v] (A.ExpressionList m' [e])) diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index 9bed173..6e92465 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -37,7 +37,7 @@ import Traversal import Types import Utils -unnest :: [Pass] +unnest :: [Pass A.AST] unnest = [ removeFreeNames , removeNesting @@ -77,22 +77,12 @@ freeNamesIn = doGeneric doSpecType st = doGeneric st -- | Replace names. --- --- This has to have extra cleverness due to a really nasty bug. Array types can --- have expressions as dimensions, and those expressions can contain free names --- which are being replaced. This is fine, but when that happens we need to update --- CompState so that the type has the replaced name, not the old name. -replaceNames :: Data t => [(A.Name, A.Name)] -> t -> PassM t -replaceNames map v = recurse v +replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t +replaceNames map v = runIdentity $ applyDepthM doName v where smap = Map.fromList [(A.nameName f, t) | (f, t) <- map] - ops :: Ops - ops = baseOp `extOp` doName `extOp` doSpecification - recurse :: Data a => Transform a - recurse = makeRecurse ops - - doName :: Transform A.Name + doName :: A.Name -> Identity A.Name doName n = return $ Map.findWithDefault n (A.nameName n) smap doSpecification :: Transform A.Specification @@ -107,11 +97,11 @@ replaceNames map v = recurse v return $ A.Specification m n' sp' -- | Turn free names in PROCs into arguments. -removeFreeNames :: Pass +removeFreeNames :: PassOn2 A.Specification A.Process removeFreeNames = pass "Convert free names to arguments" [Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved] [Prop.freeNamesToArgs] - (applyDepthM2 doSpecification doProcess) + (applyBottomUpM2 doSpecification doProcess) where doSpecification :: A.Specification -> PassM A.Specification doSpecification spec = case spec of @@ -196,25 +186,26 @@ removeFreeNames = pass "Convert free names to arguments" doProcess p = return p -- | Pull nested declarations to the top level. -removeNesting :: Pass +removeNesting :: PassASTOnOps (ExtOpMSP BaseOp) removeNesting = pass "Pull nested definitions to top level" [Prop.freeNamesToArgs] [Prop.nestedPulled] (passOnlyOnAST "removeNesting" $ \s -> do pushPullContext - s' <- recurse s >>= applyPulled + s' <- (makeRecurse ops) s >>= applyPulled popPullContext return s') where - ops :: Ops - ops = baseOp `extOpS` doStructured + ops :: ExtOpMSP BaseOp + ops = baseOp `extOpMS` (ops, doStructured) - recurse :: Recurse - recurse = makeRecurse ops - descend :: Descend - descend = makeDescend ops - doStructured :: Data t => Transform (A.Structured t) + recurse :: RecurseM PassM (ExtOpMSP BaseOp) + recurse = makeRecurseM ops + descend :: DescendM PassM (ExtOpMSP BaseOp) + descend = makeDescendM ops + + doStructured :: TransformStructured (ExtOpMSP BaseOp) doStructured s@(A.Spec m spec subS) = do spec'@(A.Specification _ n st) <- recurse spec isConst <- isConstantName n