suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed the Rain modules to use the new Pass system/types

Browse Source
This commit is contained in:
Neil Brown 2008-12-14 18:35:39 +00:00
parent d49c7fad4a
commit 1141ecb472
2 changed files with 68 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
frontends/RainPasses.hs
View File

@ -39,7 +39,7 @@ import TreeUtils
import Types import Types
-- | An ordered list of the Rain-specific passes to be run. -- | An ordered list of the Rain-specific passes to be run.
rainPasses :: [Pass] rainPasses :: [Pass A.AST]
rainPasses = rainPasses =
[ excludeNonRainFeatures [ excludeNonRainFeatures
, rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return , rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return
@ -58,8 +58,8 @@ rainPasses =
] ]
-- | A pass that transforms all instances of 'A.Int' into 'A.Int64' -- | A pass that transforms all instances of 'A.Int' into 'A.Int64'
transformInt :: Pass transformInt :: PassOn A.Type
transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyDepthM transformInt') transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyBottomUpM transformInt')
where where
transformInt' :: A.Type -> PassM A.Type transformInt' :: A.Type -> PassM A.Type
transformInt' A.Int = return A.Int64 transformInt' A.Int = return A.Int64
@ -78,11 +78,11 @@ transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyDepthM
-- --
-- This pass works because everywhereM goes bottom-up, so declarations are -- This pass works because everywhereM goes bottom-up, so declarations are
--resolved from the bottom upwards. --resolved from the bottom upwards.
uniquifyAndResolveVars :: Pass uniquifyAndResolveVars :: PassOnStruct
uniquifyAndResolveVars = rainOnlyPass uniquifyAndResolveVars = rainOnlyPass
"Uniquify variable declarations, record declared types and resolve variable names" "Uniquify variable declarations, record declared types and resolve variable names"
[Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) [Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded])
(applyDepthSM uniquifyAndResolveVars') (applyBottomUpMS uniquifyAndResolveVars')
where where
uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a) uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
@ -145,14 +145,14 @@ replaceNameName ::
replaceNameName find replace n = if (A.nameName n) == find then n {A.nameName = replace} else n 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). -- | 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 :: Pass findMain :: PassOn A.Name
--Because findMain runs after uniquifyAndResolveVars, the types of all the process will have been recorded --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" --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 --in the CompState, and pull it out into csMainLocals
findMain = rainOnlyPass "Find and tag the main function" Prop.agg_namesDone [Prop.mainTagged] findMain = rainOnlyPass "Find and tag the main function" Prop.agg_namesDone [Prop.mainTagged]
( \x -> do newMainName <- makeNonce emptyMeta "main_" ( \x -> do newMainName <- makeNonce emptyMeta "main_"
modify (findMain' newMainName) modify (findMain' newMainName)
applyDepthM (return . (replaceNameName "main" newMainName)) x) applyBottomUpM (return . (replaceNameName "main" newMainName)) x)
where where
--We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++) --We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++)
findMain' :: String -> CompState -> CompState findMain' :: String -> CompState -> CompState
@ -180,10 +180,10 @@ checkIntegral (A.ByteLiteral _ s) = Nothing -- TODO support char literals
checkIntegral _ = Nothing checkIntegral _ = Nothing
-- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops -- | Transforms seqeach\/pareach loops over things like [0..99] into SEQ i = 0 FOR 100 loops
transformEachRange :: Pass transformEachRange :: PassOn A.Specification
transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR" transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR"
(Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed] (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed]
(applyDepthM doSpec) (applyBottomUpM doSpec)
where where
doSpec :: A.Specification -> PassM A.Specification doSpec :: A.Specification -> PassM A.Specification
doSpec doSpec
@ -202,6 +202,10 @@ transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges int
A.For eachMeta begin newCount (makeConstant eachMeta 1) A.For eachMeta begin newCount (makeConstant eachMeta 1)
doSpec s = return s doSpec s = return s
-- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions
--
-- TODO make sure when the range has a bad order that an empty list is
-- returned
transformRangeRep :: Pass transformRangeRep :: Pass
transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors" transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors"
(Prop.agg_typesDone ++ [Prop.eachRangeTransformed]) (Prop.agg_typesDone ++ [Prop.eachRangeTransformed])
@ -209,18 +213,17 @@ transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into mo
(applyDepthM doExpression) (applyDepthM doExpression)
where where
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression (A.Literal m t (A.RangeLiteral m' begin end)) doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
= do count <- subExprs end begin >>= addOne = do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev
let rep = A.Rep m' $ A.For m' begin count $ makeConstant m 1 let count = addOne $ subExprs end begin
spec@(A.Specification _ repN _) <- defineNonce m' "rep_constr" return $ A.ExprConstr m $ A.RepConstr m t rep
rep A.ValAbbrev (A.For m begin count $ makeConstant m 1)
return $ A.Literal m t $ A.ArrayListLiteral m' $ (A.ExprVariable m $ A.Variable m rep)
A.Spec m' spec $ A.Only m' $
(A.ExprVariable m' $ A.Variable m' repN)
doExpression e = return e doExpression e = return e
-- TODO this is almost certainly better figured out from the CFG -- TODO this is almost certainly better figured out from the CFG
checkFunction :: PassType {-
checkFunction :: Pass t
checkFunction = return -- applyDepthM checkFunction' checkFunction = return -- applyDepthM checkFunction'
where where
checkFunction' :: A.Specification -> PassM A.Specification checkFunction' :: A.Specification -> PassM A.Specification
@ -241,16 +244,17 @@ checkFunction = return -- applyDepthM checkFunction'
skipSpecs :: A.Structured A.Process -> A.Structured A.Process skipSpecs :: A.Structured A.Process -> A.Structured A.Process
skipSpecs (A.Spec _ _ inner) = skipSpecs inner skipSpecs (A.Spec _ _ inner) = skipSpecs inner
skipSpecs s = s skipSpecs s = s
-}
-- | Pulls up the list expression into a variable. -- | Pulls up the list expression into a variable.
-- This is done no matter how simple the expression is; when we reach the -- This is done no matter how simple the expression is; when we reach the
-- backend we need it to be a variable so we can use begin() and end() (in -- 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 -- C++); these will only be valid if exactly the same list is used
-- throughout the loop. -- throughout the loop.
pullUpForEach :: Pass pullUpForEach :: PassOnStruct
pullUpForEach = rainOnlyPass "Pull up foreach-expressions" pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
(Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed] (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed]
(applyDepthSM doStructured) (applyBottomUpMS doStructured)
where where
doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
doStructured (A.Spec mstr (A.Specification mspec loopVar (A.Rep m (A.ForEach m' loopExp))) s) doStructured (A.Spec mstr (A.Specification mspec loopVar (A.Rep m (A.ForEach m' loopExp))) s)
@ -265,10 +269,10 @@ pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
doStructured s = return s doStructured s = return s
pullUpParDeclarations :: Pass pullUpParDeclarations :: PassOn A.Process
pullUpParDeclarations = rainOnlyPass "Pull up par declarations" pullUpParDeclarations = rainOnlyPass "Pull up par declarations"
[] [Prop.rainParDeclarationsPulledUp] [] [Prop.rainParDeclarationsPulledUp]
(applyDepthM pullUpParDeclarations') (applyBottomUpM pullUpParDeclarations')
where where
pullUpParDeclarations' :: A.Process -> PassM A.Process pullUpParDeclarations' :: A.Process -> PassM A.Process
pullUpParDeclarations' p@(A.Par m mode inside) pullUpParDeclarations' p@(A.Par m mode inside)
@ -284,16 +288,16 @@ pullUpParDeclarations = rainOnlyPass "Pull up par declarations"
Just (trans,inner') -> Just ( (A.Spec m spec) . trans,inner') Just (trans,inner') -> Just ( (A.Spec m spec) . trans,inner')
chaseSpecs _ = Nothing chaseSpecs _ = Nothing
mobiliseLists :: Pass mobiliseLists :: PassOn A.Type
mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties
(\x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x) (\x -> (get >>= applyBottomUpM mobilise >>= put) >> applyBottomUpM mobilise x)
where where
mobilise :: A.Type -> PassM A.Type mobilise :: A.Type -> PassM A.Type
mobilise t@(A.List _) = return $ A.Mobile t mobilise t@(A.List _) = return $ A.Mobile t
mobilise t = return 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). -- | All the items that should not occur in an AST that comes from Rain (up until it goes into the shared passes).
excludeNonRainFeatures :: Pass excludeNonRainFeatures :: Pass A.AST
excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] []
(excludeConstr (excludeConstr
[ con0 A.Real32 [ con0 A.Real32

61
frontends/RainTypes.hs
View File

@ -59,7 +59,15 @@ startState = RainTypeState {
type RainTypeM = StateT RainTypeState PassM type RainTypeM = StateT RainTypeState PassM
type RainTypePassType = Data t => t -> StateT RainTypeState PassM t type RainTypePassType = forall t. t -> StateT RainTypeState PassM t
type RainTypeCheckOn a = forall t. PolyplateSpine t (OneOpQ (RainTypeM ()) a) ()
(RainTypeM ()) => t -> RainTypeM ()
type RainTypeCheckOn2 a b = forall t.
(PolyplateSpine t (TwoOpQ (RainTypeM ()) a b) () (RainTypeM ())
) => t -> RainTypeM ()
type RainTypeCheck a = a -> RainTypeM () type RainTypeCheck a = a -> RainTypeM ()
@ -118,7 +126,17 @@ markUnify x y
modify $ \st -> st {csUnifyPairs = (tex,tey) : csUnifyPairs st} modify $ \st -> st {csUnifyPairs = (tex,tey) : csUnifyPairs st}
performTypeUnification :: Pass performTypeUnification ::
-- | A shorthand for prerequisites when you need to spell them out:
(PolyplateSpine t (OneOpQ (RainTypeM ()) A.Specification) () (RainTypeM ())
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Process) () (RainTypeM ())
,PolyplateSpine t (OneOpQ (RainTypeM ()) A.Expression) () (RainTypeM ())
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Expression) () (RainTypeM ())
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Choice) () (RainTypeM ())
,PolyplateSpine t (TwoOpQ (RainTypeM ()) A.Process A.Alternative) () (RainTypeM ())
,PolyplateM t () (OneOpM PassM A.Type) PassM
,PolyplateM t (OneOpM PassM A.Type) () PassM
) => Pass t
performTypeUnification = rainOnlyPass "Rain Type Checking" performTypeUnification = rainOnlyPass "Rain Type Checking"
([Prop.noInt] ++ Prop.agg_namesDone) ([Prop.noInt] ++ Prop.agg_namesDone)
[Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked] [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked]
@ -127,14 +145,13 @@ performTypeUnification = rainOnlyPass "Rain Type Checking"
ul <- getCompState >>= (shift . csNames) ul <- getCompState >>= (shift . csNames)
put st {csUnifyPairs = [], csUnifyLookup = ul} put st {csUnifyPairs = [], csUnifyLookup = ul}
-- Then we markup all the types in the tree: -- Then we markup all the types in the tree:
x' <- (markConditionalTypes markConditionalTypes x
<.< markParamPass markParamPass x
<.< markAssignmentTypes markAssignmentTypes x
<.< markCommTypes markCommTypes x
<.< markPoisonTypes markPoisonTypes x
<.< markReplicators markReplicators x
<.< markExpressionTypes markExpressionTypes x
) x
-- Then, we do the unification: -- Then, we do the unification:
prs <- get >>* csUnifyPairs prs <- get >>* csUnifyPairs
mapM_ (lift . uncurry unifyType) prs mapM_ (lift . uncurry unifyType) prs
@ -142,7 +159,7 @@ performTypeUnification = rainOnlyPass "Rain Type Checking"
l <- get >>* csUnifyLookup l <- get >>* csUnifyLookup
ts <- lift $ mapMapM (\v -> fromTypeExp v) l ts <- lift $ mapMapM (\v -> fromTypeExp v) l
lift $ get >>= substituteUnknownTypes ts >>= put lift $ get >>= substituteUnknownTypes ts >>= put
lift $ substituteUnknownTypes ts x') lift $ substituteUnknownTypes ts x)
where where
shift :: Map.Map String A.NameDef -> RainTypeM (Map.Map UnifyIndex UnifyValue) shift :: Map.Map String A.NameDef -> RainTypeM (Map.Map UnifyIndex UnifyValue)
shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList
@ -156,8 +173,8 @@ performTypeUnification = rainOnlyPass "Rain Type Checking"
where where
name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d} name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d}
substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassTypeOn A.Type
substituteUnknownTypes mt = applyDepthM sub substituteUnknownTypes mt = applyBottomUpM sub
where where
sub :: A.Type -> PassM A.Type sub :: A.Type -> PassM A.Type
sub (A.UnknownVarType _ (Left n)) = lookup $ UnifyIndex (A.nameMeta n, Right n) sub (A.UnknownVarType _ (Left n)) = lookup $ UnifyIndex (A.nameMeta n, Right n)
@ -170,7 +187,7 @@ substituteUnknownTypes mt = applyDepthM sub
Just t -> return t Just t -> return t
Nothing -> dieP m "Could not deduce type" Nothing -> dieP m "Could not deduce type"
markReplicators :: RainTypePassType markReplicators :: RainTypeCheckOn A.Specification
markReplicators = checkDepthM mark markReplicators = checkDepthM mark
where where
mark :: RainTypeCheck A.Specification mark :: RainTypeCheck A.Specification
@ -179,11 +196,11 @@ markReplicators = checkDepthM mark
mark _ = return () mark _ = return ()
-- | Folds all constants. -- | Folds all constants.
constantFoldPass :: Pass constantFoldPass :: PassOn A.Expression
constantFoldPass = rainOnlyPass "Fold all constant expressions" constantFoldPass = rainOnlyPass "Fold all constant expressions"
([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded]) ([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded])
[Prop.constantsFolded, Prop.constantsChecked] [Prop.constantsFolded, Prop.constantsChecked]
(applyDepthM doExpression) (applyBottomUpM doExpression)
where where
doExpression :: A.Expression -> PassM A.Expression doExpression :: A.Expression -> PassM A.Expression
doExpression = (liftM (\(x,_,_) -> x)) . constantFold doExpression = (liftM (\(x,_,_) -> x)) . constantFold
@ -191,7 +208,7 @@ constantFoldPass = rainOnlyPass "Fold all constant expressions"
-- | A pass that finds all the 'A.ProcCall' and 'A.FunctionCall' in the -- | A pass that finds all the 'A.ProcCall' and 'A.FunctionCall' in the
-- AST, and checks that the actual parameters are valid inputs, given -- AST, and checks that the actual parameters are valid inputs, given
-- the 'A.Formal' parameters in the process's type -- the 'A.Formal' parameters in the process's type
markParamPass :: RainTypePassType markParamPass :: RainTypeCheckOn2 A.Process A.Expression
markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
where where
--Picks out the parameters of a process call, checks the number is correct, and maps doParam over them --Picks out the parameters of a process call, checks the number is correct, and maps doParam over them
@ -222,7 +239,7 @@ markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
matchParamPassFunc _ = return () matchParamPassFunc _ = return ()
-- | Checks the types in expressions -- | Checks the types in expressions
markExpressionTypes :: RainTypePassType markExpressionTypes :: RainTypeCheckOn A.Expression
markExpressionTypes = checkDepthM checkExpression markExpressionTypes = checkDepthM checkExpression
where where
-- TODO also check in a later pass that the op is valid -- TODO also check in a later pass that the op is valid
@ -240,7 +257,7 @@ markExpressionTypes = checkDepthM checkExpression
checkListElems ch (A.ProcThen _ _ s) = checkListElems ch s checkListElems ch (A.ProcThen _ _ s) = checkListElems ch s
-- | Checks the types in assignments -- | Checks the types in assignments
markAssignmentTypes :: RainTypePassType markAssignmentTypes :: RainTypeCheckOn A.Process
markAssignmentTypes = checkDepthM checkAssignment markAssignmentTypes = checkDepthM checkAssignment
where where
checkAssignment :: RainTypeCheck A.Process checkAssignment :: RainTypeCheck A.Process
@ -261,7 +278,7 @@ markAssignmentTypes = checkDepthM checkAssignment
checkAssignment st = return () checkAssignment st = return ()
-- | Checks the types in if and while conditionals -- | Checks the types in if and while conditionals
markConditionalTypes :: RainTypePassType markConditionalTypes :: RainTypeCheckOn2 A.Process A.Choice
markConditionalTypes = checkDepthM2 checkWhile checkIf markConditionalTypes = checkDepthM2 checkWhile checkIf
where where
checkWhile :: RainTypeCheck A.Process checkWhile :: RainTypeCheck A.Process
@ -274,7 +291,7 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf
= markUnify exp (M m A.Bool) = markUnify exp (M m A.Bool)
-- | Marks types in poison statements -- | Marks types in poison statements
markPoisonTypes :: RainTypePassType markPoisonTypes :: RainTypeCheckOn A.Process
markPoisonTypes = checkDepthM checkPoison markPoisonTypes = checkDepthM checkPoison
where where
checkPoison :: RainTypeCheck A.Process checkPoison :: RainTypeCheck A.Process
@ -284,7 +301,7 @@ markPoisonTypes = checkDepthM checkPoison
checkPoison _ = return () checkPoison _ = return ()
-- | Checks the types in inputs and outputs, including inputs in alts -- | Checks the types in inputs and outputs, including inputs in alts
markCommTypes :: RainTypePassType markCommTypes :: RainTypeCheckOn2 A.Process A.Alternative
markCommTypes = checkDepthM2 checkInputOutput checkAltInput markCommTypes = checkDepthM2 checkInputOutput checkAltInput
where where
checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM () checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM ()