X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FDmdAnal.lhs;h=32986e56fb23436417ef1887c38595344d2c6e0a;hb=8ddee6152c215e8e8ee1cbfff3481ea5bc062305;hp=41f574ab343eb2678299f05f99fa214ea8081d0b;hpb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4;p=ghc-hetmet.git diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 41f574a..32986e5 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -7,56 +7,41 @@ ----------------- \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, both {- needed by WwLib -} ) where #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 ) import CoreArity ( exprArity ) -import DataCon ( dataConTyCon ) +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, idStrictness_maybe, + setIdStrictness, idDemandInfo, idUnfolding, + idDemandInfo_maybe, + setIdDemandInfo ) -#ifdef OLD_STRICTNESS -import IdInfo ( newStrictnessFromOld, newDemand ) -#endif import Var ( Var ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) -import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, - keysUFM, minusUFM, ufmToList, filterUFM ) +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, + minusUFM, ufmToList, filterUFM ) import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) -import CoreLint ( showPass, endPass ) -import Util ( mapAndUnzip, lengthIs ) +import Util ( mapAndUnzip, lengthIs, zipEqual ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, - RecFlag(..), isRec ) + RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) import Outputable - import Data.List \end{code} @@ -76,15 +61,9 @@ To think about \begin{code} dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] -dmdAnalPgm dflags binds +dmdAnalPgm _ binds = do { let { binds_plus_dmds = do_prog binds } ; -#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 @@ -142,7 +121,7 @@ dmdAnalTopRhs rhs \begin{code} dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) -dmdAnal sigs Abs e = (topDmdType, e) +dmdAnal _ Abs e = (topDmdType, e) dmdAnal sigs dmd e | not (isStrictDmd dmd) @@ -165,8 +144,8 @@ 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 sigs dmd (Var var) = (dmdTransform sigs var dmd, Var var) @@ -177,7 +156,7 @@ dmdAnal sigs dmd (Cast e co) (dmd_ty, e') = dmdAnal sigs dmd' e to_co = snd (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 @@ -198,7 +177,7 @@ dmdAnal sigs dmd (App fun (Type ty)) -- 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 sigs 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 @@ -207,7 +186,7 @@ dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments (res_ty `bothType` arg_ty, App fun' arg') dmdAnal sigs dmd (Lam var body) - | isTyVar var + | isTyCoVar var = let (body_ty, body') = dmdAnal sigs dmd body in @@ -217,21 +196,21 @@ dmdAnal sigs dmd (Lam var body) = let sigs' = extendSigsWithLam sigs var (body_ty, body') = dmdAnal sigs' body_dmd body - (lam_ty, var') = annotateLamIdBndr body_ty var + (lam_ty, var') = annotateLamIdBndr sigs 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 + (lam_ty, var') = annotateLamIdBndr sigs 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 sigs 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 @@ -257,7 +236,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 -- @@ -268,9 +247,9 @@ 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 in @@ -324,10 +303,12 @@ 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) = let (rhs_ty, rhs') = dmdAnal sigs dmd rhs - (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs + 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 @@ -352,8 +333,53 @@ dmdAnalAlt sigs dmd (con,bndrs,rhs) idType (head bndrs) `coreEqType` 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! + %************************************************************************ %* * \subsection{Bindings} @@ -412,20 +438,22 @@ dmdFix top_lvl sigs orig_pairs -- ) where (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs) - lazy_fv' = plusUFM_C both lazy_fv lazy_fv1 + lazy_fv' = plusVarEnv_C both lazy_fv lazy_fv1 -- old_sig = lookup sigs id -- new_sig = lookup sigs' id 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 = idNewStrictness_maybe id `orElse` botSig +initialSig :: Id -> StrictSig +initialSig id = idStrictness_maybe id `orElse` botSig dmdAnalRhs :: TopLevelFlag -> RecFlag -> SigEnv -> (Id, CoreExpr) @@ -443,7 +471,7 @@ dmdAnalRhs top_lvl rec_flag sigs (id, rhs) -- 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 + id' = id `setIdStrictness` sig_ty sigs' = extendSigEnv top_lvl sigs id sig_ty \end{code} @@ -463,8 +491,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 @@ -602,7 +630,9 @@ 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 @@ -645,7 +675,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} @@ -680,7 +710,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} @@ -691,16 +721,18 @@ nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds %************************************************************************ \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) @@ -733,24 +765,35 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var) -- The returned var is annotated with demand info -- 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) + | isTyCoVar var = (dmd_ty, var) + | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) where (fv', dmd) = removeFV fv var res +annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var]) annotateBndrs = mapAccumR annotateBndr -annotateLamIdBndr :: DmdType -- Demand type of body +annotateLamIdBndr :: SigEnv + -> DmdType -- Demand type of body -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand -annotateLamIdBndr dmd_ty@(DmdType fv ds res) id +annotateLamIdBndr sigs (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 sigs 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 @@ -761,6 +804,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 @@ -768,14 +812,25 @@ 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 _ Bot = Bot +zapUnlifted _ Abs = Abs zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd | otherwise = dmd \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} @@ -791,11 +846,13 @@ type SigEnv = VarEnv (StrictSig, TopLevelFlag) -- The DmdEnv gives the demand on the free vars of the function -- when it is given enough args to satisfy the strictness signature +emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl) +extendSigEnvList :: SigEnv -> [(Id, (StrictSig, TopLevelFlag))] -> SigEnv extendSigEnvList = extendVarEnvList extendSigsWithLam :: SigEnv -> Id -> SigEnv @@ -815,12 +872,12 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv -- CPR results (e.g. from \x -> x!). extendSigsWithLam sigs id - = case idNewDemandInfo_maybe id of - Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) + = case idDemandInfo_maybe id of + Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS] - Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel) - other -> sigs + Just (Eval (Prod _)) -> extendVarEnv sigs id (cprSig, NotTopLevel) + _ -> sigs dmdTransform :: SigEnv -- The strictness environment @@ -835,7 +892,7 @@ dmdTransform sigs var dmd ------ DATA CONSTRUCTOR | isDataConWorkId var -- Data constructor = let - StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig + StrictSig dmd_ty = idStrictness var -- It must have a strictness sig DmdType _ _ con_res = dmd_ty arity = idArity var in @@ -850,7 +907,7 @@ dmdTransform sigs var dmd dmd_ds = case res_dmd of Box (Eval ds) -> mapDmds box ds Eval ds -> ds - other -> Poly Top + _ -> 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 @@ -866,7 +923,7 @@ dmdTransform sigs var dmd ------ IMPORTED FUNCTION | isGlobalId var, -- Imported function - let StrictSig dmd_ty = idNewStrictness var + let StrictSig dmd_ty = idStrictness var = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand dmd_ty else @@ -882,7 +939,8 @@ dmdTransform sigs var dmd -- The application isn't saturated, but we must nevertheless propagate -- a lazy demand for p! in - addVarDmd top_lvl fn_ty var dmd + 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 @@ -905,7 +963,7 @@ splitDmdTy :: DmdType -> (Demand, DmdType) -- 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) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) splitCallDmd :: Demand -> (Int, Demand) splitCallDmd (Call d) = case splitCallDmd d of @@ -931,7 +989,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) @@ -941,6 +999,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)} @@ -948,7 +1007,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 @@ -960,15 +1019,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 @@ -976,15 +1036,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} @@ -996,7 +1058,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) @@ -1016,12 +1078,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 @@ -1037,9 +1099,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 @@ -1071,6 +1135,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 @@ -1090,6 +1155,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 --------------- @@ -1097,27 +1163,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) @@ -1129,105 +1184,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}