Moved all the pass information about the Rain passes into their definition (rather than the pass list at the top)

As part of this patch, I have also introduced a helper function that fiddles the type system for those passes that must run at the top-level (i.e. on A.AST) rather than on any Data t.  They will give an error if not applied at the top-level.

frontends/RainPasses.hs

@@ -40,41 +40,27 @@ import Types
 
 -- | An ordered list of the Rain-specific passes to be run.
 rainPasses :: [Pass]
-rainPasses = let f = makePassesDep' ((== FrontendRain) . csFrontend) in f
+rainPasses = let f = makePassesDep' ((== FrontendRain) . csFrontend) in
-     [ ("AST Validity check, Rain #1", excludeNonRainFeatures, [], []) -- TODO work out some dependencies
+     [ excludeNonRainFeatures
-       ,("Dummy Rain pass", return, [], [Prop.retypesChecked])
+     , rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return
-       ,("Resolve Int -> Int64", transformInt, [], [Prop.noInt])
+     , transformInt
-       ,("Uniquify variable declarations, record declared types and resolve variable names",
+     , uniquifyAndResolveVars
-           uniquifyAndResolveVars, [Prop.noInt], Prop.agg_namesDone \\ [Prop.inferredTypesRecorded])
+     , recordInfNameTypes
-       ,("Record inferred name types in dictionary", recordInfNameTypes,
+     , performTypeUnification
-           Prop.agg_namesDone \\ [Prop.inferredTypesRecorded], [Prop.inferredTypesRecorded])
+     , constantFoldPass
-            
+     ] ++ enablePassesWhen ((== FrontendRain) . csFrontend) simplifyTypes ++
-       ,("Rain Type Checking", performTypeUnification, [Prop.noInt] ++ Prop.agg_namesDone,
+     [ findMain
-         [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked,
+     , transformEachRange
-          Prop.retypesChecked])
+     , pullUpForEach
-       ,("Fold all constant expressions", constantFoldPass, [Prop.noInt] ++ Prop.agg_namesDone
+     , transformRangeRep
-            ++ [Prop.inferredTypesRecorded], [Prop.constantsFolded, Prop.constantsChecked])
+     , pullUpParDeclarations
-
+     , mobiliseLists
-     ] ++ enablePassesWhen ((== FrontendRain) . csFrontend) simplifyTypes ++ f [
+     , implicitMobility
-       
-        ("Find and tag the main function", findMain, Prop.agg_namesDone, [Prop.mainTagged])
-       ,("Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR",
-         transformEachRange, Prop.agg_typesDone ++ [Prop.constantsFolded], [Prop.eachRangeTransformed])
-       ,("Pull up foreach-expressions", pullUpForEach,
-         Prop.agg_typesDone ++ [Prop.constantsFolded],
-         [Prop.eachTransformed])
-       ,("Convert simple Rain range constructors into more general array constructors",transformRangeRep, Prop.agg_typesDone ++ [Prop.eachRangeTransformed], [Prop.rangeTransformed])
-       ,("Transform Rain functions into the occam form",checkFunction, Prop.agg_typesDone, [])
-         --TODO add an export property.  Maybe check other things too (lack of comms etc -- but that could be combined with occam?)
-       ,("Pull up par declarations", pullUpParDeclarations, [], [Prop.rainParDeclarationsPulledUp])
-
-       ,("Mobilise lists", mobiliseLists, [], []) --TODO properties
-       ,("Implicit mobility pass", implicitMobility, [], []) --TODO properties
      ]
 
 -- | A pass that transforms all instances of 'A.Int' into 'A.Int64'
-transformInt :: PassType
+transformInt :: Pass
-transformInt = applyDepthM transformInt'
+transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] $ applyDepthM transformInt'
   where
     transformInt' :: A.Type -> PassM A.Type
     transformInt' A.Int = return A.Int64
@@ -93,8 +79,11 @@ transformInt = applyDepthM transformInt'
 --
 -- This pass works because everywhereM goes bottom-up, so declarations are
 --resolved from the bottom upwards.
-uniquifyAndResolveVars :: PassType
+uniquifyAndResolveVars :: Pass
-uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars'
+uniquifyAndResolveVars = rainOnlyPass
+  "Uniquify variable declarations, record declared types and resolve variable names"
+  [Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded])
+  $ applyDepthSM uniquifyAndResolveVars'
   where
     uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
     
@@ -162,11 +151,12 @@ replaceNameName ::
 replaceNameName find replace n = if (A.nameName n) == find then n {A.nameName = replace} else n
 
 -- | A pass that finds and tags the main process, and also mangles its name (to avoid problems in the C\/C++ backends with having a function called main).
-findMain :: PassType
+findMain :: Pass
 --Because findMain runs after uniquifyAndResolveVars, the types of all the process will have been recorded
 --Therefore this pass doesn't actually need to walk the tree, it just has to look for a process named "main"
 --in the CompState, and pull it out into csMainLocals
-findMain x = do newMainName <- makeNonce "main_"
+findMain = rainOnlyPass "Find and tag the main function" Prop.agg_namesDone [Prop.mainTagged]
+  $    \x -> do newMainName <- makeNonce "main_"
                 modify (findMain' newMainName)
                 applyDepthM (return . (replaceNameName "main" newMainName)) x
   where
@@ -196,8 +186,10 @@ checkIntegral (A.ByteLiteral _ s) = Nothing -- TODO support char literals
 checkIntegral _ = Nothing
 
 -- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops
-transformEachRange :: PassType
+transformEachRange :: Pass
-transformEachRange = applyDepthSM doStructured
+transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR"
+  (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed]
+  $ applyDepthSM doStructured
   where
     doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
     doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr
@@ -212,8 +204,11 @@ transformEachRange = applyDepthSM doStructured
 --
 -- TODO make sure when the range has a bad order that an empty list is
 -- returned
-transformRangeRep :: PassType
+transformRangeRep :: Pass
-transformRangeRep = applyDepthM doExpression
+transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors"
+  (Prop.agg_typesDone ++ [Prop.eachRangeTransformed])
+  [Prop.rangeTransformed]
+  $ applyDepthM doExpression
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
@@ -252,8 +247,10 @@ checkFunction = return -- applyDepthM checkFunction'
 -- backend we need it to be a variable so we can use begin() and end() (in
 -- C++); these will only be valid if exactly the same list is used
 -- throughout the loop.
-pullUpForEach :: PassType
+pullUpForEach :: Pass
-pullUpForEach = applyDepthSM doStructured
+pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
+  (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed]
+  $ applyDepthSM doStructured
   where
     doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
     doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
@@ -267,8 +264,10 @@ pullUpForEach = applyDepthSM doStructured
     doStructured s = return s
       
     
-pullUpParDeclarations :: PassType
+pullUpParDeclarations :: Pass
-pullUpParDeclarations = applyDepthM pullUpParDeclarations'
+pullUpParDeclarations = rainOnlyPass "Pull up par declarations"
+  [] [Prop.rainParDeclarationsPulledUp]
+  $ applyDepthM pullUpParDeclarations'
   where
     pullUpParDeclarations' :: A.Process -> PassM A.Process
     pullUpParDeclarations' p@(A.Par m mode inside) 
@@ -284,16 +283,18 @@ pullUpParDeclarations = applyDepthM pullUpParDeclarations'
           Just (trans,inner') -> Just ( (A.Spec m spec) . trans,inner')
     chaseSpecs _ = Nothing
 
-mobiliseLists :: PassType
+mobiliseLists :: Pass
-mobiliseLists x = (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x
+mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties
+  $ \x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x
   where
     mobilise :: A.Type -> PassM A.Type
     mobilise t@(A.List _) = return $ A.Mobile t
     mobilise t = return t
 
 -- | All the items that should not occur in an AST that comes from Rain (up until it goes into the shared passes).
-excludeNonRainFeatures :: (Data t, CSMR m) => t -> m t
+excludeNonRainFeatures :: Pass
-excludeNonRainFeatures = excludeConstr
+excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] $
+  excludeConstr
   [ con0 A.Real32
    ,con0 A.Real64
    ,con2 A.Counted

frontends/RainTypes.hs

@@ -20,6 +20,7 @@ module RainTypes (constantFoldPass,performTypeUnification,recordInfNameTypes) wh
 
 import Control.Monad.State
 import Data.Generics
+import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
 import Data.IORef
@@ -30,6 +31,7 @@ import Errors
 import EvalConstants
 import Metadata
 import Pass
+import qualified Properties as Prop
 import ShowCode
 import Traversal
 import Types
@@ -86,9 +88,11 @@ markUnify x y
        modify $ \st -> st {csUnifyPairs = (tex,tey) : csUnifyPairs st}
 
 
-performTypeUnification :: PassType
+performTypeUnification :: Pass
-performTypeUnification x
+performTypeUnification = rainOnlyPass "Rain Type Checking"
-  = do -- First, we copy the known types into the unify map:
+  ([Prop.noInt] ++ Prop.agg_namesDone)
+  [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked]
+  $ \x -> do -- First, we copy the known types into the unify map:
        st <- get
        ul <- shift $ csNames st
        put st {csUnifyPairs = [], csUnifyLookup = ul}
@@ -136,8 +140,10 @@ substituteUnknownTypes mt = applyDepthM sub
       Nothing -> dieP m "Could not deduce type"
 
 -- | A pass that records inferred types.  Currently the only place where types are inferred is in seqeach\/pareach loops.
-recordInfNameTypes :: PassType
+recordInfNameTypes :: Pass
-recordInfNameTypes = checkDepthM recordInfNameTypes'
+recordInfNameTypes = rainOnlyPass "Record inferred name types in dictionary"
+  (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) [Prop.inferredTypesRecorded]
+  $ checkDepthM recordInfNameTypes'
   where
     recordInfNameTypes' :: Check A.Replicator
     recordInfNameTypes' input@(A.ForEach m n e)
@@ -159,8 +165,11 @@ markReplicators = checkDepthM mark
       = astTypeOf n >>= \t -> markUnify (A.List t) e
 
 -- | Folds all constants.
-constantFoldPass :: PassType
+constantFoldPass :: Pass
-constantFoldPass = applyDepthM doExpression
+constantFoldPass = rainOnlyPass "Fold all constant expressions"
+  ([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded])
+  [Prop.constantsFolded, Prop.constantsChecked]
+  $ applyDepthM doExpression
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression = (liftM (\(x,_,_) -> x)) . constantFold

pass/Pass.hs

@@ -60,7 +60,7 @@ type PassType = (forall s. Data s => s -> PassM s)
 
 -- | A description of an AST-mangling pass.
 data Monad m => Pass_ m = Pass {
-  passCode :: A.AST -> m A.AST
+  passCode :: forall t. Data t => t -> m t
  ,passName :: String 
  ,passPre :: Set.Set Property
  ,passPost :: Set.Set Property
@@ -105,16 +105,35 @@ runPassM cs pass = liftM flatten $ flip runStateT [] $ flip runStateT cs $ runEr
     flatten :: ((a, b),c) -> (a, b, c)
     flatten ((x, y), z) = (x, y, z)
 
-makePassesDep :: [(String, A.AST -> PassM A.AST, [Property], [Property])] -> [Pass]
+
+makePassesDep :: [(String, forall t. Data t => t -> PassM t, [Property], [Property])] -> [Pass]
 makePassesDep = map (\(s, p, pre, post) -> Pass p s (Set.fromList pre) (Set.fromList post) (const True))
 
-makePassesDep' :: (CompState -> Bool) -> [(String, A.AST -> PassM A.AST, [Property], [Property])] -> [Pass]
+makePassesDep' :: (CompState -> Bool) -> [(String, forall t. Data t => t -> PassM t, [Property], [Property])] -> [Pass]
 makePassesDep' f = map (\(s, p, pre, post) -> Pass p s (Set.fromList pre) (Set.fromList post) f)
 
 enablePassesWhen :: (CompState -> Bool) -> [Pass] -> [Pass]
 enablePassesWhen f = map (\p -> p
   {passEnabled = \c -> f c && (passEnabled p c)})
 
+-- | A helper to run a pass at the top-level, or deliver an error otherwise
+passOnlyOnAST :: forall t. Data t => String -> (A.AST -> PassM A.AST) -> t -> PassM t
+passOnlyOnAST name func x
+  = case cast x :: Maybe A.AST of
+      Nothing -> dieP emptyMeta $ name ++ " only operates at top-level"
+      Just x' -> func x' >>= \y -> case cast y :: Maybe t of
+        Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level"
+        Just y' -> return y'
+
+rainOnlyPass :: String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass
+rainOnlyPass name pre post code
+  = Pass {passCode = code
+         ,passName = name
+         ,passPre = Set.fromList pre
+         ,passPost = Set.fromList post
+         ,passEnabled = (== FrontendRain) . csFrontend
+         }
+
 -- | Compose a list of passes into a single pass by running them in the order given.
 runPasses :: [Pass] -> (A.AST -> PassM A.AST)
 runPasses [] ast = return ast

pass/PassList.hs

@@ -49,7 +49,8 @@ commonPasses :: CompState -> [Pass]
 commonPasses opts = concat $
   -- Rain does simplifyTypes separately:
   [ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes
-  , makePassesDep' csUsageChecking [("Usage checking", runPassR usageCheckPass, Prop.agg_namesDone, [Prop.parUsageChecked])]
+  , makePassesDep' csUsageChecking [("Usage checking", passOnlyOnAST "usageCheckPass"
+    $ runPassR usageCheckPass, Prop.agg_namesDone, [Prop.parUsageChecked])]
   -- If usage checking is turned off, the pass list will break unless we insert this dummy item:
   , makePassesDep' (not . csUsageChecking) [("Usage checking turned OFF", return, Prop.agg_namesDone, [Prop.parUsageChecked])]
   , simplifyComms

transformations/ImplicitMobility.hs

@@ -155,9 +155,12 @@ effectMoveCopyDecisions g decs = foldFuncsM $ map effect $ Map.toList decs
           Nothing -> const $ dieP (findMeta v) "Could not find label for node"
           Just mod -> effectDecision v dec mod
 
-implicitMobility :: A.AST -> PassM A.AST
+implicitMobility :: Pass
-implicitMobility t
+implicitMobility 
-  = do g' <- buildFlowGraph labelFunctions t
+  = rainOnlyPass "Implicit mobility optimisation"
+    [] [] --TODO properties
+   $ passOnlyOnAST "implicitMobility" $ \t -> do
+       g' <- buildFlowGraph labelFunctions t
               :: PassM (Either String (FlowGraph' PassM UsageLabel (), [Node],
                 [Node]))
        case g' of

transformations/Unnest.hs

@@ -181,12 +181,12 @@ removeFreeNames = applyDepthM2 doSpecification doProcess
     doProcess p = return p
 
 -- | Pull nested declarations to the top level.
-removeNesting :: Data t => Transform (A.Structured t)
+removeNesting :: Data t => Transform t
-removeNesting s
+removeNesting = passOnlyOnAST "removeNesting" $ \s ->
-    =  do pushPullContext
+       do pushPullContext
           s' <- (makeRecurse ops) s >>= applyPulled
           popPullContext
-          return s'
+          return $ fromJust $ cast s'
   where
     ops :: Ops
     ops = baseOp `extOpS` doStructured