X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FDmdAnal.lhs;h=afa722fa8aa24142a4d6df0d5453b792a8cd8851;hp=4c5de9616f58bff34d3d2b65d45be9de88944e74;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=a515009d89b62d6bc4fc34844db37edb5d4ef6ac diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 4c5de96..afa722f 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -13,41 +13,38 @@ module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags ) import StaticFlags ( opt_MaxWorkerArgs ) -import NewDemand -- All of it +import Demand -- All of it import CoreSyn import PprCore -import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity ) -import DataCon ( dataConTyCon ) +import Coercion ( isCoVarType ) +import CoreUtils ( exprIsHNF, exprIsTrivial ) +import CoreArity ( exprArity ) +import DataCon ( dataConTyCon, dataConRepStrictness ) import TyCon ( isProductTyCon, isRecursiveTyCon ) -import Id ( Id, idType, idInlinePragma, +import Id ( Id, idType, idInlineActivation, isDataConWorkId, isGlobalId, idArity, -#ifdef OLD_STRICTNESS - idDemandInfo, idStrictness, idCprInfo, idName, -#endif - idNewStrictness, idNewStrictness_maybe, - setIdNewStrictness, idNewDemandInfo, - idNewDemandInfo_maybe, - setIdNewDemandInfo + idStrictness, + setIdStrictness, idDemandInfo, idUnfolding, + idDemandInfo_maybe, setIdDemandInfo ) -#ifdef OLD_STRICTNESS -import IdInfo ( newStrictnessFromOld, newDemand ) -#endif -import Var ( Var ) +import Var ( Var, isTyVar ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) -import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, - keysUFM, minusUFM, ufmToList, filterUFM ) -import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, + minusUFM, filterUFM ) +import Type ( isUnLiftedType, eqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) -import CoreLint ( showPass, endPass ) -import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs ) +import Util ( mapAndUnzip, lengthIs, zipEqual ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, - RecFlag(..), isRec ) + RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) import Outputable +import Pair +import Data.List +import FastString \end{code} To think about @@ -66,19 +63,9 @@ To think about \begin{code} dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] -dmdAnalPgm dflags binds +dmdAnalPgm _ binds = do { - showPass dflags "Demand analysis" ; let { binds_plus_dmds = do_prog binds } ; - - endPass dflags "Demand analysis" - Opt_D_dump_stranal binds_plus_dmds ; -#ifdef OLD_STRICTNESS - -- Only if OLD_STRICTNESS is on, because only then is the old - -- strictness analyser run - let { dmd_changes = get_changes binds_plus_dmds } ; - printDump (text "Changes in demands" $$ dmd_changes) ; -#endif return binds_plus_dmds } where @@ -89,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 @@ -134,14 +119,14 @@ dmdAnalTopRhs rhs %************************************************************************ \begin{code} -dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) +dmdAnal :: AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) -dmdAnal sigs Abs e = (topDmdType, e) +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 @@ -159,19 +144,20 @@ dmdAnal sigs dmd e -- evaluation of f in a C(L) demand! -dmdAnal sigs dmd (Lit lit) - = (topDmdType, Lit lit) +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, args) <- splitTyConApp_maybe to_co + | Just (tc, _) <- splitTyConApp_maybe to_co , isRecursiveTyCon tc = evalDmd | otherwise = dmd -- This coerce usually arises from a recursive @@ -180,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 e@(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 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 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,bndrs,rhs)]) - | let tycon = dataConTyCon dc, - isProductTyCon tycon, - not (isRecursiveTyCon tycon) +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,7 +242,7 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) -- x = (a, absent-error) -- and that'll crash. -- So at one stage I had: - -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr') + -- dead_case_bndr = isAbsentDmd (idDemandInfo case_bndr') -- keepity | dead_case_bndr = Drop -- | otherwise = Keep -- @@ -262,27 +253,27 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand - alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b]) + alt_dmd = Eval (Prod [idDemandInfo b | b <- bndrs', isId b]) scrut_dmd = alt_dmd `both` - idNewDemandInfo case_bndr' + 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 @@ -300,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` @@ -318,10 +309,12 @@ dmdAnal sigs dmd (Let (Rec pairs) body) (body_ty2, Let (Rec pairs') body') -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 - (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs + (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 | otherwise = alt_ty @@ -343,9 +336,133 @@ 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')) + +addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType +-- See Note [Add demands for strict constructors] +addDataConPatDmds DEFAULT _ dmd_ty = dmd_ty +addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty +addDataConPatDmds (DataAlt con) bndrs dmd_ty + = foldr add dmd_ty str_bndrs + where + add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd + str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs" + (filter isId bndrs) + (dataConRepStrictness con) + , isMarkedStrict s ] +\end{code} + +Note [Add demands for strict constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo (X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' too look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time +around the loop (which would otherwise happen, since 'foo' is not +strict in 'a'. It is sound for the wrapper to pass an unboxed arg +because X is strict, so its argument must be evaluated. And if we +*don't* pass an unboxed argument, we can't even repair it by adding a +`seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +There is the usual danger of reboxing, which as usual we ignore. But +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} %************************************************************************ @@ -356,91 +473,89 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs) \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' = plusUFM_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 - - -- 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 = idNewStrictness_maybe id `orElse` botSig + Nothing -> pprPanic "dmdFix" (ppr var) 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 `setIdNewStrictness` sig_ty - sigs' = extendSigEnv top_lvl sigs id sig_ty + id' = id `setIdStrictness` sig_ty + sigs' = extendSigEnv top_lvl (sigEnv env) id sig_ty \end{code} + %************************************************************************ %* * \subsection{Strictness signatures and types} @@ -457,8 +572,8 @@ mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, Stri mkSigTy top_lvl rec_flag id rhs dmd_ty = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty where - never_inline = isNeverActive (idInlinePragma id) - maybe_id_dmd = idNewDemandInfo_maybe id + never_inline = isNeverActive (idInlineActivation id) + maybe_id_dmd = idDemandInfo_maybe id -- Is Nothing the first time round thunk_cpr_ok @@ -558,9 +673,49 @@ in the case where t turns out to be not-demanded. This is handled by dmdAnalTopBind. +Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The strictness analyser used to have a HACK which ensured that NOINLNE +things were not strictness-analysed. The reason was unsafePerformIO. +Left to itself, the strictness analyser would discover this strictness +for unsafePerformIO: + unsafePerformIO: C(U(AV)) +But then consider this sub-expression + unsafePerformIO (\s -> let r = f x in + case writeIORef v r s of (# s1, _ #) -> + (# s1, r #) +The strictness analyser will now find that r is sure to be eval'd, +and may then hoist it out. This makes tests/lib/should_run/memo002 +deadlock. + +Solving this by making all NOINLINE things have no strictness info is overkill. +In particular, it's overkill for runST, which is perfectly respectable. +Consider + f x = runST (return x) +This should be strict in x. + +So the new plan is to define unsafePerformIO using the 'lazy' combinator: + + unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is +magically NON-STRICT, and is inlined after strictness analysis. So +unsafePerformIO will look non-strict, and that's what we want. + +Now we don't need the hack in the strictness analyser. HOWEVER, this +decision does mean that even a NOINLINE function is not entirely +opaque: some aspect of its implementation leaks out, notably its +strictness. For example, if you have a function implemented by an +error stub, but which has RULES, you may want it not to be eliminated +in favour of error! + + \begin{code} -mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) +mk_sig_ty :: Bool -> Bool -> CoreExpr + -> DmdType -> (DmdEnv, StrictSig) +mk_sig_ty _never_inline thunk_cpr_ok rhs (DmdType fv dmds res) = (lazy_fv, mkStrictSig dmd_ty) + -- Re unused never_inline, see Note [NOINLINE and strictness] where dmd_ty = DmdType strict_fv final_dmds res' @@ -601,7 +756,7 @@ mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) res' = case res of RetCPR | ignore_cpr_info -> TopRes - other -> res + _ -> res ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok) \end{code} @@ -636,7 +791,7 @@ setUnpackStrategy ds nonAbsentArgs :: [Demand] -> Int nonAbsentArgs [] = 0 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds -nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds +nonAbsentArgs (_ : ds) = 1 + nonAbsentArgs ds \end{code} @@ -647,25 +802,18 @@ nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds %************************************************************************ \begin{code} -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument --- We already have a suitable demand on all --- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty) -\end{code} - -\begin{code} +unitVarDmd :: Var -> Demand -> DmdType unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes -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 +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds res) var dmd + = DmdType (extendVarEnv_C both fv var dmd) ds res +addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs (DmdType fv ds res) lazy_fvs = DmdType both_fv1 ds res where - both_fv = (plusUFM_C both fv lazy_fvs) + both_fv = plusVarEnv_C both fv lazy_fvs both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv -- This modifyEnv is vital. Consider -- let f = \x -> (x,y) @@ -699,18 +847,34 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var) -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var) - | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd) + | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) where (fv', dmd) = removeFV fv var res +annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var]) annotateBndrs = mapAccumR annotateBndr -annotateLamIdBndr dmd_ty@(DmdType fv ds res) id +annotateLamIdBndr :: AnalEnv + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> (DmdType, -- Demand type of lambda + Id) -- and binder annotated with demand + +annotateLamIdBndr env (DmdType fv ds res) id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) - (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd) + (final_ty, setIdDemandInfo id hacked_dmd) where + -- Watch out! See note [Lambda-bound unfoldings] + final_ty = case maybeUnfoldingTemplate (idUnfolding id) of + Nothing -> main_ty + Just unf -> main_ty `bothType` unf_ty + where + (unf_ty, _) = dmdAnal env dmd unf + + main_ty = DmdType fv' (hacked_dmd:ds) res + (fv', dmd) = removeFV fv id res hacked_dmd = argDemand dmd -- This call to argDemand is vital, because otherwise we label @@ -721,6 +885,7 @@ annotateLamIdBndr dmd_ty@(DmdType fv ds res) id -- And then the simplifier things the 'B' is a strict demand -- and evaluates the (error "oops"). Sigh +removeFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand) removeFV fv id res = (fv', zapUnlifted id dmd) where fv' = fv `delVarEnv` id @@ -728,14 +893,30 @@ removeFV fv id res = (fv', zapUnlifted id dmd) deflt | isBotRes res = Bot | otherwise = Abs +zapUnlifted :: Id -> Demand -> Demand -- For unlifted-type variables, we are only -- interested in Bot/Abs/Box Abs -zapUnlifted is Bot = Bot -zapUnlifted id 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a lambda-bound variable to carry an unfolding, a facility that is used +exclusively for join points; see Note [Case binders and join points]. If so, +we must be careful to demand-analyse the RHS of the unfolding! Example + \x. \y{=Just x}. +Then if uses 'y', then transitively it uses 'x', and we must not +forget that fact, otherwise we might make 'x' absent when it isn't. + + %************************************************************************ %* * \subsection{Strictness signatures} @@ -743,23 +924,59 @@ zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd %************************************************************************ \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 -emptySigEnv = emptyVarEnv +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 + +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) -extendSigEnvList = extendVarEnvList +lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id -extendSigsWithLam :: SigEnv -> Id -> SigEnv --- Extend the SigEnv when we meet a lambda binder +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 + +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], @@ -774,92 +991,49 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv -- definitely has product type, else we may get over-optimistic -- CPR results (e.g. from \x -> x!). -extendSigsWithLam sigs id - = case idNewDemandInfo_maybe id of - Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) +extendSigsWithLam env id + = case idDemandInfo_maybe id of + Nothing -> extendAnalEnv NotTopLevel env id cprSig -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS] - Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel) - other -> 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 = idNewStrictness 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 - other -> 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 + Just (Eval (Prod _)) -> extendAnalEnv NotTopLevel env id cprSig + _ -> env +\end{code} ------- IMPORTED FUNCTION - | isGlobalId var, -- Imported function - let StrictSig dmd_ty = idNewStrictness var - = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand - dmd_ty - else - topDmdType +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 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 - addVarDmd top_lvl fn_ty 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.) ------- LOCAL NON-LET/REC BOUND THING - | otherwise -- Default case - = unitVarDmd var dmd - - 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 %* * %************************************************************************ \begin{code} +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + splitCallDmd :: Demand -> (Int, Demand) splitCallDmd (Call d) = case splitCallDmd d of (n, r) -> (n+1, r) @@ -874,7 +1048,6 @@ deferType (DmdType fv _ _) = DmdType (deferEnv 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. - -- Peter?? deferEnv :: DmdEnv -> DmdEnv deferEnv fv = mapVarEnv defer fv @@ -885,7 +1058,7 @@ argDemand :: Demand -> Demand -- The 'Defer' demands are just Lazy at function boundaries -- Ugly! Ask John how to improve it. argDemand Top = lazyDmd -argDemand (Defer d) = lazyDmd +argDemand (Defer _) = lazyDmd argDemand (Eval ds) = Eval (mapDmds argDemand ds) argDemand (Box Bot) = evalDmd argDemand (Box d) = box (argDemand d) @@ -895,6 +1068,7 @@ argDemand d = d \begin{code} ------------------------- +lubType :: DmdType -> DmdType -> DmdType -- Consider (if x then y else []) with demand V -- Then the first branch gives {y->V} and the second -- *implicitly* has {y->A}. So we must put {y->(V `lub` A)} @@ -902,7 +1076,7 @@ argDemand d = d lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2) where - lub_fv = plusUFM_C lub fv1 fv2 + lub_fv = plusVarEnv_C lub fv1 fv2 lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1 -- lub is the identity for Bot @@ -914,15 +1088,16 @@ lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2 ----------------------------------- +bothType :: DmdType -> DmdType -> DmdType -- (t1 `bothType` t2) takes the argument/result info from t1, -- using t2 just for its free-var info -- NB: Don't forget about r2! It might be BotRes, which is -- a bottom demand on all the in-scope variables. -- Peter: can this be done more neatly? -bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) +bothType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2) = DmdType both_fv2 ds1 (r1 `bothRes` r2) where - both_fv = plusUFM_C both fv1 fv2 + both_fv = plusVarEnv_C both fv1 fv2 both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1 -- both is the identity for Abs @@ -930,15 +1105,17 @@ bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) \begin{code} +lubRes :: DmdResult -> DmdResult -> DmdResult lubRes BotRes r = r lubRes r BotRes = r lubRes RetCPR RetCPR = RetCPR -lubRes r1 r2 = TopRes +lubRes _ _ = TopRes +bothRes :: DmdResult -> DmdResult -> DmdResult -- If either diverges, the whole thing does -- Otherwise take CPR info from the first -bothRes r1 BotRes = BotRes -bothRes r1 r2 = r1 +bothRes _ BotRes = BotRes +bothRes r1 _ = r1 \end{code} \begin{code} @@ -950,7 +1127,7 @@ modifyEnv :: Bool -- No-op if False -- Assume: dom(env) includes dom(Env1) and dom(Env2) modifyEnv need_to_modify zapper env1 env2 env - | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2)) + | need_to_modify = foldr zap env (varEnvKeys (env1 `minusUFM` env2)) | otherwise = env where zap uniq env = addToUFM_Directly env uniq (zapper current_val) @@ -970,12 +1147,12 @@ lub :: Demand -> Demand -> Demand lub Bot d2 = d2 lub Abs d2 = absLub d2 -lub Top d2 = Top +lub Top _ = Top lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2) lub (Call d1) (Call d2) = Call (d1 `lub` d2) lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box -lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval +lub (Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top -- For the Eval case, we use these approximation rules @@ -991,9 +1168,11 @@ lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer lub (Box d1) (Box d2) = box (d1 `lub` d2) lub d1@(Box _) d2 = d2 `lub` d1 +lubs :: Demands -> Demands -> Demands lubs ds1 ds2 = zipWithDmds lub ds1 ds2 --------------------- +box :: Demand -> Demand -- box is the smart constructor for Box -- It computes & d -- INVARIANT: (Box d) => d = Bot, Abs, Eval @@ -1025,6 +1204,7 @@ defer (Box _) = lazyDmd defer (Defer ds) = Defer ds defer (Eval ds) = deferEval ds +deferEval :: Demands -> Demand -- deferEval ds = defer (Eval ds) deferEval ds | allTop ds = Top | otherwise = Defer ds @@ -1044,6 +1224,7 @@ absLub (Box _) = Top absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)? absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)? +absLubs :: Demands -> Demands absLubs = mapDmds absLub --------------- @@ -1051,27 +1232,16 @@ both :: Demand -> Demand -> Demand both Abs d2 = d2 -both Bot Bot = Bot -both Bot Abs = Bot -both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds) - -- Consider - -- f x = error x - -- From 'error' itself we get demand Bot on x - -- From the arg demand on x we get - -- x :-> evalDmd = Box (Eval (Poly Abs)) - -- So we get Bot `both` Box (Eval (Poly Abs)) - -- = Seq Keep (Poly Bot) - -- - -- Consider also - -- f x = if ... then error (fst x) else fst x - -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) - -- = Eval (SA) - -- which is what we want. -both Bot d = errDmd - -both Top Bot = errDmd -both Top Abs = Top -both Top Top = Top +-- Note [Bottom demands] +both Bot Bot = Bot +both Bot Abs = Bot +both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds) +both Bot (Defer ds) = Eval (mapDmds (`both` Bot) ds) +both Bot _ = errDmd + +both Top Bot = errDmd +both Top Abs = Top +both Top Top = Top both Top (Box d) = Box d both Top (Call d) = Call d both Top (Eval ds) = Eval (mapDmds (`both` Top) ds) @@ -1083,105 +1253,48 @@ both Top (Defer ds) -- = defer (Top `both` Eval ds) both (Box d1) (Box d2) = box (d1 `both` d2) both (Box d1) d2@(Call _) = box (d1 `both` d2) both (Box d1) d2@(Eval _) = box (d1 `both` d2) -both (Box d1) (Defer d2) = Box d1 +both (Box d1) (Defer _) = Box d1 both d1@(Box _) d2 = d2 `both` d1 both (Call d1) (Call d2) = Call (d1 `both` d2) -both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)? -both (Call d1) (Defer ds2) = Call d1 -- Ditto -both d1@(Call _) d2 = d1 `both` d1 +both (Call d1) (Eval _) = Call d1 -- Could do better for (Poly Bot)? +both (Call d1) (Defer _) = Call d1 -- Ditto +both d1@(Call _) d2 = d2 `both` d1 -both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2) -both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2) -both d1@(Eval ds1) d2 = d2 `both` d1 +both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2) +both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2) +both d1@(Eval _) d2 = d2 `both` d1 -both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2) -both d1@(Defer ds1) d2 = d2 `both` d1 +both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2) +both d1@(Defer _) d2 = d2 `both` d1 +boths :: Demands -> Demands -> Demands boths ds1 ds2 = zipWithDmds both ds1 ds2 \end{code} +Note [Bottom demands] +~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = error x +From 'error' itself we get demand Bot on x +From the arg demand on x we get + x :-> evalDmd = Box (Eval (Poly Abs)) +So we get Bot `both` Box (Eval (Poly Abs)) + = Seq Keep (Poly Bot) + +Consider also + f x = if ... then error (fst x) else fst x +Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) + = Eval (SA) +which is what we want. + +Consider also + f x = error [fst x] +Then we get + x :-> Bot `both` Defer [SA] +and we want the Bot demand to cancel out the Defer +so that we get Eval [SA]. Otherwise we'd have the odd +situation that + f x = error (fst x) -- Strictness U(SA)b + g x = error ('y':fst x) -- Strictness Tb - -%************************************************************************ -%* * -\subsection{Miscellaneous -%* * -%************************************************************************ - - -\begin{code} -#ifdef OLD_STRICTNESS -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_var var - | isId var = get_changes_str var $$ get_changes_dmd var - | otherwise = empty - -get_changes_expr (Type t) = empty -get_changes_expr (Var v) = empty -get_changes_expr (Lit l) = empty -get_changes_expr (Note n e) = get_changes_expr e -get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2 -get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e -get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e -get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a) - -get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs - -get_changes_str id - | new_better && old_better = empty - | new_better = message "BETTER" - | old_better = message "WORSE" - | otherwise = message "INCOMPARABLE" - where - message word = text word <+> text "strictness for" <+> ppr id <+> info - info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old - -- strictness analyser can't track - old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id) - old_better = old `betterStrictness` new - new_better = new `betterStrictness` old - -get_changes_dmd id - | isUnLiftedType (idType id) = empty -- Not useful - | new_better && old_better = empty - | new_better = message "BETTER" - | old_better = message "WORSE" - | otherwise = message "INCOMPARABLE" - where - message word = text word <+> text "demand for" <+> ppr id <+> info - info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements - -- A bit of a hack - old = newDemand (idDemandInfo id) - new_better = new `betterDemand` old - old_better = old `betterDemand` new - -betterStrictness :: StrictSig -> StrictSig -> Bool -betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 - -betterDmdType t1 t2 = (t1 `lubType` t2) == t2 - -betterDemand :: Demand -> Demand -> Bool --- If d1 `better` d2, and d2 `better` d2, then d1==d2 -betterDemand d1 d2 = (d1 `lub` d2) == d2 - -squashSig (StrictSig (DmdType fv ds res)) - = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) - where - -- squash just gets rid of call demands - -- which the old analyser doesn't track -squashDmd (Call d) = evalDmd -squashDmd (Box d) = Box (squashDmd d) -squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) -squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) -squashDmd d = d -#endif -\end{code}