Fixed many of the modules to use the new Polyplate-based Traversal system

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

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 <http://www.gnu.org/licenses/>.
 -}
 
--- | 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)

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@(_:_:_)))

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

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 = baseOp `extOpMS` (ops, makeBottomUpM ops doStructured)
-    ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess
+                 `extOpM` makeBottomUpM ops doProcess
 
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Assign m [v] (A.ExpressionList m' [e]))

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.
---
+replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
--- This has to have extra cleverness due to a really nasty bug.  Array types can
+replaceNames map v = runIdentity $ applyDepthM doName v
--- 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
   where
     smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
 
-    ops :: Ops
+    doName :: A.Name -> Identity A.Name
-    ops = baseOp `extOp` doName `extOp` doSpecification
-    recurse :: Data a => Transform a
-    recurse = makeRecurse ops
-
-    doName :: Transform 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 :: ExtOpMSP BaseOp
-    ops = baseOp `extOpS` doStructured
+    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