X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FDmdAnal.lhs;h=e8aa22c326d7b7a5a9c6bee192b0af5b25bf6686;hp=eec165a1a06591aab32d7e0cd55ae83087e4b305;hb=71c7067b7cc2b06265c97190e6a09c272ad7a175;hpb=0c72be2588fbbd6410ae9ea5bf9307d593208919 diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index eec165a..e8aa22c 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -22,25 +22,20 @@ module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, import DynFlags ( DynFlags, DynFlag(..) ) import StaticFlags ( opt_MaxWorkerArgs ) -import NewDemand -- All of it +import Demand -- All of it import CoreSyn import PprCore -import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity ) +import CoreUtils ( exprIsHNF, exprIsTrivial ) +import CoreArity ( exprArity ) import DataCon ( dataConTyCon ) 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 ) @@ -49,11 +44,11 @@ import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, keysUFM, minusUFM, ufmToList, filterUFM ) import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) -import CoreLint ( showPass, endPass ) import Util ( mapAndUnzip, lengthIs ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec ) import Maybes ( orElse, expectJust ) +import ErrUtils ( showPass ) import Outputable import Data.List @@ -77,17 +72,7 @@ To think about dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] dmdAnalPgm dflags 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 @@ -220,21 +205,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) + | 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 @@ -260,7 +245,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 -- @@ -271,9 +256,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 @@ -428,7 +413,7 @@ dmdFix top_lvl sigs orig_pairs -- 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 = idStrictness_maybe id `orElse` botSig dmdAnalRhs :: TopLevelFlag -> RecFlag -> SigEnv -> (Id, CoreExpr) @@ -446,7 +431,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} @@ -466,8 +451,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 @@ -567,9 +552,47 @@ 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) = (lazy_fv, mkStrictSig dmd_ty) + -- Re unused never_inline, see Note [NOINLINE and strictness] where dmd_ty = DmdType strict_fv final_dmds res' @@ -699,18 +722,33 @@ 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 = mapAccumR annotateBndr -annotateLamIdBndr dmd_ty@(DmdType fv ds res) id +annotateLamIdBndr :: SigEnv + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> (DmdType, -- Demand type of lambda + Id) -- and binder annotated with demand + +annotateLamIdBndr sigs dmd_ty@(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 @@ -736,6 +774,16 @@ 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} @@ -775,7 +823,7 @@ extendSigsWithLam :: SigEnv -> Id -> SigEnv -- CPR results (e.g. from \x -> x!). extendSigsWithLam sigs id - = case idNewDemandInfo_maybe id of + = case idDemandInfo_maybe id of Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS] @@ -795,7 +843,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 @@ -826,7 +874,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 @@ -1057,22 +1105,11 @@ both :: Demand -> Demand -> Demand both Abs d2 = d2 +-- Note [Bottom demands] 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 (Defer ds) = Eval (mapDmds (`both` Bot) ds) both Bot d = errDmd both Top Bot = errDmd @@ -1107,87 +1144,29 @@ both d1@(Defer ds1) d2 = d2 `both` d1 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}