From 0adbdda126d902b6272b9c0b1830606e228d62e0 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Mon, 2 Jun 2008 12:51:14 +0000 Subject: [PATCH] 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 | 97 +++++++++++++++-------------- frontends/RainTypes.hs | 23 ++++--- pass/Pass.hs | 25 +++++++- pass/PassList.hs | 3 +- transformations/ImplicitMobility.hs | 9 ++- transformations/Unnest.hs | 8 +-- 6 files changed, 99 insertions(+), 66 deletions(-) diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index bb1712b..1aff273 100644 --- a/frontends/RainPasses.hs +++ b/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 - [ ("AST Validity check, Rain #1", excludeNonRainFeatures, [], []) -- TODO work out some dependencies - ,("Dummy Rain pass", return, [], [Prop.retypesChecked]) - ,("Resolve Int -> Int64", transformInt, [], [Prop.noInt]) - ,("Uniquify variable declarations, record declared types and resolve variable names", - uniquifyAndResolveVars, [Prop.noInt], Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) - ,("Record inferred name types in dictionary", recordInfNameTypes, - Prop.agg_namesDone \\ [Prop.inferredTypesRecorded], [Prop.inferredTypesRecorded]) - - ,("Rain Type Checking", performTypeUnification, [Prop.noInt] ++ Prop.agg_namesDone, - [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, - Prop.retypesChecked]) - ,("Fold all constant expressions", constantFoldPass, [Prop.noInt] ++ Prop.agg_namesDone - ++ [Prop.inferredTypesRecorded], [Prop.constantsFolded, Prop.constantsChecked]) - - ] ++ enablePassesWhen ((== FrontendRain) . csFrontend) simplifyTypes ++ f [ - - ("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 +rainPasses = let f = makePassesDep' ((== FrontendRain) . csFrontend) in + [ excludeNonRainFeatures + , rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return + , transformInt + , uniquifyAndResolveVars + , recordInfNameTypes + , performTypeUnification + , constantFoldPass + ] ++ enablePassesWhen ((== FrontendRain) . csFrontend) simplifyTypes ++ + [ findMain + , transformEachRange + , pullUpForEach + , transformRangeRep + , pullUpParDeclarations + , mobiliseLists + , implicitMobility ] -- | A pass that transforms all instances of 'A.Int' into 'A.Int64' -transformInt :: PassType -transformInt = applyDepthM transformInt' +transformInt :: Pass +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 = applyDepthSM uniquifyAndResolveVars' +uniquifyAndResolveVars :: Pass +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 = applyDepthSM doStructured +transformEachRange :: Pass +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 = applyDepthM doExpression +transformRangeRep :: Pass +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 = applyDepthSM doStructured +pullUpForEach :: Pass +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 = applyDepthM pullUpParDeclarations' +pullUpParDeclarations :: Pass +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 x = (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x +mobiliseLists :: Pass +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 = excludeConstr +excludeNonRainFeatures :: Pass +excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] $ + excludeConstr [ con0 A.Real32 ,con0 A.Real64 ,con2 A.Counted diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 14e252e..3ebbadb 100644 --- a/frontends/RainTypes.hs +++ b/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 x - = do -- First, we copy the known types into the unify map: +performTypeUnification :: Pass +performTypeUnification = rainOnlyPass "Rain Type Checking" + ([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 = checkDepthM recordInfNameTypes' +recordInfNameTypes :: Pass +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 = applyDepthM doExpression +constantFoldPass :: Pass +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 diff --git a/pass/Pass.hs b/pass/Pass.hs index d9d9377..ea6d110 100644 --- a/pass/Pass.hs +++ b/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 diff --git a/pass/PassList.hs b/pass/PassList.hs index 64cc4f3..2ea3234 100644 --- a/pass/PassList.hs +++ b/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 diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs index 5e3ea09..85dd3e4 100644 --- a/transformations/ImplicitMobility.hs +++ b/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 t - = do g' <- buildFlowGraph labelFunctions t +implicitMobility :: Pass +implicitMobility + = 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 diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index 038f347..68854e7 100644 --- a/transformations/Unnest.hs +++ b/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 s - = do pushPullContext +removeNesting :: Data t => Transform t +removeNesting = passOnlyOnAST "removeNesting" $ \s -> + do pushPullContext s' <- (makeRecurse ops) s >>= applyPulled popPullContext - return s' + return $ fromJust $ cast s' where ops :: Ops ops = baseOp `extOpS` doStructured