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

2008-12-02 18:06:10 +00:00 · 2008-12-02 18:06:10 +00:00 · 890e7ea9a6
commit 890e7ea9a6
parent a3bcb32937
6 changed files with 91 additions and 58 deletions
--- 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
--- 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 <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)
--- 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@(_:_:_)))
--- 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
--- 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]))
--- 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