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.
This commit is contained in:
Neil Brown
parent
3e56aa0671
commit
0adbdda126
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
25
pass/Pass.hs
25
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user