From 738b84dc9a8b09d35da80353f1a010bf283c111f Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 20 Jul 2001 10:09:32 +0000 Subject: [PATCH] [project @ 2001-07-20 10:09:32 by simonpj] Third cut at the demand analyser; seems to work nicely now --- ghc/compiler/stranal/DmdAnal.lhs | 200 +++++++++++++++++++++++++------------- 1 file changed, 134 insertions(+), 66 deletions(-) diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index f13b363..1f5a3bc 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -25,7 +25,7 @@ import IdInfo ( newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, import Var ( Var ) import VarEnv import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, - keysUFM, minusUFM, ufmToList ) + keysUFM, minusUFM, ufmToList, filterUFM ) import Type ( isUnLiftedType ) import CoreLint ( showPass, endPass ) import ErrUtils ( dumpIfSet_dyn ) @@ -78,13 +78,13 @@ dmdAnalTopBind sigs (NonRec id rhs) = (sigs, NonRec id rhs) -- It's pre-computed in MkId.lhs | otherwise = let - (sigs', (id', rhs')) = downRhs TopLevel sigs (id, rhs) + (sigs', _, (id', rhs')) = downRhs TopLevel sigs (id, rhs) in (sigs', NonRec id' rhs') dmdAnalTopBind sigs (Rec pairs) = let - (sigs', pairs') = dmdFix TopLevel sigs pairs + (sigs', _, pairs') = dmdFix TopLevel sigs pairs in (sigs', Rec pairs') \end{code} @@ -148,17 +148,20 @@ dmdAnal sigs dmd (Lam var body) in (body_ty, Lam var body') - | otherwise - = let - body_dmd = case dmd of - Call dmd -> dmd - other -> Lazy -- Conservative - + | Call body_dmd <- dmd -- A call demand: good! + = let (body_ty, body') = dmdAnal sigs body_dmd body - (lam_ty, var') = annotateLamIdBndr body_ty var + (lam_ty, var') = annotateLamIdBndr body_ty var in (lam_ty, Lam var' body') + | otherwise -- Not enough demand on the lambda; but do the body + = let -- anyway to annotate it and gather free var info + (body_ty, body') = dmdAnal sigs Eval body + (lam_ty, var') = annotateLamIdBndr body_ty var + in + (deferType lam_ty, Lam var' body') + dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) | let tycon = dataConTyCon dc, isProductTyCon tycon, @@ -184,37 +187,30 @@ dmdAnal sigs dmd (Case scrut case_bndr alts) dmdAnal sigs dmd (Let (NonRec id rhs) body) = let - (sigs', (id1, rhs')) = downRhs NotTopLevel sigs (id, rhs) - (body_ty, body') = dmdAnal sigs' dmd body - (body_ty1, id2) = annotateBndr body_ty id1 + (sigs', lazy_fv, (id1, rhs')) = downRhs NotTopLevel sigs (id, rhs) + (body_ty, body') = dmdAnal sigs' dmd body + (body_ty1, id2) = annotateBndr body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv in -- pprTrace "dmdLet" (ppr id <+> ppr (sig,rhs_env)) - (body_ty1, Let (NonRec id2 rhs') body') + (body_ty2, Let (NonRec id2 rhs') body') dmdAnal sigs dmd (Let (Rec pairs) body) = let - bndrs = map fst pairs - (sigs', pairs') = dmdFix NotTopLevel sigs pairs - (body_ty, body') = dmdAnal sigs' dmd body - - -- I saw occasions where it was really worth using the - -- call demands on the Ids to propagate demand info - -- on the free variables. An example is 'roll' in imaginary/wheel-sieve2 - -- Something like this: - -- roll x = letrec go y = if ... then roll (x-1) else x+1 - -- in go ms - -- We want to see that this is strict in x. - -- - -- This will happen because sigs' has a binding for 'go' that - -- has a demand on x. - - (result_ty, _) = annotateBndrs body_ty bndrs + bndrs = map fst pairs + (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs + (body_ty, body') = dmdAnal sigs' dmd body + body_ty1 = addLazyFVs body_ty lazy_fv + in + sigs' `seq` body_ty `seq` + let + (body_ty2, _) = annotateBndrs body_ty1 bndrs -- Don't bother to add demand info to recursive -- binders as annotateBndr does; -- being recursive, we can't treat them strictly. -- But we do need to remove the binders from the result demand env in - (result_ty, Let (Rec pairs') body') + (body_ty2, Let (Rec pairs') body') dmdAnalAlt sigs dmd (con,bndrs,rhs) @@ -235,7 +231,7 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs) dmdFix :: TopLevelFlag -> SigEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)] - -> (SigEnv, + -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info dmdFix top_lvl sigs pairs @@ -247,21 +243,32 @@ dmdFix top_lvl sigs pairs loop :: Int -> SigEnv -- Already contains the current sigs -> [(Id,CoreExpr)] - -> (SigEnv, [(Id,CoreExpr)]) + -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) loop n sigs pairs - | all (same_sig sigs sigs') bndrs = (sigs, pairs) - -- Note: use pairs, not pairs'. Since the sigs are the same - -- there'll be no change, unless this is the very first visit, - -- and the first iteraion of that visit. But in that case, the - -- function is bottom anyway, there's no point in looking. + | all (same_sig sigs sigs') bndrs = (sigs', lazy_fv, pairs') + -- Note: use pairs', not pairs. pairs' is the result of + -- processing the RHSs with sigs (= sigs'), whereas pairs + -- is the result of processing the RHSs with the *previous* + -- iteration of sigs. | n >= 5 = pprTrace "dmdFix" (ppr n <+> ppr pairs) (loop (n+1) sigs' pairs') | otherwise = {- pprTrace "dmdFixLoop" (ppr id_sigs) -} (loop (n+1) sigs' pairs') where -- Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed - (sigs', pairs') = mapAccumL (downRhs top_lvl) sigs pairs - + ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs + + my_downRhs top_lvl (sigs,lazy_fv) (id,rhs) + = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig)) + -- (new_sig `seq` + -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' ) + ((sigs', lazy_fv'), pair') + -- ) + where + (sigs', lazy_fv1, pair') = downRhs top_lvl sigs (id,rhs) + lazy_fv' = plusUFM_C both lazy_fv lazy_fv1 + old_sig = lookup sigs id + new_sig = lookup sigs' id -- Get an initial strictness signature from the Id -- itself. That way we make use of earlier iterations @@ -276,30 +283,65 @@ dmdFix top_lvl sigs pairs downRhs :: TopLevelFlag -> SigEnv -> (Id, CoreExpr) - -> (SigEnv, (Id, CoreExpr)) --- On the way down, compute a strictness signature --- for the function. Keep its annotated RHS and dmd env --- for use on the way up --- The demand-env is that computed for a vanilla call. + -> (SigEnv, DmdEnv, (Id, CoreExpr)) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. downRhs top_lvl sigs (id, rhs) - = (sigs', (id', rhs')) + = (sigs', lazy_fv, (id', rhs')) where - arity = exprArity rhs -- The idArity may not be up to date - (rhs_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs - sig = mkStrictSig id arity (mkSigTy rhs rhs_ty) - id' = id `setIdNewStrictness` sig - sigs' = extendSigEnv top_lvl sigs id sig - -mkSigTy rhs (DmdType fv [] RetCPR) - | not (exprIsValue rhs) = DmdType fv [] TopRes + arity = exprArity rhs -- The idArity may not be up to date + (rhs_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs + (lazy_fv, sig_ty) = mkSigTy rhs rhs_ty + sig = mkStrictSig id arity sig_ty + id' = id `setIdNewStrictness` sig + sigs' = extendSigEnv top_lvl sigs id sig + +mkSigTy rhs (DmdType fv dmds res) + = (lazy_fv, DmdType strict_fv lazified_dmds res') + where + lazy_fv = filterUFM (not . isStrictDmd) fv + strict_fv = filterUFM isStrictDmd fv + -- We put the strict FVs in the DmdType of the Id, so + -- that at its call sites we unleash demands on its strict fvs. + -- An example is 'roll' in imaginary/wheel-sieve2 + -- Something like this: + -- roll x = letrec + -- go y = if ... then roll (x-1) else x+1 + -- in + -- go ms + -- We want to see that roll is strict in x, which is because + -- go is called. So we put the DmdEnv for x in go's DmdType. + -- + -- Another example: + -- f :: Int -> Int -> Int + -- f x y = let t = x+1 + -- h z = if z==0 then t else + -- if z==1 then x+1 else + -- x + h (z-1) + -- in + -- h y + -- Calling h does indeed evaluate x, but we can only see + -- that if we unleash a demand on x at the call site for t. + -- + -- Incidentally, here's a place where lambda-lifting h would + -- lose the cigar --- we couldn't see the joint strictness in t/x + -- + -- ON THE OTHER HAND + -- We don't want to put *all* the fv's from the RHS into the + -- DmdType, because that makes fixpointing very slow --- the + -- DmdType gets full of lazy demands that are slow to converge. + + lazified_dmds = map lazify dmds + -- Get rid of defers in the arguments + + res' = case (dmds, res) of + ([], RetCPR) | not (exprIsValue rhs) -> TopRes + other -> res -- If the rhs is a thunk, we forget the CPR info, because -- it is presumably shared (else it would have been inlined, and -- so we'd lose sharing if w/w'd it into a function. -- - -- ** But keep the demand unleashed on the free - -- vars when the thing is evaluated! ** - -- -- DONE IN OLD CPR ANALYSER, BUT NOT YET HERE -- Also, if the strictness analyser has figured out that it's strict, -- the let-to-case transformation will happen, so again it's good. @@ -310,9 +352,6 @@ mkSigTy rhs (DmdType fv [] RetCPR) -- ...body strict in r... -- r's RHS isn't a value yet; but modInt returns r in various branches, so -- if r doesn't have the CPR property then neither does modInt - -mkSigTy rhs (DmdType fv dmds res) = DmdType fv (map lazify dmds) res --- Get rid of defers \end{code} @@ -329,6 +368,9 @@ addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd | isTopLevel top_lvl = dmd_ty -- Don't record top level things | otherwise = DmdType (extendVarEnv fv var dmd) ds res +addLazyFVs (DmdType fv ds res) lazy_fvs + = DmdType (plusUFM_C both fv lazy_fvs) ds res + annotateBndr :: DmdType -> Var -> (DmdType, Var) -- The returned env has the var deleted -- The returned var is annotated with demand info @@ -432,7 +474,12 @@ dmdTransform sigs var dmd ------ LOCAL LET/REC BOUND THING | Just (StrictSig arity dmd_ty, top_lvl) <- lookupVarEnv sigs var = let - fn_ty = if arity <= depth then dmd_ty else topDmdType + fn_ty | arity <= depth = dmd_ty + | otherwise = deferType dmd_ty + -- NB: it's important to use deferType, and not just return topDmdType + -- Consider let { f x y = p + x } in f 1 + -- The application isn't saturated, but we must nevertheless propagate + -- a lazy demand for p! in addVarDmd top_lvl fn_ty var dmd @@ -472,8 +519,10 @@ vanillaCall 0 = Eval vanillaCall n = Call (vanillaCall (n-1)) deferType :: DmdType -> DmdType -deferType (DmdType fv ds _) = DmdType (mapVarEnv defer fv) ds TopRes - -- Check this +deferType (DmdType fv _ _) = DmdType (mapVarEnv defer fv) [] TopRes + -- Notice that we throw away info about both arguments and results + -- For example, f = let ... in \x -> x + -- We don't want to get a stricness type V->T for f. defer :: Demand -> Demand -- c.f. `lub` Abs @@ -481,10 +530,19 @@ defer Abs = Abs defer (Seq k _ ds) = Seq k Defer ds defer other = Lazy +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd Err = True +isStrictDmd (Seq _ Now _) = True +isStrictDmd Eval = True +isStrictDmd (Call _) = True +isStrictDmd other = False + lazify :: Demand -> Demand -- The 'Defer' demands are just Lazy at function boundaries lazify (Seq k Defer ds) = Lazy lazify (Seq k Now ds) = Seq k Now (map lazify ds) +lazify Bot = Abs -- Don't pass args that are consumed by bottom lazify d = d betterDemand :: Demand -> Demand -> Bool @@ -559,7 +617,14 @@ vee k1 k2 = Keep ----------------------------------- both :: Demand -> Demand -> Demand -both Bot d = Bot +-- The normal one +-- both Bot d = Bot + +-- The experimental one +both Bot Bot = Bot +both Bot Abs = Bot +both Bot d = d + both Abs Bot = Bot both Abs d = d @@ -574,7 +639,8 @@ both Lazy Err = Lazy both Lazy (Seq k Now ds) = Seq Keep Now ds both Lazy d = d -both Eval Bot = Bot +-- Part of the Bot like Err experiment +-- both Eval Bot = Bot both Eval (Seq k l ds) = Seq Keep Now ds both Eval (Call d) = Call d both Eval d = Eval @@ -670,7 +736,9 @@ get_changes binds = vcat (map get_changes_bind binds) get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs) -get_changes_pr (id,rhs) = get_changes_var id $$ get_changes_expr rhs +get_changes_pr (id,rhs) + | isImplicitId id = empty -- We don't look inside these + | otherwise = get_changes_var id $$ get_changes_expr rhs get_changes_var var | isId var = get_changes_str var $$ get_changes_dmd var -- 1.7.10.4