From 1141ecb4726638bd91eec566f7f5ef9d5a05ef9f Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 14 Dec 2008 18:35:39 +0000 Subject: [PATCH] Fixed the Rain modules to use the new Pass system/types --- frontends/RainPasses.hs | 54 +++++++++++++++++++----------------- frontends/RainTypes.hs | 61 ++++++++++++++++++++++++++--------------- 2 files changed, 68 insertions(+), 47 deletions(-) diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 0e58b87..d943a26 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -39,7 +39,7 @@ import TreeUtils import Types -- | An ordered list of the Rain-specific passes to be run. -rainPasses :: [Pass] +rainPasses :: [Pass A.AST] rainPasses = [ excludeNonRainFeatures , rainOnlyPass "Dummy Rain pass" [] [Prop.retypesChecked] return @@ -58,8 +58,8 @@ rainPasses = ] -- | A pass that transforms all instances of 'A.Int' into 'A.Int64' -transformInt :: Pass -transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyDepthM transformInt') +transformInt :: PassOn A.Type +transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyBottomUpM transformInt') where transformInt' :: A.Type -> PassM A.Type 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 --resolved from the bottom upwards. -uniquifyAndResolveVars :: Pass +uniquifyAndResolveVars :: PassOnStruct uniquifyAndResolveVars = rainOnlyPass "Uniquify variable declarations, record declared types and resolve variable names" [Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) - (applyDepthSM uniquifyAndResolveVars') + (applyBottomUpMS uniquifyAndResolveVars') where 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 -- | 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 --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 = rainOnlyPass "Find and tag the main function" Prop.agg_namesDone [Prop.mainTagged] ( \x -> do newMainName <- makeNonce emptyMeta "main_" modify (findMain' newMainName) - applyDepthM (return . (replaceNameName "main" newMainName)) x) + applyBottomUpM (return . (replaceNameName "main" newMainName)) x) where --We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++) findMain' :: String -> CompState -> CompState @@ -180,10 +180,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 :: Pass +transformEachRange :: PassOn A.Specification transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR" (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed] - (applyDepthM doSpec) + (applyBottomUpM doSpec) where doSpec :: A.Specification -> PassM A.Specification doSpec @@ -202,6 +202,10 @@ transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges int A.For eachMeta begin newCount (makeConstant eachMeta 1) 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 = rainOnlyPass "Convert simple Rain range constructors into more general array constructors" (Prop.agg_typesDone ++ [Prop.eachRangeTransformed]) @@ -209,18 +213,17 @@ transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into mo (applyDepthM doExpression) where doExpression :: A.Expression -> PassM A.Expression - doExpression (A.Literal m t (A.RangeLiteral m' begin end)) - = do count <- subExprs end begin >>= addOne - let rep = A.Rep m' $ A.For m' begin count $ makeConstant m 1 - spec@(A.Specification _ repN _) <- defineNonce m' "rep_constr" - rep A.ValAbbrev - return $ A.Literal m t $ A.ArrayListLiteral m' $ - A.Spec m' spec $ A.Only m' $ - (A.ExprVariable m' $ A.Variable m' repN) + doExpression (A.ExprConstr _ (A.RangeConstr m t begin end)) + = do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev + let count = addOne $ subExprs end begin + return $ A.ExprConstr m $ A.RepConstr m t rep + (A.For m begin count $ makeConstant m 1) + (A.ExprVariable m $ A.Variable m rep) doExpression e = return e -- TODO this is almost certainly better figured out from the CFG -checkFunction :: PassType +{- +checkFunction :: Pass t checkFunction = return -- applyDepthM checkFunction' where 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.Spec _ _ inner) = skipSpecs inner skipSpecs s = s +-} -- | Pulls up the list expression into a variable. -- 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 -- C++); these will only be valid if exactly the same list is used -- throughout the loop. -pullUpForEach :: Pass +pullUpForEach :: PassOnStruct pullUpForEach = rainOnlyPass "Pull up foreach-expressions" (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed] - (applyDepthSM doStructured) + (applyBottomUpMS doStructured) where 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) @@ -265,10 +269,10 @@ pullUpForEach = rainOnlyPass "Pull up foreach-expressions" doStructured s = return s -pullUpParDeclarations :: Pass +pullUpParDeclarations :: PassOn A.Process pullUpParDeclarations = rainOnlyPass "Pull up par declarations" [] [Prop.rainParDeclarationsPulledUp] - (applyDepthM pullUpParDeclarations') + (applyBottomUpM pullUpParDeclarations') where pullUpParDeclarations' :: A.Process -> PassM A.Process 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') chaseSpecs _ = Nothing -mobiliseLists :: Pass +mobiliseLists :: PassOn A.Type mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties - (\x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x) + (\x -> (get >>= applyBottomUpM mobilise >>= put) >> applyBottomUpM 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 :: Pass +excludeNonRainFeatures :: Pass A.AST excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] (excludeConstr [ con0 A.Real32 diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index c795ff9..5ba2673 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -59,7 +59,15 @@ startState = RainTypeState { 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 () @@ -118,7 +126,17 @@ markUnify x y 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" ([Prop.noInt] ++ Prop.agg_namesDone) [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked] @@ -127,14 +145,13 @@ performTypeUnification = rainOnlyPass "Rain Type Checking" ul <- getCompState >>= (shift . csNames) put st {csUnifyPairs = [], csUnifyLookup = ul} -- Then we markup all the types in the tree: - x' <- (markConditionalTypes - <.< markParamPass - <.< markAssignmentTypes - <.< markCommTypes - <.< markPoisonTypes - <.< markReplicators - <.< markExpressionTypes - ) x + markConditionalTypes x + markParamPass x + markAssignmentTypes x + markCommTypes x + markPoisonTypes x + markReplicators x + markExpressionTypes x -- Then, we do the unification: prs <- get >>* csUnifyPairs mapM_ (lift . uncurry unifyType) prs @@ -142,7 +159,7 @@ performTypeUnification = rainOnlyPass "Rain Type Checking" l <- get >>* csUnifyLookup ts <- lift $ mapMapM (\v -> fromTypeExp v) l lift $ get >>= substituteUnknownTypes ts >>= put - lift $ substituteUnknownTypes ts x') + lift $ substituteUnknownTypes ts x) where shift :: Map.Map String A.NameDef -> RainTypeM (Map.Map UnifyIndex UnifyValue) shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList @@ -156,8 +173,8 @@ performTypeUnification = rainOnlyPass "Rain Type Checking" where name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d} -substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType -substituteUnknownTypes mt = applyDepthM sub +substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassTypeOn A.Type +substituteUnknownTypes mt = applyBottomUpM sub where sub :: A.Type -> PassM A.Type sub (A.UnknownVarType _ (Left n)) = lookup $ UnifyIndex (A.nameMeta n, Right n) @@ -170,7 +187,7 @@ substituteUnknownTypes mt = applyDepthM sub Just t -> return t Nothing -> dieP m "Could not deduce type" -markReplicators :: RainTypePassType +markReplicators :: RainTypeCheckOn A.Specification markReplicators = checkDepthM mark where mark :: RainTypeCheck A.Specification @@ -179,11 +196,11 @@ markReplicators = checkDepthM mark mark _ = return () -- | Folds all constants. -constantFoldPass :: Pass +constantFoldPass :: PassOn A.Expression constantFoldPass = rainOnlyPass "Fold all constant expressions" ([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded]) [Prop.constantsFolded, Prop.constantsChecked] - (applyDepthM doExpression) + (applyBottomUpM doExpression) where doExpression :: A.Expression -> PassM A.Expression 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 -- AST, and checks that the actual parameters are valid inputs, given -- the 'A.Formal' parameters in the process's type -markParamPass :: RainTypePassType +markParamPass :: RainTypeCheckOn2 A.Process A.Expression markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc where --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 () -- | Checks the types in expressions -markExpressionTypes :: RainTypePassType +markExpressionTypes :: RainTypeCheckOn A.Expression markExpressionTypes = checkDepthM checkExpression where -- 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 -- | Checks the types in assignments -markAssignmentTypes :: RainTypePassType +markAssignmentTypes :: RainTypeCheckOn A.Process markAssignmentTypes = checkDepthM checkAssignment where checkAssignment :: RainTypeCheck A.Process @@ -261,7 +278,7 @@ markAssignmentTypes = checkDepthM checkAssignment checkAssignment st = return () -- | Checks the types in if and while conditionals -markConditionalTypes :: RainTypePassType +markConditionalTypes :: RainTypeCheckOn2 A.Process A.Choice markConditionalTypes = checkDepthM2 checkWhile checkIf where checkWhile :: RainTypeCheck A.Process @@ -274,7 +291,7 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf = markUnify exp (M m A.Bool) -- | Marks types in poison statements -markPoisonTypes :: RainTypePassType +markPoisonTypes :: RainTypeCheckOn A.Process markPoisonTypes = checkDepthM checkPoison where checkPoison :: RainTypeCheck A.Process @@ -284,7 +301,7 @@ markPoisonTypes = checkDepthM checkPoison checkPoison _ = return () -- | Checks the types in inputs and outputs, including inputs in alts -markCommTypes :: RainTypePassType +markCommTypes :: RainTypeCheckOn2 A.Process A.Alternative markCommTypes = checkDepthM2 checkInputOutput checkAltInput where checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM ()