X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FDmdAnal.lhs;h=afa722fa8aa24142a4d6df0d5453b792a8cd8851;hp=2a160cde39edd6f5523a003fec7acacb545b730a;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=c5b76e6f1d2151dd76a2e6477c543a4dd1efca46 diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 2a160cd..afa722f 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -18,31 +18,33 @@ import StaticFlags ( opt_MaxWorkerArgs ) import Demand -- All of it import CoreSyn import PprCore +import Coercion ( isCoVarType ) import CoreUtils ( exprIsHNF, exprIsTrivial ) import CoreArity ( exprArity ) import DataCon ( dataConTyCon, dataConRepStrictness ) import TyCon ( isProductTyCon, isRecursiveTyCon ) import Id ( Id, idType, idInlineActivation, isDataConWorkId, isGlobalId, idArity, - idStrictness, idStrictness_maybe, + idStrictness, setIdStrictness, idDemandInfo, idUnfolding, - idDemandInfo_maybe, - setIdDemandInfo + idDemandInfo_maybe, setIdDemandInfo ) -import Var ( Var ) +import Var ( Var, isTyVar ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, - minusUFM, ufmToList, filterUFM ) -import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) + minusUFM, filterUFM ) +import Type ( isUnLiftedType, eqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) import Util ( mapAndUnzip, lengthIs, zipEqual ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) import Outputable +import Pair import Data.List +import FastString \end{code} To think about @@ -74,35 +76,33 @@ dmdAnalTopBind :: SigEnv -> CoreBind -> (SigEnv, CoreBind) dmdAnalTopBind sigs (NonRec id rhs) - = let - ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs) - (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1) - -- Do two passes to improve CPR information - -- See comments with ignore_cpr_info in mk_sig_ty - -- and with extendSigsWithLam - in - (sigs2, NonRec id2 rhs2) + = (sigs2, NonRec id2 rhs2) + where + ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive (virgin sigs) (id, rhs) + (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive (nonVirgin sigs) (id, rhs1) + -- Do two passes to improve CPR information + -- See comments with ignore_cpr_info in mk_sig_ty + -- and with extendSigsWithLam dmdAnalTopBind sigs (Rec pairs) - = let - (sigs', _, pairs') = dmdFix TopLevel sigs pairs + = (sigs', Rec pairs') + where + (sigs', _, pairs') = dmdFix TopLevel (virgin sigs) pairs -- We get two iterations automatically -- c.f. the NonRec case above - in - (sigs', Rec pairs') \end{code} \begin{code} dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr) -- Analyse the RHS and return -- a) appropriate strictness info --- b) the unfolding (decorated with stricntess info) +-- b) the unfolding (decorated with strictness info) dmdAnalTopRhs rhs = (sig, rhs2) where call_dmd = vanillaCall (exprArity rhs) - (_, rhs1) = dmdAnal emptySigEnv call_dmd rhs - (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1 + (_, rhs1) = dmdAnal (virgin emptySigEnv) call_dmd rhs + (rhs_ty, rhs2) = dmdAnal (nonVirgin emptySigEnv) call_dmd rhs1 sig = mkTopSigTy rhs rhs_ty -- Do two passes; see notes with extendSigsWithLam -- Otherwise we get bogus CPR info for constructors like @@ -119,14 +119,14 @@ dmdAnalTopRhs rhs %************************************************************************ \begin{code} -dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) +dmdAnal :: AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal _ Abs e = (topDmdType, e) -dmdAnal sigs dmd e +dmdAnal env dmd e | not (isStrictDmd dmd) = let - (res_ty, e') = dmdAnal sigs evalDmd e + (res_ty, e') = dmdAnal env evalDmd e in (deferType res_ty, e') -- It's important not to analyse e with a lazy demand because @@ -146,15 +146,16 @@ dmdAnal sigs dmd e dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) -dmdAnal sigs dmd (Var var) - = (dmdTransform sigs var dmd, Var var) +dmdAnal env dmd (Var var) + = (dmdTransform env var dmd, Var var) -dmdAnal sigs dmd (Cast e co) +dmdAnal env dmd (Cast e co) = (dmd_ty, Cast e' co) where - (dmd_ty, e') = dmdAnal sigs dmd' e - to_co = snd (coercionKind co) + (dmd_ty, e') = dmdAnal env dmd' e + to_co = pSnd (coercionKind co) dmd' | Just (tc, _) <- splitTyConApp_maybe to_co , isRecursiveTyCon tc = evalDmd @@ -165,55 +166,60 @@ dmdAnal sigs dmd (Cast e co) -- inside recursive products -- we might not reach -- a fixpoint. So revert to a vanilla Eval demand -dmdAnal sigs dmd (Note n e) +dmdAnal env dmd (Note n e) = (dmd_ty, Note n e') where - (dmd_ty, e') = dmdAnal sigs dmd e + (dmd_ty, e') = dmdAnal env dmd e -dmdAnal sigs dmd (App fun (Type ty)) +dmdAnal env dmd (App fun (Type ty)) = (fun_ty, App fun' (Type ty)) where + (fun_ty, fun') = dmdAnal env dmd fun + +dmdAnal sigs dmd (App fun (Coercion co)) + = (fun_ty, App fun' (Coercion co)) + where (fun_ty, fun') = dmdAnal sigs dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal sigs dmd (App fun arg) -- Non-type arguments +dmdAnal env dmd (App fun arg) -- Non-type arguments = let -- [Type arg handled above] - (fun_ty, fun') = dmdAnal sigs (Call dmd) fun - (arg_ty, arg') = dmdAnal sigs arg_dmd arg + (fun_ty, fun') = dmdAnal env (Call dmd) fun + (arg_ty, arg') = dmdAnal env arg_dmd arg (arg_dmd, res_ty) = splitDmdTy fun_ty in (res_ty `bothType` arg_ty, App fun' arg') -dmdAnal sigs dmd (Lam var body) +dmdAnal env dmd (Lam var body) | isTyVar var = let - (body_ty, body') = dmdAnal sigs dmd body + (body_ty, body') = dmdAnal env dmd body in (body_ty, Lam var body') | Call body_dmd <- dmd -- A call demand: good! = let - sigs' = extendSigsWithLam sigs var - (body_ty, body') = dmdAnal sigs' body_dmd body - (lam_ty, var') = annotateLamIdBndr sigs body_ty var + env' = extendSigsWithLam env var + (body_ty, body') = dmdAnal env' body_dmd body + (lam_ty, var') = annotateLamIdBndr env 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 evalDmd body - (lam_ty, var') = annotateLamIdBndr sigs body_ty var + (body_ty, body') = dmdAnal env evalDmd body + (lam_ty, var') = annotateLamIdBndr env body_ty var in (deferType lam_ty, Lam var' body') -dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) +dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) | let tycon = dataConTyCon dc , isProductTyCon tycon , not (isRecursiveTyCon tycon) = let - sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig - (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt + env_alt = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig + (alt_ty, alt') = dmdAnalAlt env_alt dmd alt (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr (_, bndrs', _) = alt' case_bndr_sig = cprSig @@ -251,23 +257,23 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) scrut_dmd = alt_dmd `both` idDemandInfo case_bndr' - (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut + (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut in (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt']) -dmdAnal sigs dmd (Case scrut case_bndr ty alts) +dmdAnal env dmd (Case scrut case_bndr ty alts) = let - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts - (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts + (scrut_ty, scrut') = dmdAnal env evalDmd scrut (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr in -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts') -dmdAnal sigs dmd (Let (NonRec id rhs) body) +dmdAnal env dmd (Let (NonRec id rhs) body) = let - (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs) - (body_ty, body') = dmdAnal sigs' dmd body + (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive env (id, rhs) + (body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body (body_ty1, id2) = annotateBndr body_ty id1 body_ty2 = addLazyFVs body_ty1 lazy_fv in @@ -285,11 +291,11 @@ dmdAnal sigs dmd (Let (NonRec id rhs) body) -- bother to re-analyse the RHS. (body_ty2, Let (NonRec id2 rhs') body') -dmdAnal sigs dmd (Let (Rec pairs) body) +dmdAnal env dmd (Let (Rec pairs) body) = let bndrs = map fst pairs - (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs - (body_ty, body') = dmdAnal sigs' dmd body + (sigs', lazy_fv, pairs') = dmdFix NotTopLevel env pairs + (body_ty, body') = dmdAnal (updSigEnv env sigs') dmd body body_ty1 = addLazyFVs body_ty lazy_fv in sigs' `seq` body_ty `seq` @@ -303,10 +309,10 @@ dmdAnal sigs dmd (Let (Rec pairs) body) (body_ty2, Let (Rec pairs') body') -dmdAnalAlt :: SigEnv -> Demand -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt sigs dmd (con,bndrs,rhs) +dmdAnalAlt :: AnalEnv -> Demand -> Alt Var -> (DmdType, Alt Var) +dmdAnalAlt env dmd (con,bndrs,rhs) = let - (rhs_ty, rhs') = dmdAnal sigs dmd rhs + (rhs_ty, rhs') = dmdAnal env dmd rhs rhs_ty' = addDataConPatDmds con bndrs rhs_ty (alt_ty, bndrs') = annotateBndrs rhs_ty' bndrs final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType @@ -330,7 +336,7 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs) -- ; print len } io_hack_reqd = con == DataAlt unboxedPairDataCon && - idType (head bndrs) `coreEqType` realWorldStatePrimTy + idType (head bndrs) `eqType` realWorldStatePrimTy in (final_alt_ty, (con, bndrs', rhs')) @@ -380,6 +386,85 @@ if X is monomorphic, and has an UNPACK pragma, then this optimisation is even more important. We don't want the wrapper to rebox an unboxed argument, and pass an Int to $wfoo! + +%************************************************************************ +%* * + Demand transformer +%* * +%************************************************************************ + +\begin{code} +dmdTransform :: AnalEnv -- The strictness environment + -> Id -- The function + -> Demand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform env var dmd + +------ DATA CONSTRUCTOR + | isDataConWorkId var -- Data constructor + = let + StrictSig dmd_ty = idStrictness var -- It must have a strictness sig + DmdType _ _ con_res = dmd_ty + arity = idArity var + in + if arity == call_depth then -- Saturated, so unleash the demand + let + -- Important! If we Keep the constructor application, then + -- we need the demands the constructor places (always lazy) + -- If not, we don't need to. For example: + -- f p@(x,y) = (p,y) -- S(AL) + -- g a b = f (a,b) + -- It's vital that we don't calculate Absent for a! + dmd_ds = case res_dmd of + Box (Eval ds) -> mapDmds box ds + Eval ds -> ds + _ -> Poly Top + + -- ds can be empty, when we are just seq'ing the thing + -- If so we must make up a suitable bunch of demands + arg_ds = case dmd_ds of + Poly d -> replicate arity d + Prod ds -> ASSERT( ds `lengthIs` arity ) ds + + in + mkDmdType emptyDmdEnv arg_ds con_res + -- Must remember whether it's a product, hence con_res, not TopRes + else + topDmdType + +------ IMPORTED FUNCTION + | isGlobalId var, -- Imported function + let StrictSig dmd_ty = idStrictness var + = -- pprTrace "strict-sig" (ppr var $$ ppr dmd_ty) $ + if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand + dmd_ty + else + topDmdType + +------ LOCAL LET/REC BOUND THING + | Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv env var + = let + fn_ty | dmdTypeDepth dmd_ty <= call_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 + if isTopLevel top_lvl then fn_ty -- Don't record top level things + else addVarDmd fn_ty var dmd + +------ LOCAL NON-LET/REC BOUND THING + | otherwise -- Default case + = unitVarDmd var dmd + + where + (call_depth, res_dmd) = splitCallDmd dmd +\end{code} + %************************************************************************ %* * \subsection{Bindings} @@ -388,93 +473,89 @@ argument, and pass an Int to $wfoo! \begin{code} dmdFix :: TopLevelFlag - -> SigEnv -- Does not include bindings for this binding + -> AnalEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)] -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info -dmdFix top_lvl sigs orig_pairs - = loop 1 initial_sigs orig_pairs +dmdFix top_lvl env orig_pairs + = loop 1 initial_env orig_pairs where bndrs = map fst orig_pairs - initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs] + initial_env = addInitialSigs top_lvl env bndrs loop :: Int - -> SigEnv -- Already contains the current sigs + -> AnalEnv -- Already contains the current sigs -> [(Id,CoreExpr)] -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) - loop n sigs pairs + loop n env pairs + = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $ + loop' n env pairs + + loop' n env pairs | found_fixpoint = (sigs', lazy_fv, pairs') - -- Note: use pairs', not pairs. pairs' is the result of + -- Note: return 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 >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat - [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs], - text "env:" <+> ppr (ufmToList sigs), - text "binds:" <+> pprCoreBinding (Rec pairs)])) - (emptySigEnv, lazy_fv, orig_pairs) -- Safe output - -- The lazy_fv part is really important! orig_pairs has no strictness - -- info, including nothing about free vars. But if we have - -- letrec f = ....y..... in ...f... - -- where 'y' is free in f, we must record that y is mentioned, - -- otherwise y will get recorded as absent altogether - - | otherwise = loop (n+1) sigs' pairs' + | n >= 10 + = pprTrace "dmdFix loop" (ppr n <+> (vcat + [ text "Sigs:" <+> ppr [ (id,lookupVarEnv sigs id, lookupVarEnv sigs' id) + | (id,_) <- pairs], + text "env:" <+> ppr env, + text "binds:" <+> pprCoreBinding (Rec pairs)])) + (sigEnv env, lazy_fv, orig_pairs) -- Safe output + -- The lazy_fv part is really important! orig_pairs has no strictness + -- info, including nothing about free vars. But if we have + -- letrec f = ....y..... in ...f... + -- where 'y' is free in f, we must record that y is mentioned, + -- otherwise y will get recorded as absent altogether + + | otherwise + = loop (n+1) (nonVirgin sigs') pairs' where + sigs = sigEnv env found_fixpoint = all (same_sig sigs sigs') bndrs - -- Use the new signature to do the next pair + + ((sigs',lazy_fv), pairs') = mapAccumL my_downRhs (sigs, emptyDmdEnv) pairs + -- mapAccumL: 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',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') = dmdAnalRhs top_lvl Recursive sigs (id,rhs) - lazy_fv' = plusVarEnv_C both lazy_fv lazy_fv1 - -- old_sig = lookup sigs id - -- new_sig = lookup sigs' id + my_downRhs (sigs,lazy_fv) (id,rhs) + = ((sigs', lazy_fv'), pair') + where + (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive (updSigEnv env sigs) (id,rhs) + lazy_fv' = plusVarEnv_C both lazy_fv lazy_fv1 same_sig sigs sigs' var = lookup sigs var == lookup sigs' var lookup sigs var = case lookupVarEnv sigs var of Just (sig,_) -> sig Nothing -> pprPanic "dmdFix" (ppr var) - -- Get an initial strictness signature from the Id - -- itself. That way we make use of earlier iterations - -- of the fixpoint algorithm. (Cunning plan.) - -- Note that the cunning plan extends to the DmdEnv too, - -- since it is part of the strictness signature -initialSig :: Id -> StrictSig -initialSig id = idStrictness_maybe id `orElse` botSig - dmdAnalRhs :: TopLevelFlag -> RecFlag - -> SigEnv -> (Id, CoreExpr) + -> AnalEnv -> (Id, CoreExpr) -> (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. -dmdAnalRhs top_lvl rec_flag sigs (id, rhs) +dmdAnalRhs top_lvl rec_flag env (id, rhs) = (sigs', lazy_fv, (id', rhs')) where arity = idArity id -- The idArity should be up to date -- The simplifier was run just beforehand - (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs + (rhs_dmd_ty, rhs') = dmdAnal env (vanillaCall arity) rhs (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) -- The RHS can be eta-reduced to just a variable, -- in which case we should not complain. mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty id' = id `setIdStrictness` sig_ty - sigs' = extendSigEnv top_lvl sigs id sig_ty + sigs' = extendSigEnv top_lvl (sigEnv env) id sig_ty \end{code} + %************************************************************************ %* * \subsection{Strictness signatures and types} @@ -773,13 +854,13 @@ annotateBndr dmd_ty@(DmdType fv ds res) var annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var]) annotateBndrs = mapAccumR annotateBndr -annotateLamIdBndr :: SigEnv +annotateLamIdBndr :: AnalEnv -> DmdType -- Demand type of body -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand -annotateLamIdBndr sigs (DmdType fv ds res) id +annotateLamIdBndr env (DmdType fv ds res) id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) @@ -790,7 +871,7 @@ annotateLamIdBndr sigs (DmdType fv ds res) id Nothing -> main_ty Just unf -> main_ty `bothType` unf_ty where - (unf_ty, _) = dmdAnal sigs dmd unf + (unf_ty, _) = dmdAnal env dmd unf main_ty = DmdType fv' (hacked_dmd:ds) res @@ -815,10 +896,15 @@ removeFV fv id res = (fv', zapUnlifted id dmd) zapUnlifted :: Id -> Demand -> Demand -- For unlifted-type variables, we are only -- interested in Bot/Abs/Box Abs -zapUnlifted _ Bot = Bot -zapUnlifted _ Abs = Abs -zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd - | otherwise = dmd +zapUnlifted id dmd + = case dmd of + _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally + Bot -> Bot + Abs -> Abs + _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness + | otherwise -> dmd + where + ty = idType id \end{code} Note [Lamba-bound unfoldings] @@ -838,25 +924,59 @@ forget that fact, otherwise we might make 'x' absent when it isn't. %************************************************************************ \begin{code} -type SigEnv = VarEnv (StrictSig, TopLevelFlag) - -- We use the SigEnv to tell us whether to +data AnalEnv + = AE { ae_sigs :: SigEnv + , ae_virgin :: Bool } -- True on first iteration only + -- See Note [Initialising strictness] + -- We use the se_env to tell us whether to -- record info about a variable in the DmdEnv -- We do so if it's a LocalId, but not top-level -- -- The DmdEnv gives the demand on the free vars of the function -- when it is given enough args to satisfy the strictness signature +type SigEnv = VarEnv (StrictSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = ptext (sLit "AE") <+> braces (vcat + [ ptext (sLit "ae_virgin =") <+> ppr virgin + , ptext (sLit "ae_sigs =") <+> ppr env ]) + emptySigEnv :: SigEnv -emptySigEnv = emptyVarEnv +emptySigEnv = emptyVarEnv + +sigEnv :: AnalEnv -> SigEnv +sigEnv = ae_sigs + +updSigEnv :: AnalEnv -> SigEnv -> AnalEnv +updSigEnv env sigs = env { ae_sigs = sigs } + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv -extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl) +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id -extendSigEnvList :: SigEnv -> [(Id, (StrictSig, TopLevelFlag))] -> SigEnv -extendSigEnvList = extendVarEnvList +addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +-- See Note [Initialising strictness] +addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids + = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl)) + | id <- ids ] } + where + init_sig | virgin = \_ -> botSig + | otherwise = idStrictness -extendSigsWithLam :: SigEnv -> Id -> SigEnv --- Extend the SigEnv when we meet a lambda binder +virgin, nonVirgin :: SigEnv -> AnalEnv +virgin sigs = AE { ae_sigs = sigs, ae_virgin = True } +nonVirgin sigs = AE { ae_sigs = sigs, ae_virgin = False } + +extendSigsWithLam :: AnalEnv -> Id -> AnalEnv +-- Extend the AnalEnv when we meet a lambda binder -- If the binder is marked demanded with a product demand, then give it a CPR -- signature, because in the likely event that this is a lambda on a fn defn -- [we only use this when the lambda is being consumed with a call demand], @@ -871,89 +991,38 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv -- definitely has product type, else we may get over-optimistic -- CPR results (e.g. from \x -> x!). -extendSigsWithLam sigs id +extendSigsWithLam env id = case idDemandInfo_maybe id of - Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) + Nothing -> extendAnalEnv NotTopLevel env id cprSig -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS] - Just (Eval (Prod _)) -> extendVarEnv sigs id (cprSig, NotTopLevel) - _ -> sigs - - -dmdTransform :: SigEnv -- The strictness environment - -> Id -- The function - -> Demand -- The demand on the function - -> DmdType -- The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables - -dmdTransform sigs var dmd - ------- DATA CONSTRUCTOR - | isDataConWorkId var -- Data constructor - = let - StrictSig dmd_ty = idStrictness var -- It must have a strictness sig - DmdType _ _ con_res = dmd_ty - arity = idArity var - in - if arity == call_depth then -- Saturated, so unleash the demand - let - -- Important! If we Keep the constructor application, then - -- we need the demands the constructor places (always lazy) - -- If not, we don't need to. For example: - -- f p@(x,y) = (p,y) -- S(AL) - -- g a b = f (a,b) - -- It's vital that we don't calculate Absent for a! - dmd_ds = case res_dmd of - Box (Eval ds) -> mapDmds box ds - Eval ds -> ds - _ -> Poly Top - - -- ds can be empty, when we are just seq'ing the thing - -- If so we must make up a suitable bunch of demands - arg_ds = case dmd_ds of - Poly d -> replicate arity d - Prod ds -> ASSERT( ds `lengthIs` arity ) ds - - in - mkDmdType emptyDmdEnv arg_ds con_res - -- Must remember whether it's a product, hence con_res, not TopRes - else - topDmdType - ------- IMPORTED FUNCTION - | isGlobalId var, -- Imported function - let StrictSig dmd_ty = idStrictness var - = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand - dmd_ty - else - topDmdType + Just (Eval (Prod _)) -> extendAnalEnv NotTopLevel env id cprSig + _ -> env +\end{code} ------- LOCAL LET/REC BOUND THING - | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var - = let - fn_ty | dmdTypeDepth dmd_ty <= call_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 - if isTopLevel top_lvl then fn_ty -- Don't record top level things - else addVarDmd fn_ty var dmd +Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our basic plan is to initialise the strictness of each Id in +a recursive group to "bottom", and find a fixpoint from there. +However, this group A might be inside an *enclosing* recursive +group B, in which case we'll do the entire fixpoint shebang on A +for each iteration of B. ------- LOCAL NON-LET/REC BOUND THING - | otherwise -- Default case - = unitVarDmd var dmd +To speed things up, we initialise each iteration of B from the result +of the last one, which is neatly recorded in each binder. That way we +make use of earlier iterations of the fixpoint algorithm. (Cunning +plan.) - where - (call_depth, res_dmd) = splitCallDmd dmd -\end{code} +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. %************************************************************************ %* * -\subsection{Demands} + Demands %* * %************************************************************************