From 6debf9292f108e82ad22b5dbd976ea043caeb6f5 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Sun, 25 May 2008 20:13:57 +0000 Subject: [PATCH] Rework Traversal, and convert all passes to use it. This changes the Traversal API to the one that I've been working on in the Polyplate branch, but implemented in terms of Data. The performance isn't as good as the Polyplate version, but the code is a lot simpler because it doesn't need all the type constraints (and it doesn't make GHC struggle). This also reworks all the passes in Tock to use the new API, including those that previously used makeGeneric (which I've now removed) or everywhereM. Most of the passes are simpler because of this, and I suspect it's fixed a few subtle bugs resulting from missing recursion in makeGeneric code. I haven't yet profiled this, but subjectively it seems about the same as the old Traversal (and thus faster for all the passes that didn't yet use it). --- backends/BackendPasses.hs | 74 ++++------- backends/GenerateCPPCSP.hs | 12 +- common/Types.hs | 24 ++-- frontends/OccamTypes.hs | 164 ++++++++++++------------ frontends/RainPasses.hs | 58 ++++----- frontends/RainTypes.hs | 24 ++-- pass/Pass.hs | 24 ++-- pass/Traversal.hs | 209 ++++++++++++++++++++++--------- transformations/SimplifyComms.hs | 53 +++----- transformations/SimplifyExprs.hs | 143 +++++++++------------ transformations/SimplifyProcs.hs | 56 ++++----- transformations/SimplifyTypes.hs | 13 +- transformations/Unnest.hs | 79 ++++++------ 13 files changed, 461 insertions(+), 472 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 946d70e..6382bda 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -30,6 +30,7 @@ import Metadata import Pass import PrettyShow import qualified Properties as Prop +import Traversal import Types import Utils @@ -44,19 +45,16 @@ squashArrays = makePassesDep where prereq = Prop.agg_namesDone ++ Prop.agg_typesDone ++ Prop.agg_functionsGone ++ [Prop.subscriptsPulledUp, Prop.arrayLiteralsExpanded] -transformWaitFor :: Data t => t -> PassM t -transformWaitFor = doGeneric `extM` doAlt +transformWaitFor :: PassType +transformWaitFor = applyDepthM doAlt where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformWaitFor - doAlt :: A.Process -> PassM A.Process doAlt a@(A.Alt m pri s) = do (s',(specs,code)) <- runStateT (applyToOnly doWaitFor s) ([],[]) if (null specs && null code) then return a else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.Only m $ A.Alt m pri s'])) specs - doAlt p = doGeneric p + doAlt p = return p addSpec :: Data a => (A.Structured a -> A.Structured a) -> A.Structured a -> A.Structured a addSpec spec inner = spec inner @@ -81,8 +79,8 @@ append_sizes n = n {A.nameName = A.nameName n ++ "_sizes"} -- | Declares a _sizes array for every array, statically sized or dynamically sized. -- For each record type it declares a _sizes array too. -declareSizesArray :: Data t => t -> PassM t -declareSizesArray = doGeneric `ext1M` doStructured +declareSizesArray :: PassType +declareSizesArray = applyDepthSM doStructured where defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM () defineSizesName m n spec @@ -175,10 +173,6 @@ declareSizesArray = doGeneric `ext1M` doStructured defineSizesName m n_sizes sizeSpecType return $ A.Specification m n_sizes sizeSpecType - - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric declareSizesArray - doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured str@(A.Spec m sp@(A.Specification m' n spec) s) = do t <- typeOfSpec spec @@ -207,14 +201,12 @@ declareSizesArray = doGeneric `ext1M` doStructured sizeSpec = A.Specification m' n_sizes sizeSpecType defineSizesName m' n_sizes sizeSpecType return sizeSpec - s' <- doStructured s - return (A.Spec m sizeSpec $ A.Spec m sp $ s') + return (A.Spec m sizeSpec $ A.Spec m sp $ s) (A.RecordType m _ fs, _) -> - do s' <- doStructured s - fieldDeclarations <- foldM (declareFieldSizes (A.nameName n) m) s' fs + do fieldDeclarations <- foldM (declareFieldSizes (A.nameName n) m) s fs return $ A.Spec m sp fieldDeclarations - _ -> doGeneric str - doStructured s = doGeneric s + _ -> return str + doStructured s = return s makeStaticSizeSpec :: Meta -> A.Name -> [A.Dimension] -> A.SpecType makeStaticSizeSpec m n ds = makeDynamicSizeSpec m n es @@ -238,21 +230,17 @@ declareSizesArray = doGeneric `ext1M` doStructured -- | A pass for adding _sizes parameters to PROC arguments -- TODO in future, only add _sizes for variable-sized parameters -addSizesFormalParameters :: Data t => t -> PassM t -addSizesFormalParameters = doGeneric `extM` doSpecification +addSizesFormalParameters :: PassType +addSizesFormalParameters = applyDepthM doSpecification where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric addSizesFormalParameters - doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Proc m' sm args body)) = do (args', newargs) <- transformFormals m args - body' <- doGeneric body - let newspec = A.Proc m' sm args' body' + let newspec = A.Proc m' sm args' body modify (\cs -> cs {csNames = Map.adjust (\nd -> nd { A.ndSpecType = newspec }) (A.nameName n) (csNames cs)}) mapM_ (recordArg m') newargs return $ A.Specification m n newspec - doSpecification st = doGeneric st + doSpecification st = return st recordArg :: Meta -> A.Formal -> PassM () recordArg m (A.Formal am t n) @@ -277,15 +265,12 @@ addSizesFormalParameters = doGeneric `extM` doSpecification return (f : rest, new) -- | A pass for adding _sizes parameters to actuals in PROC calls -addSizesActualParameters :: Data t => t -> PassM t -addSizesActualParameters = doGeneric `extM` doProcess +addSizesActualParameters :: PassType +addSizesActualParameters = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric addSizesActualParameters - doProcess :: A.Process -> PassM A.Process doProcess (A.ProcCall m n params) = concatMapM transformActual params >>* A.ProcCall m n - doProcess p = doGeneric p + doProcess p = return p transformActual :: A.Actual -> PassM [A.Actual] transformActual a@(A.ActualVariable v) @@ -306,25 +291,16 @@ addSizesActualParameters = doGeneric `extM` doProcess transformActualVariable a _ = return [a] -- | Transforms all slices into the FromFor form. -simplifySlices :: Data t => t -> PassM t -simplifySlices = doGeneric `extM` doVariable +simplifySlices :: PassType +simplifySlices = applyDepthM doVariable where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric simplifySlices - - -- We recurse into the subscripts in case they contain subscripts: doVariable :: A.Variable -> PassM A.Variable doVariable (A.SubscriptedVariable m (A.SubscriptFor m' for) v) - = do for' <- doGeneric for - v' <- doGeneric v - return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for') v') + = return (A.SubscriptedVariable m (A.SubscriptFromFor m' (makeConstant m' 0) for) v) doVariable (A.SubscriptedVariable m (A.SubscriptFrom m' from) v) - = do v' <- doGeneric v - A.Array (d:_) _ <- astTypeOf v' + = do A.Array (d:_) _ <- astTypeOf v limit <- case d of A.Dimension n -> return n - A.UnknownDimension -> return $ A.SizeVariable m' v' - from' <- doGeneric from - return (A.SubscriptedVariable m (A.SubscriptFromFor m' from' (A.Dyadic m A.Subtr limit from')) v') - -- We must recurse, to handle nested variables, and variables inside subscripts! - doVariable v = doGeneric v + A.UnknownDimension -> return $ A.SizeVariable m' v + return (A.SubscriptedVariable m (A.SubscriptFromFor m' from (A.Dyadic m A.Subtr limit from)) v) + doVariable v = return v diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 1b0e128..8652923 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -47,6 +47,7 @@ import Pass import qualified Properties as Prop import ShowCode import TLP +import Traversal import Types import Utils @@ -93,7 +94,7 @@ genCPPCSPPasses = makePassesDep' ((== BackendCPPCSP) . csBackend) [ ("Transform channels to ANY", chansToAny, [Prop.processTypesChecked], [Prop.allChansToAnyOrProtocol]) ] -chansToAny :: Data t => t -> PassM t +chansToAny :: PassType chansToAny x = do st <- get case csFrontend st of FrontendOccam -> @@ -104,13 +105,10 @@ chansToAny x = do st <- get chansToAny' :: A.Type -> PassM A.Type chansToAny' c@(A.Chan _ _ (A.UserProtocol {})) = return c chansToAny' (A.Chan a b _) = return $ A.Chan a b A.Any - chansToAny' t = doGeneric t + chansToAny' t = return t chansToAnyM :: Data t => t -> PassM t - chansToAnyM = doGeneric `extM` chansToAny' - - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric chansToAnyM + chansToAnyM = applyDepthM chansToAny' chansToAnyInCompState :: PassM () chansToAnyInCompState = do st <- get diff --git a/common/Types.hs b/common/Types.hs index a5d0eb5..85c3d79 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -48,9 +48,9 @@ import Errors import EvalLiterals import Intrinsics import Metadata -import Pass import PrettyShow import ShowCode +import Traversal import TypeSizes import Utils @@ -311,22 +311,14 @@ abbrevModeOfSpec s -- | Resolve a datatype into its underlying type -- i.e. if it's a named data -- type, then return the underlying real type. This will recurse. - underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type -underlyingType m = underlyingType' +underlyingType m = applyDepthM doType where - underlyingType' :: Data t => t -> m t - underlyingType' = doGeneric `extM` underlyingType'' - - doGeneric :: Data t => t -> m t - doGeneric = makeGeneric underlyingType' - - underlyingType'' :: A.Type -> m A.Type - underlyingType'' t@(A.UserDataType _) - = resolveUserType m t >>= underlyingType m - underlyingType'' (A.Array ds t) - = underlyingType m t >>* addDimensions ds - underlyingType'' t = doGeneric t + doType :: A.Type -> m A.Type + -- This is fairly subtle: after resolving a user type, we have to recurse + -- on the resulting type. + doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m + doType t = return t -- | Like underlyingType, but only do the "outer layer": if you give this a -- user type that's an array of user types, then you'll get back an array of diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index a28f055..6868515 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -616,25 +616,33 @@ inSubscriptedContext m body --{{{ inferTypes -- | Infer types. -inferTypes :: Data t => t -> PassM t -inferTypes = applyX $ baseX - `extX` doExpression - `extX` doDimension - `extX` doSubscript - `extX` doArrayConstr - `extX` doReplicator - `extX` doAlternative - `extX` doInputMode - `extX` doSpecification - `extX` doProcess - `extX` doVariable +inferTypes :: PassType +inferTypes = recurse where - doExpression :: ExplicitTrans A.Expression - doExpression descend outer + ops :: Ops + ops = baseOp + `extOp` doExpression + `extOp` doDimension + `extOp` doSubscript + `extOp` doArrayConstr + `extOp` doReplicator + `extOp` doAlternative + `extOp` doInputMode + `extOp` doSpecification + `extOp` doProcess + `extOp` doVariable + + recurse :: Recurse + recurse = makeRecurse ops + descend :: Descend + descend = makeDescend ops + + doExpression :: Transform A.Expression + doExpression outer = case outer of -- Literals are what we're really looking for here. A.Literal m t lr -> - do t' <- inferTypes t + do t' <- recurse t ctx <- getTypeContext let wantT = case (ctx, t') of -- No type specified on the literal, @@ -643,7 +651,7 @@ inferTypes = applyX $ baseX -- Use the explicit type of the literal, or the -- default. _ -> t' - (realT, realLR) <- doLiteral descend (wantT, lr) + (realT, realLR) <- doLiteral (wantT, lr) return $ A.Literal m realT realLR -- Expressions that aren't literals, but that modify the type @@ -651,14 +659,14 @@ inferTypes = applyX $ baseX A.Dyadic m op le re -> let -- Both types are the same. bothSame - = do lt <- inferTypes le >>= astTypeOf - rt <- inferTypes re >>= astTypeOf + = do lt <- recurse le >>= astTypeOf + rt <- recurse re >>= astTypeOf inTypeContext (Just $ betterType lt rt) $ descend outer -- The RHS type is always A.Int. intOnRight - = do le' <- inferTypes le - re' <- inTypeContext (Just A.Int) $ inferTypes re + = do le' <- recurse le + re' <- inTypeContext (Just A.Int) $ recurse re return $ A.Dyadic m op le' re' in case classifyOp op of ComparisonOp -> noTypeContext $ bothSame @@ -675,9 +683,9 @@ inferTypes = applyX $ baseX ctx' <- case ctx of Just t -> unsubscriptType s t >>* Just Nothing -> return Nothing - e' <- inTypeContext ctx' $ inferTypes e + e' <- inTypeContext ctx' $ recurse e t <- astTypeOf e' - s' <- inferTypes s >>= fixSubscript t + s' <- recurse s >>= fixSubscript t return $ A.SubscriptedExpr m s' e' A.BytesInExpr _ _ -> noTypeContext $ descend outer -- FIXME: ExprConstr @@ -694,19 +702,19 @@ inferTypes = applyX $ baseX doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a] doActuals m n fs as = do checkActualCount m n fs as - sequence [inTypeContext (Just t) $ inferTypes a + sequence [inTypeContext (Just t) $ recurse a | (A.Formal _ t _, a) <- zip fs as] - doDimension :: ExplicitTrans A.Dimension - doDimension descend dim = inTypeContext (Just A.Int) $ descend dim + doDimension :: Transform A.Dimension + doDimension dim = inTypeContext (Just A.Int) $ descend dim - doSubscript :: ExplicitTrans A.Subscript - doSubscript descend s = inTypeContext (Just A.Int) $ descend s + doSubscript :: Transform A.Subscript + doSubscript s = inTypeContext (Just A.Int) $ descend s -- FIXME: RepConstr shouldn't contain the type -- and this won't fill it in. -- (That is, it should just be a kind of literal.) - doArrayConstr :: ExplicitTrans A.ArrayConstr - doArrayConstr descend ac + doArrayConstr :: Transform A.ArrayConstr + doArrayConstr ac = case ac of A.RangeConstr m t _ _ -> inSubscriptedContext m $ descend ac A.RepConstr m t _ _ -> inSubscriptedContext m $ descend ac @@ -718,46 +726,46 @@ inferTypes = applyX $ baseX do es' <- doFunctionCall m n es return $ A.FunctionCallList m n es' A.ExpressionList m es -> - do es' <- sequence [inTypeContext (Just t) $ inferTypes e + do es' <- sequence [inTypeContext (Just t) $ recurse e | (t, e) <- zip ts es] return $ A.ExpressionList m es' - doReplicator :: ExplicitTrans A.Replicator - doReplicator descend rep + doReplicator :: Transform A.Replicator + doReplicator rep = case rep of A.For _ _ _ _ -> inTypeContext (Just A.Int) $ descend rep A.ForEach _ _ _ -> noTypeContext $ descend rep - doAlternative :: ExplicitTrans A.Alternative - doAlternative descend a = inTypeContext (Just A.Bool) $ descend a + doAlternative :: Transform A.Alternative + doAlternative a = inTypeContext (Just A.Bool) $ descend a - doInputMode :: ExplicitTrans A.InputMode - doInputMode descend im = inTypeContext (Just A.Int) $ descend im + doInputMode :: Transform A.InputMode + doInputMode im = inTypeContext (Just A.Int) $ descend im -- FIXME: This should be shared with foldConstants. - doSpecification :: ExplicitTrans A.Specification - doSpecification descend s@(A.Specification m n st) - = do st' <- doSpecType descend st + doSpecification :: Transform A.Specification + doSpecification s@(A.Specification m n st) + = do st' <- doSpecType st -- Update the definition of each name after we handle it. modifyName n (\nd -> nd { A.ndSpecType = st' }) return $ A.Specification m n st' - doSpecType :: ExplicitTrans A.SpecType - doSpecType descend st + doSpecType :: Transform A.SpecType + doSpecType st = case st of A.Place _ _ -> inTypeContext (Just A.Int) $ descend st A.Is m am t v -> - do am' <- inferTypes am - t' <- inferTypes t - v' <- inTypeContext (Just t') $ inferTypes v + do am' <- recurse am + t' <- recurse t + v' <- inTypeContext (Just t') $ recurse v t'' <- case t' of A.Infer -> astTypeOf v' _ -> return t' return $ A.Is m am' t'' v' A.IsExpr m am t e -> - do am' <- inferTypes am - t' <- inferTypes t - e' <- inTypeContext (Just t') $ inferTypes e + do am' <- recurse am + t' <- recurse t + e' <- inTypeContext (Just t') $ recurse e t'' <- case t' of A.Infer -> astTypeOf e' _ -> return t' @@ -765,8 +773,8 @@ inferTypes = applyX $ baseX A.IsChannelArray m t vs -> -- No expressions in this -- but we may need to infer the type -- of the variable if it's something like "cs IS [c]:". - do t' <- inferTypes t - vs' <- mapM inferTypes vs + do t' <- recurse t + vs' <- mapM recurse vs let dim = makeDimension m $ length vs' t'' <- case (t', vs') of (A.Infer, (v:_)) -> @@ -777,9 +785,9 @@ inferTypes = applyX $ baseX _ -> return $ applyDimension dim t' return $ A.IsChannelArray m t'' vs' A.Function m sm ts fs (Left sel) -> - do sm' <- inferTypes sm - ts' <- inferTypes ts - fs' <- inferTypes fs + do sm' <- recurse sm + ts' <- recurse ts + fs' <- recurse fs sel' <- doFuncDef ts sel return $ A.Function m sm' ts' fs' (Left sel') A.RetypesExpr _ _ _ _ -> noTypeContext $ descend st @@ -791,27 +799,27 @@ inferTypes = applyX $ baseX -- form.) doFuncDef :: [A.Type] -> Transform (A.Structured A.ExpressionList) doFuncDef ts (A.Spec m spec s) - = do spec' <- inferTypes spec + = do spec' <- recurse spec s' <- doFuncDef ts s return $ A.Spec m spec' s' doFuncDef ts (A.ProcThen m p s) - = do p' <- inferTypes p + = do p' <- recurse p s' <- doFuncDef ts s return $ A.ProcThen m p' s' doFuncDef ts (A.Only m el) = do el' <- doExpressionList ts el return $ A.Only m el' - doProcess :: ExplicitTrans A.Process - doProcess descend p + doProcess :: Transform A.Process + doProcess p = case p of A.Assign m vs el -> - do vs' <- inferTypes vs + do vs' <- recurse vs ts <- mapM astTypeOf vs' el' <- doExpressionList ts el return $ A.Assign m vs' el' A.Output m v ois -> - do v' <- inferTypes v + do v' <- recurse v -- At this point we must resolve the "c ! x" ambiguity: -- we definitely know what c is, and we must know what x is -- before trying to infer its type. @@ -828,14 +836,14 @@ inferTypes = applyX $ baseX else do ois' <- doOutputItems m v' Nothing ois return $ A.Output m v' ois' A.OutputCase m v tag ois -> - do v' <- inferTypes v + do v' <- recurse v ois' <- doOutputItems m v' (Just tag) ois return $ A.OutputCase m v' tag ois' A.If _ _ -> inTypeContext (Just A.Bool) $ descend p A.Case m e so -> - do e' <- inferTypes e + do e' <- recurse e t <- astTypeOf e' - so' <- inTypeContext (Just t) $ inferTypes so + so' <- inTypeContext (Just t) $ recurse so return $ A.Case m e' so' A.While _ _ _ -> inTypeContext (Just A.Bool) $ descend p A.Processor _ _ _ -> inTypeContext (Just A.Int) $ descend p @@ -867,19 +875,19 @@ inferTypes = applyX $ baseX doOutputItem :: A.Type -> Transform A.OutputItem doOutputItem (A.Counted ct at) (A.OutCounted m ce ae) - = do ce' <- inTypeContext (Just ct) $ inferTypes ce - ae' <- inTypeContext (Just at) $ inferTypes ae + = do ce' <- inTypeContext (Just ct) $ recurse ce + ae' <- inTypeContext (Just at) $ recurse ae return $ A.OutCounted m ce' ae' - doOutputItem A.Any o = noTypeContext $ inferTypes o - doOutputItem t o = inTypeContext (Just t) $ inferTypes o + doOutputItem A.Any o = noTypeContext $ recurse o + doOutputItem t o = inTypeContext (Just t) $ recurse o - doVariable :: ExplicitTrans A.Variable - doVariable descend (A.SubscriptedVariable m s v) - = do v' <- inferTypes v + doVariable :: Transform A.Variable + doVariable (A.SubscriptedVariable m s v) + = do v' <- recurse v t <- astTypeOf v' - s' <- inferTypes s >>= fixSubscript t + s' <- recurse s >>= fixSubscript t return $ A.SubscriptedVariable m s' v' - doVariable descend v = descend v + doVariable v = descend v -- | Resolve the @v[s]@ ambiguity: this takes the type that @v@ is, and -- returns the correct 'Subscript'. @@ -901,8 +909,8 @@ inferTypes = applyX $ baseX -- | Process a 'LiteralRepr', taking the type it's meant to represent or -- 'Infer', and returning the type it really is. - doLiteral :: ExplicitTrans (A.Type, A.LiteralRepr) - doLiteral descend (wantT, lr) + doLiteral :: Transform (A.Type, A.LiteralRepr) + doLiteral (wantT, lr) = case lr of A.ArrayLiteral m aes -> do (t, A.ArrayElemArray aes') <- @@ -960,7 +968,7 @@ inferTypes = applyX $ baseX return (bestT, aes') -- An expression: descend into it with the right context. doArrayElem wantT (A.ArrayElemExpr e) - = do e' <- inTypeContext (Just wantT) $ doExpression descend e + = do e' <- inTypeContext (Just wantT) $ doExpression e t <- astTypeOf e' checkType (findMeta e') wantT t return (t, A.ArrayElemExpr e') @@ -1005,7 +1013,7 @@ inferTypes = applyX $ baseX -- | Check the AST for type consistency. -- This is actually a series of smaller passes that check particular types -- inside the AST, but it doesn't really make sense to split it up. -checkTypes :: Data t => t -> PassM t +checkTypes :: PassType checkTypes t = checkVariables t >>= checkExpressions >>= @@ -1014,7 +1022,7 @@ checkTypes t = --{{{ checkVariables -checkVariables :: Data t => t -> PassM t +checkVariables :: PassType checkVariables = checkDepthM doVariable where doVariable :: Check A.Variable @@ -1036,7 +1044,7 @@ checkVariables = checkDepthM doVariable --}}} --{{{ checkExpressions -checkExpressions :: Data t => t -> PassM t +checkExpressions :: PassType checkExpressions = checkDepthM doExpression where doExpression :: Check A.Expression @@ -1091,7 +1099,7 @@ checkExpressions = checkDepthM doExpression --}}} --{{{ checkSpecTypes -checkSpecTypes :: Data t => t -> PassM t +checkSpecTypes :: PassType checkSpecTypes = checkDepthM doSpecType where doSpecType :: Check A.SpecType @@ -1170,7 +1178,7 @@ checkSpecTypes = checkDepthM doSpecType --}}} --{{{ checkProcesses -checkProcesses :: Data t => t -> PassM t +checkProcesses :: PassType checkProcesses = checkDepthM doProcess where doProcess :: Check A.Process diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 40dd7a6..160bf48 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -32,6 +32,7 @@ import Pass import qualified Properties as Prop import RainTypes import SimplifyTypes +import Traversal import TreeUtils import Types @@ -69,8 +70,8 @@ rainPasses = let f = makePassesDep' ((== FrontendRain) . csFrontend) in f ] -- | A pass that transforms all instances of 'A.Int' into 'A.Int64' -transformInt :: Data t => t -> PassM t -transformInt = everywhereM (mkM transformInt') +transformInt :: PassType +transformInt = applyDepthM transformInt' where transformInt' :: A.Type -> PassM A.Type transformInt' A.Int = return A.Int64 @@ -89,8 +90,8 @@ transformInt = everywhereM (mkM transformInt') -- -- This pass works because everywhereM goes bottom-up, so declarations are --resolved from the bottom upwards. -uniquifyAndResolveVars :: Data t => t -> PassM t -uniquifyAndResolveVars = everywhereM (mk1M uniquifyAndResolveVars') +uniquifyAndResolveVars :: PassType +uniquifyAndResolveVars = applyDepthSM uniquifyAndResolveVars' where uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a) @@ -158,13 +159,13 @@ 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 :: Data t => t -> PassM t +findMain :: PassType --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_" modify (findMain' newMainName) - everywhereM (mkM $ 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 @@ -183,32 +184,25 @@ 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 :: Data t => t -> PassM t -transformEachRange = doGeneric `ext1M` doStructured +transformEachRange :: PassType +transformEachRange = applyDepthSM doStructured where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformEachRange - doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr _ (A.RangeConstr _ _ begin end))) body) - = do body' <- doStructured body - -- Need to change the stored abbreviation mode to original: + = do -- Need to change the stored abbreviation mode to original: modifyName loopVar $ \nd -> nd { A.ndAbbrevMode = A.Original } return $ A.Rep repMeta (A.For eachMeta loopVar begin - (addOne $ subExprs end begin)) body' - doStructured s = doGeneric s + (addOne $ subExprs end begin)) body + doStructured 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 :: Data t => t -> PassM t -transformRangeRep = doGeneric `extM` doExpression +transformRangeRep :: PassType +transformRangeRep = applyDepthM doExpression where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformRangeRep - doExpression :: A.Expression -> PassM A.Expression doExpression (A.ExprConstr _ (A.RangeConstr m t begin end)) = do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.VariableName A.ValAbbrev @@ -216,11 +210,11 @@ transformRangeRep = doGeneric `extM` doExpression return $ A.ExprConstr m $ A.RepConstr m t (A.For m rep begin count) (A.ExprVariable m $ A.Variable m rep) - doExpression e = doGeneric e + doExpression e = return e -- TODO this is almost certainly better figured out from the CFG -checkFunction :: Data t => t -> PassM t -checkFunction = return -- everywhereM (mkM checkFunction') +checkFunction :: PassType +checkFunction = return -- applyDepthM checkFunction' where checkFunction' :: A.Specification -> PassM A.Specification checkFunction' spec@(A.Specification _ n (A.Function m _ _ _ (Right body))) @@ -246,12 +240,9 @@ checkFunction = return -- everywhereM (mkM 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 :: Data t => t -> PassM t -pullUpForEach = doGeneric `ext1M` doStructured +pullUpForEach :: PassType +pullUpForEach = applyDepthSM doStructured where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric pullUpForEach - doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s) = do (extra, loopExp') <- case loopExp of @@ -260,13 +251,12 @@ pullUpForEach = doGeneric `ext1M` doStructured spec@(A.Specification _ n _) <- makeNonceIsExpr "loop_expr" m' t loopExp return (A.Spec m' spec, A.ExprVariable m' (A.Variable m' n)) - s' <- doStructured s - return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s' - doStructured s = doGeneric s + return $ extra $ A.Rep m (A.ForEach m' loopVar loopExp') s + doStructured s = return s -pullUpParDeclarations :: Data t => t -> PassM t -pullUpParDeclarations = everywhereM (mkM pullUpParDeclarations') +pullUpParDeclarations :: PassType +pullUpParDeclarations = applyDepthM pullUpParDeclarations' where pullUpParDeclarations' :: A.Process -> PassM A.Process pullUpParDeclarations' p@(A.Par m mode inside) diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index 7fbce1c..d308882 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -86,7 +86,7 @@ markUnify x y modify $ \st -> st {csUnifyPairs = (tex,tey) : csUnifyPairs st} -performTypeUnification :: Data t => t -> PassM t +performTypeUnification :: PassType performTypeUnification x = do -- First, we copy the known types into the unify map: st <- get @@ -122,7 +122,7 @@ performTypeUnification x name = A.Name {A.nameName = rawName, A.nameMeta = A.ndMeta d, A.nameType = A.ndNameType d} -substituteUnknownTypes :: Data t => Map.Map UnifyIndex A.Type -> t -> PassM t +substituteUnknownTypes :: Map.Map UnifyIndex A.Type -> PassType substituteUnknownTypes mt = applyDepthM sub where sub :: A.Type -> PassM A.Type @@ -137,8 +137,8 @@ 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 :: Data t => t -> PassM t -recordInfNameTypes = everywhereM (mkM recordInfNameTypes') +recordInfNameTypes :: PassType +recordInfNameTypes = applyDepthM recordInfNameTypes' where recordInfNameTypes' :: A.Replicator -> PassM A.Replicator recordInfNameTypes' input@(A.ForEach m n e) @@ -149,7 +149,7 @@ recordInfNameTypes = everywhereM (mkM recordInfNameTypes') return input recordInfNameTypes' r = return r -markReplicators :: Data t => t -> PassM t +markReplicators :: PassType markReplicators = checkDepthM mark where mark :: Check A.Replicator @@ -157,7 +157,7 @@ markReplicators = checkDepthM mark = astTypeOf n >>= \t -> markUnify (A.List t) e -- | Folds all constants. -constantFoldPass :: Data t => t -> PassM t +constantFoldPass :: PassType constantFoldPass = applyDepthM doExpression where doExpression :: A.Expression -> PassM A.Expression @@ -166,7 +166,7 @@ constantFoldPass = applyDepthM doExpression -- | 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 :: Data t => t -> PassM t +markParamPass :: PassType markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc where --Picks out the parameters of a process call, checks the number is correct, and maps doParam over them @@ -197,7 +197,7 @@ markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc matchParamPassFunc _ = return () -- | Checks the types in expressions -markExpressionTypes :: Data t => t -> PassM t +markExpressionTypes :: PassType markExpressionTypes = checkDepthM checkExpression where -- TODO also check in a later pass that the op is valid @@ -217,7 +217,7 @@ markExpressionTypes = checkDepthM checkExpression checkExpression _ = return () -- | Checks the types in assignments -markAssignmentTypes :: Data t => t -> PassM t +markAssignmentTypes :: PassType markAssignmentTypes = checkDepthM checkAssignment where checkAssignment :: Check A.Process @@ -238,7 +238,7 @@ markAssignmentTypes = checkDepthM checkAssignment checkAssignment st = return () -- | Checks the types in if and while conditionals -markConditionalTypes :: Data t => t -> PassM t +markConditionalTypes :: PassType markConditionalTypes = checkDepthM2 checkWhile checkIf where checkWhile :: Check A.Process @@ -251,7 +251,7 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf = markUnify exp A.Bool -- | Checks the types in inputs and outputs, including inputs in alts -markCommTypes :: Data t => t -> PassM t +markCommTypes :: PassType markCommTypes = checkDepthM2 checkInputOutput checkAltInput where checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM () diff --git a/pass/Pass.hs b/pass/Pass.hs index 79f35f3..b21818c 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -31,7 +31,6 @@ import System.IO import qualified AST as A import CompState import Errors -import Metadata import PrettyShow import TreeUtils import Utils @@ -52,7 +51,13 @@ instance Warn PassM where instance Warn PassMR where warnReport w = lift $ lift $ modify (++ [w]) --- | The type of an AST-mangling pass. +-- | The type of a pass function. +-- This is as generic as possible. Passes are used on 'A.AST' in normal use, +-- but for explicit descent and testing it's useful to be able to run them +-- against AST fragments of other types as well. +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 ,passName :: String @@ -67,10 +72,10 @@ instance Monad m => Eq (Pass_ m) where instance Monad m => Ord (Pass_ m) where compare x y = compare (passName x) (passName y) - type Pass = Pass_ PassM type PassR = Pass_ PassMR +-- | A property that can be asserted and tested against the AST. data Property = Property { propName :: String ,propCheck :: A.AST -> PassMR () @@ -157,19 +162,8 @@ applyToOnly f (A.ProcThen m p s) = applyToOnly f s >>* A.ProcThen m p applyToOnly f (A.Several m ss) = mapM (applyToOnly f) ss >>* A.Several m applyToOnly f (A.Only m o) = f o >>* A.Only m --- | Make a generic rule for a pass. -makeGeneric :: forall m t. (Data t, Monad m) => (forall s. Data s => s -> m s) -> t -> m t -makeGeneric top - = (gmapM top) - `extM` (return :: String -> m String) - `extM` (return :: Meta -> m Meta) - excludeConstr :: (Data a, CSMR m) => [Constr] -> a -> m a excludeConstr cons x = if null items then return x else dieInternal (Nothing, "Excluded item still remains in source tree: " ++ (show $ head items) ++ " tree is: " ++ pshow x) where items = checkTreeForConstr cons x - -mk1M :: (Monad m, Data a, Typeable1 t) => (forall d . Data d => t d -> m (t d)) -> a -> m a -mk1M = ext1M return - diff --git a/pass/Traversal.hs b/pass/Traversal.hs index e94833e..92a2020 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -18,98 +18,183 @@ with this program. If not, see . -- | Traversal strategies over the AST and other data types. module Traversal ( - ExplicitTrans, Transform, Check - , transformToExplicitDepth, checkToTransform - , baseX, extX, extD, extC, applyX - , applyDepthM, applyDepthM2 + OpsM, Ops + , TransformM, Transform + , CheckM, Check + , baseOp, extOp, extOpS + , makeDepth, extOpD, extOpSD + , makeCheck, extOpC + , RecurseM, Recurse, makeRecurse + , DescendM, Descend, makeDescend + , applyDepthM, applyDepthSM, applyDepthM2 , checkDepthM, checkDepthM2 ) where import Data.Generics +import qualified AST as A import GenericUtils -import NavAST import Pass --- | A transformation for a single 'Data' type with explicit descent. --- The first argument passed is a function that can be called to explicitly --- descend into a generic value. -type ExplicitTrans t = (forall s. Data s => s -> PassM s) -> t -> PassM t +-- | A set of generic operations. +type OpsM m = ([TypeKey], DescendM m -> RecurseM m) --- | A transformation for a single 'Data' type with implicit descent. --- This can be applied recursively throughout a data structure. -type Transform t = t -> PassM t +-- | As 'OpsM', but specialised for 'PassM'. +type Ops = OpsM PassM --- | A check for a single 'Data' type with implicit descent. +-- | A transformation for a single 'Data' type. +type TransformM m t = t -> m t + +-- | As 'TransformM', but specialised for 'PassM'. +type Transform t = TransformM PassM t + +-- | A check for a single 'Data' type. -- This is like 'Transform', but it doesn't change the value; it may fail or -- modify the state, though. -type Check t = t -> PassM () +type CheckM m t = t -> m () --- | Make an 'ExplicitTrans' that applies a 'Transform', recursing depth-first. -transformToExplicitDepth :: Data t => Transform t -> ExplicitTrans t -transformToExplicitDepth f descend x = descend x >>= f +-- | As 'CheckM', but specialised for 'PassM'. +type Check t = CheckM PassM t --- | Make a 'Transform' that applies a 'Check'. -checkToTransform :: Data t => Check t -> Transform t -checkToTransform f x = f x >> return x +-- | An empty set of operations. +baseOp :: forall m. Monad m => OpsM m +baseOp = ([], id) --- | A set of generic transformations. -type InfoX = ([TypeKey], - (forall dgt. Data dgt => dgt -> PassM dgt) - -> (forall t1. Data t1 => t1 -> PassM t1) - -> (forall t2. Data t2 => t2 -> PassM t2)) +-- | Add a 'TransformM' to a set, to be applied with explicit descent +-- (that is, the transform will be responsible for recursing into child +-- elements itself). +extOp :: forall m t. (Monad m, Data t) => OpsM m -> TransformM m t -> OpsM m +extOp (tks, g) f = ((typeKey (undefined :: t)) : tks, + (\descend -> g descend `extM` f)) --- | An empty set of transformations. -baseX :: InfoX -baseX = ([], (\doGeneric t -> t)) +-- | As 'extOp', but for transformations that work on all 'A.Structured' types. +extOpS :: forall m. Monad m => + OpsM m + -> (forall t. Data t => TransformM m (A.Structured t)) + -> OpsM m +extOpS ops f + = ops + `extOp` (f :: TransformM m (A.Structured A.Variant)) + `extOp` (f :: TransformM m (A.Structured A.Process)) + `extOp` (f :: TransformM m (A.Structured A.Option)) + `extOp` (f :: TransformM m (A.Structured A.ExpressionList)) + `extOp` (f :: TransformM m (A.Structured A.Choice)) + `extOp` (f :: TransformM m (A.Structured A.Alternative)) + `extOp` (f :: TransformM m (A.Structured ())) --- | Add an 'ExplicitTrans' to a set. -extX :: forall t. Data t => InfoX -> ExplicitTrans t -> InfoX -extX (tks, g) f = ((typeKey (undefined :: t)) : tks, - (\doGeneric t -> (g doGeneric t) `extM` (f doGeneric))) +-- | Generate an operation that applies a 'TransformM' with automatic +-- depth-first descent. +makeDepth :: (Monad m, Data t) => OpsM m -> TransformM m t -> TransformM m t +makeDepth ops f v = descend v >>= f + where + descend = makeDescend ops --- | Add a 'Transform' to a set, to be applied depth-first. -extD :: forall t. Data t => InfoX -> Transform t -> InfoX -extD info f = extX info (transformToExplicitDepth f) +-- | Add a 'TransformM' to a set, to be applied with automatic depth-first +-- descent. +extOpD :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> TransformM m t -> OpsM m +extOpD ops ops0 f = ops `extOp` (makeDepth ops0 f) --- | Add a 'Check' to a set, to be applied depth-first. -extC :: forall t. Data t => InfoX -> Check t -> InfoX -extC info f = extD info (checkToTransform f) +-- | As 'extOpD', but for transformations that work on all 'A.Structured' types. +extOpSD :: forall m. Monad m => + OpsM m + -> OpsM m + -> (forall t. Data t => TransformM m (A.Structured t)) + -> OpsM m +extOpSD ops ops0 f = ops `extOpS` (makeDepth ops0 f) --- | Apply a set of transformations. -applyX :: Data s => InfoX -> s -> PassM s -applyX info@(tks, maker) = trans +-- | Generate an operation that applies a 'CheckM' with automatic +-- depth-first descent. +makeCheck :: (Monad m, Data t) => OpsM m -> CheckM m t -> TransformM m t +makeCheck ops f v = descend v >> f v >> return v + where + descend = makeDescend ops + +-- | Add a 'CheckM' to a set, to be applied with automatic depth-first descent. +extOpC :: forall m t. (Monad m, Data t) => OpsM m -> OpsM m -> CheckM m t -> OpsM m +extOpC ops ops0 f = ops `extOp` (makeCheck ops0 f) + +-- | A function that applies a generic operation. +-- This applies the operations in the set to the provided value. +-- +-- This is the type of function that you want to use to apply a generic +-- operation; a pass in Tock is usually the application of a 'RecurseM' to the +-- AST. It's also what you should use when you're writing a pass that uses +-- explicit descent, and you want to explicitly recurse into one of the +-- children of a value that one of your transformations has been applied to. +type RecurseM m = (forall t. Data t => t -> m t) + +-- | As 'RecurseM', but specialised for 'PassM'. +type Recurse = RecurseM PassM + +-- | Build a 'RecurseM' function from a set of operations. +makeRecurse :: forall m. Monad m => OpsM m -> RecurseM m +makeRecurse ops@(_, f) = f descend + where + descend :: DescendM m + descend = makeDescend ops + +-- | A function that applies a generic operation. +-- This applies the operations in the set to the immediate children of the +-- provided value, but not to the value itself. +-- +-- You should use this type of operation when you're writing a traversal with +-- explicit descent, and you want to descend into all the children of a value +-- that one of your transformations has been applied to. +type DescendM m = (forall t. Data t => t -> m t) + +-- | As 'DescendM', but specialised for 'PassM'. +type Descend = DescendM PassM + +-- | Build a 'DescendM' function from a set of operations. +makeDescend :: forall m. Monad m => OpsM m -> DescendM m +makeDescend ops@(tks, _) = gmapMFor ts recurse where ts :: TypeSet ts = makeTypeSet tks - trans :: Data s => s -> PassM s - trans = maker doGeneric doGeneric - - doGeneric :: Data t => t -> PassM t - doGeneric = gmapMFor ts trans + recurse :: RecurseM m + recurse = makeRecurse ops -- | Apply a transformation, recursing depth-first. -applyDepthM :: forall t1 s. (Data t1, Data s) => - Transform t1 -> s -> PassM s -applyDepthM f1 - = applyX $ baseX `extD` f1 +applyDepthM :: forall m t1 s. (Monad m, Data t1, Data s) => + TransformM m t1 -> s -> m s +applyDepthM f1 = makeRecurse ops + where + ops :: OpsM m + ops = baseOp `extOp` makeDepth ops f1 + +-- | As 'applyDepthM', but for transformations that work on all 'A.Structured' +-- types. +applyDepthSM :: forall m s. (Monad m, Data s) => + (forall t. Data t => TransformM m (A.Structured t)) -> s -> m s +applyDepthSM f1 = makeRecurse ops + where + ops :: OpsM m + ops = extOpSD baseOp ops f1 -- | Apply two transformations, recursing depth-first. -applyDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) => - Transform t1 -> Transform t2 -> s -> PassM s -applyDepthM2 f1 f2 - = applyX $ baseX `extD` f1 `extD` f2 +applyDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) => + TransformM m t1 -> TransformM m t2 -> s -> m s +applyDepthM2 f1 f2 = makeRecurse ops + where + ops :: OpsM m + ops = baseOp `extOp` makeDepth ops f1 + `extOp` makeDepth ops f2 -- | Apply a check, recursing depth-first. -checkDepthM :: forall t1 s. (Data t1, Data s) => - Check t1 -> s -> PassM s -checkDepthM f1 - = applyX $ baseX `extC` f1 +checkDepthM :: forall m t1 s. (Monad m, Data t1, Data s) => + CheckM m t1 -> s -> m s +checkDepthM f1 = makeRecurse ops + where + ops :: OpsM m + ops = baseOp `extOp` makeCheck ops f1 -- | Apply two checks, recursing depth-first. -checkDepthM2 :: forall t1 t2 s. (Data t1, Data t2, Data s) => - Check t1 -> Check t2 -> s -> PassM s -checkDepthM2 f1 f2 - = applyX $ baseX `extC` f1 `extC` f2 +checkDepthM2 :: forall m t1 t2 s. (Monad m, Data t1, Data t2, Data s) => + CheckM m t1 -> CheckM m t2 -> s -> m s +checkDepthM2 f1 f2 = makeRecurse ops + where + ops :: OpsM m + ops = baseOp `extOp` makeCheck ops f1 + `extOp` makeCheck ops f2 diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 849ba17..9fab435 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -20,7 +20,6 @@ with this program. If not, see . module SimplifyComms where import Control.Monad.State -import Data.Generics import Data.List import qualified AST as A @@ -28,6 +27,7 @@ import CompState import Metadata import Pass import qualified Properties as Prop +import Traversal import Types import Utils @@ -38,12 +38,9 @@ simplifyComms = makePassesDep ,("Flatten sequential protocol inputs into multiple inputs", transformProtocolInput, Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved], [Prop.seqInputsFlattened]) ] -outExprs :: Data t => t -> PassM t -outExprs = doGeneric `extM` doProcess +outExprs :: PassType +outExprs = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric outExprs - doProcess :: A.Process -> PassM A.Process doProcess (A.Output m c ois) = do (ois', specs) <- mapAndUnzipM changeItem ois @@ -53,7 +50,7 @@ outExprs = doGeneric `extM` doProcess = do (ois', specs) <- mapAndUnzipM changeItem ois let foldedSpec = foldFuncs specs return $ A.Seq m (foldedSpec $ A.Only m $ A.OutputCase m c tag ois') - doProcess p = doGeneric p + doProcess p = return p changeItem :: A.OutputItem -> PassM (A.OutputItem, A.Structured A.Process -> A.Structured A.Process) changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e @@ -133,12 +130,9 @@ ALT -- process D -} -transformInputCase :: Data t => t -> PassM t -transformInputCase = doGeneric `extM` doProcess +transformInputCase :: PassType +transformInputCase = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformInputCase - doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputCase m' s)) = do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original @@ -149,15 +143,14 @@ transformInputCase = doGeneric `extM` doProcess doProcess (A.Alt m pri s) = do s' <- doStructuredA s return (A.Alt m pri s') - doProcess p = doGeneric p + doProcess p = return p -- Can't easily use generics here as we're switching from one type of Structured to another doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option) -- These entries all just burrow deeper into the structured: doStructuredV v (A.ProcThen m p s) = do s' <- doStructuredV v s - p' <- doProcess p - return (A.ProcThen m p' s') + return (A.ProcThen m p s') doStructuredV v (A.Spec m sp st) = do st' <- doStructuredV v st return (A.Spec m sp st') @@ -171,20 +164,18 @@ transformInputCase = doGeneric `extM` doProcess doStructuredV chanVar (A.Only m (A.Variant m' n iis p)) = do (Right items) <- protocolItems chanVar let (Just idx) = elemIndex n (fst $ unzip items) - p' <- doProcess p return $ A.Only m $ A.Option m' [makeConstant m' idx] $ if (length iis == 0) - then p' + then p else A.Seq m' $ A.Several m' - [A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis) - ,A.Only (findMeta p') p'] + [A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis), + A.Only (findMeta p) p] doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative) - -- TODO use generics instead of this boilerplate, but don't omit the doProcess call in ProcThen! + -- TODO use generics instead of this boilerplate doStructuredA (A.ProcThen m p s) = do s' <- doStructuredA s - p' <- doProcess p - return (A.ProcThen m p' s') + return (A.ProcThen m p s') doStructuredA (A.Spec m sp st) = do st' <- doStructuredA st return (A.Spec m sp st') @@ -206,22 +197,18 @@ transformInputCase = doGeneric `extM` doProcess -- Leave other guards (and parts of Structured) untouched: doStructuredA s = return s -transformProtocolInput :: Data t => t -> PassM t -transformProtocolInput = doGeneric `extM` doProcess `extM` doAlternative +transformProtocolInput :: PassType +transformProtocolInput = applyDepthM2 doProcess doAlternative where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformProtocolInput - doProcess :: A.Process -> PassM A.Process doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_))) = return $ A.Seq m $ A.Several m $ map (A.Only m . A.Input m v . A.InputSimple m' . singleton) iis - doProcess p = doGeneric p + doProcess p = return p doAlternative :: A.Alternative -> PassM A.Alternative doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_)))) body) - = do body' <- doProcess body - return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $ + = return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $ map (A.Only m' . A.Input m' v . A.InputSimple m' . singleton) otherIIS - ++ [A.Only m' body'] - doAlternative s = doGeneric s + ++ [A.Only m' body] + doAlternative s = return s diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index 3d77a0c..030fbe8 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -31,6 +31,7 @@ import Metadata import Pass import qualified Properties as Prop import ShowCode +import Traversal import Types import Utils @@ -48,12 +49,9 @@ simplifyExprs = makePassesDep -- ++ makePassesDep' ((== BackendCPPCSP) . csBackend) [("Pull up definitions (C++)", pullUp True, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.functionsRemoved, Prop.processTypesChecked,Prop.seqInputsFlattened], [Prop.functionCallsRemoved, Prop.subscriptsPulledUp])] -- | Convert FUNCTION declarations to PROCs. -functionsToProcs :: Data t => t -> PassM t -functionsToProcs = doGeneric `extM` doSpecification +functionsToProcs :: PassType +functionsToProcs = applyDepthM doSpecification where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric functionsToProcs - doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Function mf sm rts fs evp)) = do -- Create new names for the return values. @@ -76,8 +74,8 @@ functionsToProcs = doGeneric `extM` doSpecification A.ndPlacement = A.Unplaced } defineName n nd - doGeneric spec - doSpecification s = doGeneric s + return spec + doSpecification s = return s vpToSeq :: Meta -> A.Name -> Either (A.Structured A.ExpressionList) A.Process -> [A.Variable] -> A.Process vpToSeq m n (Left el) vs = A.Seq m $ vpToSeq' el vs @@ -101,40 +99,32 @@ functionsToProcs = doGeneric `extM` doSpecification -- | Convert AFTER expressions to the equivalent using MINUS (which is how the -- occam 3 manual defines AFTER). -removeAfter :: Data t => t -> PassM t -removeAfter = doGeneric `extM` doExpression +removeAfter :: PassType +removeAfter = applyDepthM doExpression where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric removeAfter - doExpression :: A.Expression -> PassM A.Expression doExpression (A.Dyadic m A.After a b) - = do a' <- removeAfter a - b' <- removeAfter b - t <- astTypeOf a' + = do t <- astTypeOf a case t of A.Byte -> do let one = A.Literal m t $ A.IntLiteral m "1" oneTwoSeven = A.Literal m t $ A.IntLiteral m "127" - return $ A.Dyadic m A.Less (A.Dyadic m A.Minus (A.Dyadic m A.Minus a' b') one) oneTwoSeven + return $ A.Dyadic m A.Less (A.Dyadic m A.Minus (A.Dyadic m A.Minus a b) one) oneTwoSeven _ -> do let zero = A.Literal m t $ A.IntLiteral m "0" - return $ A.Dyadic m A.More (A.Dyadic m A.Minus a' b') zero - doExpression e = doGeneric e + return $ A.Dyadic m A.More (A.Dyadic m A.Minus a b) zero + doExpression e = return e --- | For array literals that include other arrays, burst them into their elements. -expandArrayLiterals :: Data t => t -> PassM t -expandArrayLiterals = doGeneric `extM` doArrayElem +-- | For array literals that include other arrays, burst them into their +-- elements. +expandArrayLiterals :: PassType +expandArrayLiterals = applyDepthM doArrayElem where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric expandArrayLiterals - doArrayElem :: A.ArrayElem -> PassM A.ArrayElem doArrayElem ae@(A.ArrayElemExpr e) - = do e' <- expandArrayLiterals e - t <- astTypeOf e' + = do t <- astTypeOf e case t of A.Array ds _ -> expand ds e - _ -> doGeneric ae - doArrayElem ae = doGeneric ae + _ -> return ae + doArrayElem ae = return ae expand :: [A.Dimension] -> A.Expression -> PassM A.ArrayElem expand [] e = return $ A.ArrayElemExpr e @@ -159,26 +149,21 @@ expandArrayLiterals = doGeneric `extM` doArrayElem -- Therefore, we only need to pull up the counts for sequential replicators -- -- TODO for simplification, we could avoid pulling up replication counts that are known to be constants -pullRepCounts :: Data t => t -> PassM t -pullRepCounts = doGeneric `extM` doProcess +pullRepCounts :: PassType +pullRepCounts = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric pullRepCounts - doProcess :: A.Process -> PassM A.Process doProcess (A.Seq m s) = pullRepCountSeq s >>* A.Seq m - doProcess p = doGeneric p + doProcess p = return p pullRepCountSeq :: A.Structured A.Process -> PassM (A.Structured A.Process) - pullRepCountSeq (A.Only m p) = doProcess p >>* A.Only m + pullRepCountSeq s@(A.Only _ _) = return s pullRepCountSeq (A.Spec m sp str) - = do sp' <- pullRepCounts sp - str' <- pullRepCountSeq str - return $ A.Spec m sp' str' + = do str' <- pullRepCountSeq str + return $ A.Spec m sp str' pullRepCountSeq (A.ProcThen m p s) - = do p' <- doProcess p - s' <- pullRepCountSeq s - return $ A.ProcThen m p' s' + = do s' <- pullRepCountSeq s + return $ A.ProcThen m p s' pullRepCountSeq (A.Several m ss) = mapM pullRepCountSeq ss >>* A.Several m pullRepCountSeq (A.Rep m (A.For m' n from for) s) = do t <- astTypeOf for @@ -190,12 +175,9 @@ pullRepCounts = doGeneric `extM` doProcess = do s' <- pullRepCountSeq s return $ A.Rep m rep s' -transformConstr :: Data t => t -> PassM t -transformConstr = doGeneric `ext1M` doStructured +transformConstr :: PassType +transformConstr = applyDepthSM doStructured where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric transformConstr - -- For arrays, this takes a constructor expression: -- VAL type name IS [i = rep | expr]: -- ... @@ -218,8 +200,7 @@ transformConstr = doGeneric `ext1M` doStructured -- name += [expr] doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _ expr@(A.ExprConstr m'' (A.RepConstr _ t rep exp)))) scope) - = do scope' <- transformConstr scope - case t of + = do case t of A.Array {} -> do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.VariableName A.Original let indexVar = A.Variable m'' indexName @@ -232,11 +213,11 @@ transformConstr = doGeneric `ext1M` doStructured [ assignItem indexVar , incrementIndex indexVar ] ]) - scope' + scope A.List {} -> return $ declDest $ A.ProcThen m'' (A.Seq m'' $ A.Rep m'' rep $ appendItem) - scope' + scope _ -> diePC m $ formatCode "Unsupported type for array constructor: %" t where declDest :: Data a => A.Structured a -> A.Structured a @@ -261,26 +242,26 @@ transformConstr = doGeneric `ext1M` doStructured (A.ExprVariable m'' $ A.Variable m'' n) (A.Literal m'' t $ A.ListLiteral m'' [exp])] - doStructured s = doGeneric s + doStructured s = return s -- | Find things that need to be moved up to their enclosing Structured, and do -- so. -pullUp :: Data t => Bool -> t -> PassM t -pullUp pullUpArraysInsideRecords - = doGeneric - `ext1M` doStructured - `extM` doProcess - `extM` doSpecification - `extM` doLiteralRepr - `extM` doExpression - `extM` doVariable - `extM` doExpressionList +pullUp :: Bool -> PassType +pullUp pullUpArraysInsideRecords = recurse where - pullUpRecur :: Data t => t -> PassM t - pullUpRecur = pullUp pullUpArraysInsideRecords - - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric pullUpRecur + ops :: Ops + ops = baseOp + `extOpS` doStructured + `extOp` doProcess + `extOp` doSpecification + `extOp` doLiteralRepr + `extOp` doExpression + `extOp` doVariable + `extOp` doExpressionList + recurse :: Recurse + recurse = makeRecurse ops + descend :: Descend + descend = makeDescend ops -- | When we encounter a Structured, create a new pulled items state, -- recurse over it, then apply whatever pulled items we found to it. @@ -288,7 +269,7 @@ pullUp pullUpArraysInsideRecords doStructured s = do pushPullContext -- Recurse over the body, then apply the pulled items to it - s' <- doGeneric s >>= applyPulled + s' <- descend s >>= applyPulled -- ... and restore the original pulled items popPullContext return s' @@ -298,7 +279,7 @@ pullUp pullUpArraysInsideRecords doProcess :: A.Process -> PassM A.Process doProcess p = do pushPullContext - p' <- doGeneric p + p' <- descend p pulled <- havePulled p'' <- if pulled then liftM (A.Seq emptyMeta) $ applyPulled (A.Only emptyMeta p') @@ -310,11 +291,11 @@ pullUp pullUpArraysInsideRecords doSpecification :: A.Specification -> PassM A.Specification -- Iss might be SubscriptedVars -- which is fine; the backend can deal with that. doSpecification (A.Specification m n (A.Is m' am t v)) - = do v' <- doGeneric v -- note doGeneric rather than pullUp + = do v' <- descend v -- note descend rather than pullUp return $ A.Specification m n (A.Is m' am t v') -- IsExprs might be SubscriptedExprs, and if so we have to convert them. doSpecification (A.Specification m n (A.IsExpr m' am t e)) - = do e' <- doExpression' e -- note doExpression' rather than pullUp + = do e' <- doExpression' e -- note doExpression' rather than recurse return $ A.Specification m n (A.IsExpr m' am t e') -- Convert RetypesExpr into Retypes of a variable. doSpecification (A.Specification m n (A.RetypesExpr m' am toT e)) @@ -323,7 +304,7 @@ pullUp pullUpArraysInsideRecords spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e' addPulled $ (m', Left spec) return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n')) - doSpecification s = doGeneric s + doSpecification s = descend s -- | Filter what can be pulled in LiteralReprs. doLiteralRepr :: A.LiteralRepr -> PassM A.LiteralRepr @@ -331,9 +312,9 @@ pullUp pullUpArraysInsideRecords -- for nested array literals. -- Don't pull up array expressions that are fields of record literals. doLiteralRepr (A.RecordLiteral m es) - = do es' <- mapM (if pullUpArraysInsideRecords then doExpression else doExpression') es -- note doExpression' rather than pullUp + = do es' <- mapM (if pullUpArraysInsideRecords then doExpression else doExpression') es -- note doExpression' rather than recurse return $ A.RecordLiteral m es' - doLiteralRepr lr = doGeneric lr + doLiteralRepr lr = descend lr -- | Pull array expressions that aren't already non-subscripted variables. -- Also pull lists that are literals or constructed @@ -366,7 +347,7 @@ pullUp pullUpArraysInsideRecords -- | Pull any variable subscript that results in an array. doVariable :: A.Variable -> PassM A.Variable doVariable v@(A.SubscriptedVariable m _ _) - = do v' <- doGeneric v + = do v' <- descend v t <- astTypeOf v' case t of A.Array _ _ -> @@ -376,12 +357,12 @@ pullUp pullUpArraysInsideRecords addPulled $ (m, Left spec) return $ A.Variable m n _ -> return v' - doVariable v = doGeneric v + doVariable v = descend v -- | Convert a FUNCTION call into some variables and a PROC call. convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable] convertFuncCall m n es - = do es' <- pullUpRecur es + = do es' <- recurse es ets <- sequence [astTypeOf e | e <- es'] ps <- get @@ -403,18 +384,18 @@ pullUp pullUpArraysInsideRecords return $ A.ExprVariable m v -- Convert SubscriptedExprs into SubscriptedVariables. doExpression' (A.SubscriptedExpr m s e) - = do e' <- pullUpRecur e - s' <- pullUpRecur s + = do e' <- recurse e + s' <- recurse s t <- astTypeOf e' spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e' addPulled $ (m, Left spec) return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n)) - doExpression' e = doGeneric e + doExpression' e = descend e doExpressionList :: A.ExpressionList -> PassM A.ExpressionList -- Convert multi-valued function calls. doExpressionList (A.FunctionCallList m n es) = do vs <- convertFuncCall m n es return $ A.ExpressionList m [A.ExprVariable m v | v <- vs] - doExpressionList el = doGeneric el + doExpressionList el = descend el diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 084298a..e8249f6 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -28,6 +28,7 @@ import CompState import Metadata import Pass import qualified Properties as Prop +import Traversal import Types simplifyProcs :: [Pass] @@ -38,47 +39,37 @@ simplifyProcs = makePassesDep ] -- | Wrap the subprocesses of PARs in no-arg PROCs. -parsToProcs :: Data t => t -> PassM t -parsToProcs = doGeneric `extM` doProcess +parsToProcs :: PassType +parsToProcs = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric parsToProcs - doProcess :: A.Process -> PassM A.Process doProcess (A.Par m pm s) = do s' <- doStructured s return $ A.Par m pm s' - doProcess p = doGeneric p + doProcess p = return p -- FIXME This should be generic and in Pass. doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process) doStructured (A.Rep m r s) - = do r' <- parsToProcs r - s' <- doStructured s - return $ A.Rep m r' s' + = do s' <- doStructured s + return $ A.Rep m r s' doStructured (A.Spec m spec s) - = do spec' <- parsToProcs spec - s' <- doStructured s - return $ A.Spec m spec' s' + = do s' <- doStructured s + return $ A.Spec m spec s' doStructured (A.ProcThen m p s) - = do p' <- parsToProcs p - s' <- doStructured s - return $ A.ProcThen m p' s' + = do s' <- doStructured s + return $ A.ProcThen m p s' doStructured (A.Only m p) - = do p' <- parsToProcs p - s@(A.Specification _ n _) <- makeNonceProc m p' + = do s@(A.Specification _ n _) <- makeNonceProc m p modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) }) return $ A.Spec m s (A.Only m (A.ProcCall m n [])) doStructured (A.Several m ss) = liftM (A.Several m) $ mapM doStructured ss -- | Turn parallel assignment into multiple single assignments through temporaries. -removeParAssign :: Data t => t -> PassM t -removeParAssign = doGeneric `extM` doProcess +removeParAssign :: PassType +removeParAssign = applyDepthM doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric removeParAssign - doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es)) = do ts <- mapM astTypeOf vs @@ -87,27 +78,26 @@ removeParAssign = doGeneric `extM` doProcess let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es] let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps] return $ A.Seq m $ foldl (\s spec -> A.Spec m spec s) (A.Several m (map (A.Only m) (first ++ second))) specs - doProcess p = doGeneric p + doProcess p = return p -- | Turn assignment of arrays and records into multiple assignments. -flattenAssign :: Data t => t -> PassM t -flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured +flattenAssign :: PassType +flattenAssign = makeRecurse ops where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric flattenAssign + ops :: Ops + ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess doProcess :: A.Process -> PassM A.Process doProcess (A.Assign m [v] (A.ExpressionList m' [e])) = do t <- astTypeOf v assign m t v m' e - doProcess p = doGeneric p - + doProcess p = return p + doStructured :: Data a => A.Structured a -> PassM (A.Structured a) doStructured (A.Spec m (A.Specification m' n t@(A.RecordType _ _ fs)) s) = do procSpec <- recordCopyProc n m fs - s' <- doStructured s - return $ A.Spec m (A.Specification m' n t) (procSpec s') - doStructured s = doGeneric s + return $ A.Spec m (A.Specification m' n t) (procSpec s) + doStructured s = return s assign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process assign m t@(A.Array _ _) v m' e = complexAssign m t v m' e diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs index c94d9b1..d8c2fe4 100644 --- a/transformations/SimplifyTypes.hs +++ b/transformations/SimplifyTypes.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -20,13 +20,13 @@ with this program. If not, see . module SimplifyTypes (simplifyTypes) where import Control.Monad.State -import Data.Generics import qualified Data.Set as Set import qualified AST as A import Metadata import Pass import qualified Properties as Prop +import Traversal import Types simplifyTypes :: [Pass] @@ -41,12 +41,9 @@ resolveAllNamedTypes = Pass ,passEnabled = const True} -- | Turn named data types into their underlying types. -resolveNamedTypes :: Data t => t -> PassM t -resolveNamedTypes = doGeneric `extM` doType +resolveNamedTypes :: PassType +resolveNamedTypes = applyDepthM doType where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric resolveNamedTypes - doType :: A.Type -> PassM A.Type doType t@(A.UserDataType _) = underlyingType emptyMeta t - doType t = doGeneric t + doType t = return t diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index 7076545..abf1b36 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -19,6 +19,7 @@ with this program. If not, see . -- | Flatten nested declarations. module Unnest (unnest) where +import Control.Monad.Identity import Control.Monad.State import Data.Generics import Data.List @@ -32,6 +33,7 @@ import EvalConstants import Metadata import Pass import qualified Properties as Prop +import Traversal import Types unnest :: [Pass] @@ -86,33 +88,21 @@ freeNamesIn = doGeneric -- | Replace names. replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t -replaceNames map = doGeneric `extT` doName +replaceNames map v = runIdentity $ applyDepthM doName v where - doGeneric :: Data t => t -> t - doGeneric = (gmapT (replaceNames map)) - `extT` (id :: String -> String) - `extT` (id :: Meta -> Meta) - smap = [(A.nameName f, t) | (f, t) <- map] + smap = Map.fromList [(A.nameName f, t) | (f, t) <- map] - doName :: A.Name -> A.Name - doName n - = case lookup (A.nameName n) smap of - Just n' -> n' - Nothing -> n + doName :: A.Name -> Identity A.Name + doName n = return $ Map.findWithDefault n (A.nameName n) smap -- | Turn free names in PROCs into arguments. -removeFreeNames :: Data t => t -> PassM t -removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess +removeFreeNames :: PassType +removeFreeNames = applyDepthM2 doSpecification doProcess where - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric removeFreeNames - doSpecification :: A.Specification -> PassM A.Specification doSpecification spec = case spec of - A.Specification m n st@(A.Proc _ _ _ _) -> - do st'@(A.Proc mp sm fs p) <- removeFreeNames st - - -- If this is the top-level process, we shouldn't add new args -- + A.Specification m n st@(A.Proc mp sm fs p) -> + do -- If this is the top-level process, we shouldn't add new args -- -- we know it's not going to be moved by removeNesting, so anything -- that it had in scope originally will still be in scope. ps <- get @@ -120,7 +110,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess let isTLP = (snd $ head $ csMainLocals ps) == n -- Figure out the free names. - let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st' + let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st let freeNames'' = [n | n <- freeNames', case A.nameType n of A.ChannelName -> True @@ -145,12 +135,12 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess -- Add formals for each of the free names let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames] - let st'' = A.Proc mp sm (fs ++ newFs) $ replaceNames (zip freeNames newNames) p - let spec' = A.Specification m n st'' + let st' = A.Proc mp sm (fs ++ newFs) $ replaceNames (zip freeNames newNames) p + let spec' = A.Specification m n st' -- Update the definition of the proc nameDef <- lookupName n - defineName n (nameDef { A.ndSpecType = st'' }) + defineName n (nameDef { A.ndSpecType = st' }) -- Note that we should add extra arguments to calls of this proc -- when we find them @@ -163,42 +153,43 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) }) return spec' - _ -> doGeneric spec + _ -> return spec -- | Add the extra arguments we recorded when we saw the definition. doProcess :: A.Process -> PassM A.Process doProcess p@(A.ProcCall m n as) = do st <- get case Map.lookup (A.nameName n) (csAdditionalArgs st) of - Just add -> doGeneric $ A.ProcCall m n (as ++ add) - Nothing -> doGeneric p - doProcess p = doGeneric p + Just add -> return $ A.ProcCall m n (as ++ add) + Nothing -> return p + doProcess p = return p -- | Pull nested declarations to the top level. -removeNesting :: forall a. Data a => A.Structured a -> PassM (A.Structured a) -removeNesting p +removeNesting :: Data t => Transform (A.Structured t) +removeNesting s = do pushPullContext - p' <- pullSpecs p - s <- applyPulled p' + s' <- (makeRecurse ops) s >>= applyPulled popPullContext - return s + return s' where - pullSpecs :: Data t => t -> PassM t - pullSpecs = doGeneric `ext1M` doStructured + ops :: Ops + ops = baseOp `extOpS` doStructured - doGeneric :: Data t => t -> PassM t - doGeneric = makeGeneric pullSpecs + recurse :: Recurse + recurse = makeRecurse ops + descend :: Descend + descend = makeDescend ops - doStructured :: Data t => A.Structured t -> PassM (A.Structured t) - doStructured s@(A.Spec m spec@(A.Specification _ n st) subS) - = do isConst <- isConstantName n + doStructured :: Data t => Transform (A.Structured t) + doStructured s@(A.Spec m spec subS) + = do spec'@(A.Specification _ n st) <- recurse spec + isConst <- isConstantName n if isConst || canPull st then do debug $ "removeNesting: pulling up " ++ show n - spec' <- doGeneric spec addPulled $ (m, Left spec') doStructured subS - else doGeneric s - doStructured s = doGeneric s + else descend s + doStructured s = descend s canPull :: A.SpecType -> Bool canPull (A.Proc _ _ _ _) = True