diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 6351251..9534c8d 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -49,7 +49,7 @@ transformWaitFor :: Pass transformWaitFor = cOnlyPass "Transform wait for guards into wait until guards" [] [Prop.waitForRemoved] - $ applyDepthM doAlt + (applyDepthM doAlt) where doAlt :: A.Process -> PassM A.Process doAlt a@(A.Alt m pri s) @@ -86,7 +86,7 @@ declareSizesArray :: Pass declareSizesArray = occamOnlyPass "Declare array-size arrays" (prereq ++ [Prop.slicesSimplified, Prop.arrayConstructorsRemoved]) [Prop.arraySizesDeclared] - $ applyDepthSM doStructured + (applyDepthSM doStructured) where defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM () defineSizesName m n spec @@ -239,7 +239,7 @@ addSizesFormalParameters :: Pass addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers" (prereq ++ [Prop.arraySizesDeclared]) [] - $ applyDepthM doSpecification + (applyDepthM doSpecification) where doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Proc m' sm args body)) @@ -276,7 +276,7 @@ addSizesActualParameters :: Pass addSizesActualParameters = occamOnlyPass "Add array-size arrays to PROC calls" (prereq ++ [Prop.arraySizesDeclared]) [] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.ProcCall m n params) = concatMapM transformActual params >>* A.ProcCall m n @@ -305,7 +305,7 @@ simplifySlices :: Pass simplifySlices = occamOnlyPass "Simplify array slices" prereq [Prop.slicesSimplified] - $ applyDepthM doVariable + (applyDepthM doVariable) where doVariable :: A.Variable -> PassM A.Variable doVariable (A.SubscriptedVariable m (A.SubscriptFor m' check for) v) diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index d2caa67..7cc7bc6 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -51,7 +51,7 @@ fixConstructorTypes :: Pass fixConstructorTypes = occamOnlyPass "Fix the types of array constructors" [Prop.constantsFolded] [Prop.arrayConstructorTypesDone] - $ applyDepthM doExpression + (applyDepthM doExpression) where doExpression :: A.Expression -> PassM A.Expression doExpression (A.ExprConstr m (A.RepConstr m' _ rep expr)) @@ -66,7 +66,7 @@ resolveAmbiguities :: Pass resolveAmbiguities = occamOnlyPass "Resolve ambiguities" [Prop.inferredTypesRecorded] [Prop.ambiguitiesResolved] - $ applyDepthM doExpressionList + (applyDepthM doExpressionList) where doExpressionList :: Transform A.ExpressionList -- A single function call inside an ExpressionList is actually a @@ -80,7 +80,7 @@ foldConstants :: Pass foldConstants = occamOnlyPass "Fold constants" [Prop.inferredTypesRecorded] [Prop.constantsFolded] - $ applyDepthM2 doExpression doSpecification + (applyDepthM2 doExpression doSpecification) where -- Try to fold all expressions we encounter. Since we've recursed into the -- expression first, this'll also fold subexpressions of non-constant @@ -103,7 +103,7 @@ checkConstants :: Pass checkConstants = occamOnlyPass "Check mandatory constants" [Prop.constantsFolded, Prop.arrayConstructorTypesDone] [Prop.constantsChecked] - $ applyDepthM2 doDimension doOption + (applyDepthM2 doDimension doOption) where -- Check array dimensions are constant. doDimension :: A.Dimension -> PassM A.Dimension diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 689fd63..1ca94c8 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -610,7 +610,7 @@ inferTypes :: Pass inferTypes = occamOnlyPass "Infer types" [] [Prop.inferredTypesRecorded] - $ recurse + recurse where ops :: Ops ops = baseOp @@ -1011,11 +1011,11 @@ checkTypes = occamOnlyPass "Check types" [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved] [Prop.expressionTypesChecked, Prop.processTypesChecked, Prop.functionTypesChecked, Prop.retypesChecked] - $ checkVariables >.> + ( checkVariables >.> checkExpressions >.> checkSpecTypes >.> checkProcesses >.> - checkReplicators + checkReplicators) --{{{ checkVariables diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 3f5fa25..a462391 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -60,7 +60,7 @@ 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 = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyDepthM transformInt') where transformInt' :: A.Type -> PassM A.Type transformInt' A.Int = return A.Int64 @@ -83,7 +83,7 @@ uniquifyAndResolveVars :: Pass uniquifyAndResolveVars = rainOnlyPass "Uniquify variable declarations, record declared types and resolve variable names" [Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) - $ applyDepthSM uniquifyAndResolveVars' + (applyDepthSM uniquifyAndResolveVars') where uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a) @@ -156,9 +156,9 @@ findMain :: Pass --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 "main_" + ( \x -> do newMainName <- makeNonce "main_" modify (findMain' newMainName) - applyDepthM (return . (replaceNameName "main" newMainName)) x + applyDepthM (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 @@ -189,7 +189,7 @@ checkIntegral _ = Nothing transformEachRange :: Pass transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR" (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed] - $ applyDepthSM doStructured + (applyDepthSM doStructured) where doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr @@ -208,7 +208,7 @@ transformRangeRep :: Pass transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors" (Prop.agg_typesDone ++ [Prop.eachRangeTransformed]) [Prop.rangeTransformed] - $ applyDepthM doExpression + (applyDepthM doExpression) where doExpression :: A.Expression -> PassM A.Expression doExpression (A.ExprConstr _ (A.RangeConstr m t begin end)) @@ -250,7 +250,7 @@ checkFunction = return -- applyDepthM checkFunction' pullUpForEach :: Pass pullUpForEach = rainOnlyPass "Pull up foreach-expressions" (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed] - $ applyDepthSM doStructured + (applyDepthSM doStructured) where doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s) @@ -267,7 +267,7 @@ pullUpForEach = rainOnlyPass "Pull up foreach-expressions" pullUpParDeclarations :: Pass pullUpParDeclarations = rainOnlyPass "Pull up par declarations" [] [Prop.rainParDeclarationsPulledUp] - $ applyDepthM pullUpParDeclarations' + (applyDepthM pullUpParDeclarations') where pullUpParDeclarations' :: A.Process -> PassM A.Process pullUpParDeclarations' p@(A.Par m mode inside) @@ -285,7 +285,7 @@ pullUpParDeclarations = rainOnlyPass "Pull up par declarations" mobiliseLists :: Pass mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties - $ \x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x + (\x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x) where mobilise :: A.Type -> PassM A.Type mobilise t@(A.List _) = return $ A.Mobile t @@ -293,8 +293,8 @@ mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties -- | 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 = rainOnlyPass "AST Validity check, Rain #1" [] [] $ - excludeConstr +excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] + (excludeConstr [ con0 A.Real32 ,con0 A.Real64 ,con2 A.Counted @@ -314,5 +314,5 @@ excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] $ ,con1 A.Stop ,con3 A.Processor ,con3 A.IntrinsicProcCall - ] + ]) diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 3ebbadb..5f749b7 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -92,7 +92,7 @@ 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: + (\x -> do -- First, we copy the known types into the unify map: st <- get ul <- shift $ csNames st put st {csUnifyPairs = [], csUnifyLookup = ul} @@ -111,7 +111,7 @@ performTypeUnification = rainOnlyPass "Rain Type Checking" l <- get >>* csUnifyLookup ts <- mapMapM (\v -> fromTypeExp v) l get >>= substituteUnknownTypes ts >>= put - substituteUnknownTypes ts x' + substituteUnknownTypes ts x') where shift :: Map.Map String A.NameDef -> PassM (Map.Map UnifyIndex UnifyValue) shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList @@ -143,7 +143,7 @@ substituteUnknownTypes mt = applyDepthM sub recordInfNameTypes :: Pass recordInfNameTypes = rainOnlyPass "Record inferred name types in dictionary" (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) [Prop.inferredTypesRecorded] - $ checkDepthM recordInfNameTypes' + (checkDepthM recordInfNameTypes') where recordInfNameTypes' :: Check A.Replicator recordInfNameTypes' input@(A.ForEach m n e) @@ -169,7 +169,7 @@ constantFoldPass :: Pass constantFoldPass = rainOnlyPass "Fold all constant expressions" ([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded]) [Prop.constantsFolded, Prop.constantsChecked] - $ applyDepthM doExpression + (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 47aba53..5b90c94 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 :: forall t. Data t => t -> m t + passCode :: PassType , passName :: String , passPre :: Set.Set Property , passPost :: Set.Set Property @@ -121,7 +121,13 @@ passOnlyOnAST name func x Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level" Just y' -> return y' -type PassMaker = String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass +-- For all functions of this type, do NOT use dollar before the pass. +-- That is, do not write: pass "" [] [] $ some code +-- On GHC 6.6 (without impredicative polymorphism from 6.8.1) this +-- will force the RHS (some code) to become monomorphic, where in fact +-- it needs to remain polymorphic. So just bracket the code for the +-- pass instead, and everything will be fine +type PassMaker = String -> [Property] -> [Property] -> PassType -> Pass passMakerHelper :: (CompState -> Bool) -> PassMaker passMakerHelper f name pre post code @@ -144,14 +150,8 @@ cOnlyPass = passMakerHelper $ (== BackendC) . csBackend cppOnlyPass :: PassMaker cppOnlyPass = passMakerHelper $ (== BackendCPPCSP) . csBackend -pass :: String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass -pass name pre post code - = Pass { passCode = code - , passName = name - , passPre = Set.fromList pre - , passPost = Set.fromList post - , passEnabled = const True - } +pass :: PassMaker +pass = passMakerHelper (const True) -- | Compose a list of passes into a single pass by running them in the order given. runPasses :: [Pass] -> (A.AST -> PassM A.AST) diff --git a/pass/PassList.hs b/pass/PassList.hs index 83c1df9..5b0ae18 100644 --- a/pass/PassList.hs +++ b/pass/PassList.hs @@ -51,7 +51,7 @@ commonPasses opts = concat $ [ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes , enablePassesWhen csUsageChecking [pass "Usage checking" Prop.agg_namesDone [Prop.parUsageChecked] - $ passOnlyOnAST "usageCheckPass" $ runPassR usageCheckPass] + (passOnlyOnAST "usageCheckPass" $ runPassR usageCheckPass)] -- If usage checking is turned off, the pass list will break unless we insert this dummy item: , enablePassesWhen (not . csUsageChecking) [pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked] diff --git a/pass/Traversal.hs b/pass/Traversal.hs index f98eef7..13230e6 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -160,8 +160,8 @@ makeDescend ops@(tks, _) = gmapMFor ts recurse recurse = makeRecurse ops -- | Apply a transformation, recursing depth-first. -applyDepthM :: forall m t1 s. (Monad m, Data t1, Data s) => - TransformM m t1 -> s -> m s +applyDepthM :: forall m t1. (Monad m, Data t1) => + TransformM m t1 -> (forall s. Data s => s -> m s) applyDepthM f1 = makeRecurse ops where ops :: OpsM m diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs index 85dd3e4..609a9c4 100644 --- a/transformations/ImplicitMobility.hs +++ b/transformations/ImplicitMobility.hs @@ -159,7 +159,7 @@ implicitMobility :: Pass implicitMobility = rainOnlyPass "Implicit mobility optimisation" [] [] --TODO properties - $ passOnlyOnAST "implicitMobility" $ \t -> do + (passOnlyOnAST "implicitMobility" $ \t -> do g' <- buildFlowGraph labelFunctions t :: PassM (Either String (FlowGraph' PassM UsageLabel (), [Node], [Node])) @@ -170,5 +170,5 @@ implicitMobility -- data-flow analysis do decs <- makeMoveCopyDecisions g terms printMoveCopyDecisions decs - effectMoveCopyDecisions g decs t + effectMoveCopyDecisions g decs t) diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 03bde0f..a4aa026 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -42,7 +42,7 @@ outExprs :: Pass outExprs = pass "Define temporary variables for outputting expressions" (Prop.agg_namesDone ++ Prop.agg_typesDone) [Prop.outExpressionRemoved] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Output m c ois) @@ -137,7 +137,7 @@ transformInputCase :: Pass transformInputCase = pass "Transform ? CASE statements/guards into plain CASE" (Prop.agg_namesDone ++ Prop.agg_typesDone) [Prop.inputCaseRemoved] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputCase m' s)) @@ -184,7 +184,7 @@ transformProtocolInput :: Pass transformProtocolInput = pass "Flatten sequential protocol inputs into multiple inputs" (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved]) [Prop.seqInputsFlattened] - $ applyDepthM2 doProcess doAlternative + (applyDepthM2 doProcess doAlternative) where doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_))) diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index bb5feb0..d1e855d 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -51,7 +51,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked, Prop.functionTypesChecked]) [Prop.functionsRemoved] - $ applyDepthM doSpecification + (applyDepthM doSpecification) where doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Function mf sm rts fs evp)) @@ -103,7 +103,7 @@ removeAfter :: Pass removeAfter = pass "Convert AFTER to MINUS" [Prop.expressionTypesChecked] [Prop.afterRemoved] - $ applyDepthM doExpression + (applyDepthM doExpression) where doExpression :: A.Expression -> PassM A.Expression doExpression (A.Dyadic m A.After a b) @@ -122,7 +122,7 @@ expandArrayLiterals :: Pass expandArrayLiterals = pass "Expand array literals" [Prop.expressionTypesChecked, Prop.processTypesChecked] [Prop.arrayLiteralsExpanded] - $ applyDepthM doArrayElem + (applyDepthM doArrayElem) where doArrayElem :: A.ArrayElem -> PassM A.ArrayElem doArrayElem ae@(A.ArrayElemExpr e) @@ -159,7 +159,7 @@ pullRepCounts :: Pass pullRepCounts = pass "Pull up replicator counts for SEQs" (Prop.agg_namesDone ++ Prop.agg_typesDone) [] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Seq m s) = pullRepCountSeq s >>* A.Seq m @@ -188,7 +188,7 @@ transformConstr :: Pass transformConstr = pass "Transform array constructors into initialisation code" (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp]) [Prop.arrayConstructorsRemoved] - $ applyDepthSM doStructured + (applyDepthSM doStructured) where -- For arrays, this takes a constructor expression: -- VAL type name IS [i = rep | expr]: diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 36d7130..72e9e58 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -43,7 +43,7 @@ parsToProcs :: Pass parsToProcs = pass "Wrap PAR subprocesses in PROCs" [Prop.parUsageChecked] [Prop.parsWrapped] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Par m pm s) @@ -65,7 +65,7 @@ removeParAssign :: Pass removeParAssign = pass "Remove parallel assignment" [Prop.parUsageChecked, Prop.functionsRemoved, Prop.functionCallsRemoved] [Prop.assignParRemoved] - $ applyDepthM doProcess + (applyDepthM doProcess) where doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) @@ -82,7 +82,7 @@ flattenAssign :: Pass flattenAssign = pass "Flatten assignment" (Prop.agg_typesDone ++ [Prop.assignParRemoved]) [Prop.assignFlattened] - $ makeRecurse ops + (makeRecurse ops) where ops :: Ops ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index e59113c..5623f23 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -98,7 +98,7 @@ removeFreeNames :: Pass removeFreeNames = pass "Convert free names to arguments" [Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved] [Prop.freeNamesToArgs] - $ applyDepthM2 doSpecification doProcess + (applyDepthM2 doSpecification doProcess) where doSpecification :: A.Specification -> PassM A.Specification doSpecification spec = case spec of @@ -188,11 +188,11 @@ removeNesting :: Pass removeNesting = pass "Pull nested definitions to top level" [Prop.freeNamesToArgs] [Prop.nestedPulled] - $ passOnlyOnAST "removeNesting" $ \s -> + (passOnlyOnAST "removeNesting" $ \s -> do pushPullContext s' <- (makeRecurse ops) s >>= applyPulled popPullContext - return $ fromJust $ cast s' + return $ fromJust $ cast s') where ops :: Ops ops = baseOp `extOpS` doStructured