diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/Demand.hs | 72 | ||||
| -rw-r--r-- | compiler/basicTypes/Id.hs | 11 | ||||
| -rw-r--r-- | compiler/basicTypes/IdInfo.hs | 15 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreTidy.hs | 5 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 5 | ||||
| -rw-r--r-- | compiler/stranal/DmdAnal.hs | 28 | ||||
| -rw-r--r-- | compiler/stranal/WorkWrap.hs | 79 |
7 files changed, 170 insertions, 45 deletions
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index 4159dd67cf..928b0381d5 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -5,7 +5,7 @@ \section[Demand]{@Demand@: A decoupled implementation of a demand domain} -} -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} module Demand ( StrDmd, UseDmd(..), Count(..), @@ -37,7 +37,7 @@ module Demand ( appIsBottom, isBottomingSig, pprIfaceStrictSig, trimCPRInfo, returnsCPR_maybe, StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, - isTopSig, splitStrictSig, increaseStrictSigArity, + isTopSig, hasDemandEnvSig, splitStrictSig, increaseStrictSigArity, seqDemand, seqDemandList, seqDmdType, seqStrictSig, @@ -52,7 +52,8 @@ module Demand ( trimToType, TypeShape(..), useCount, isUsedOnce, reuseEnv, - killUsageDemand, killUsageSig, zapUsageDemand, + killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, + zapUsedOnceDemand, zapUsedOnceSig, strictifyDictDmd ) where @@ -1677,6 +1678,9 @@ increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) isTopSig :: StrictSig -> Bool isTopSig (StrictSig ty) = isTopDmdType ty +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) + isBottomingSig :: StrictSig -> Bool -- True if the signature diverges or throws an exception isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res @@ -1861,9 +1865,31 @@ of absence or one-shot information altogether. This is only used for performanc tests, to see how important they are. -} +zapUsageEnvSig :: StrictSig -> StrictSig +-- Remove the usage environment from the demand +zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r + zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand -zapUsageDemand = kill_usage (True, True) +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all 1* information (but not C1 information) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all 1* information (but not C1 information) from the strictness +-- signature +zapUsedOnceSig :: StrictSig -> StrictSig +zapUsedOnceSig (StrictSig (DmdType env ds r)) + = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) killUsageDemand :: DynFlags -> Demand -> Demand -- See Note [Killing usage information] @@ -1877,35 +1903,39 @@ killUsageSig dflags sig@(StrictSig (DmdType env ds r)) | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) | otherwise = sig -type KillFlags = (Bool, Bool) +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } killFlags :: DynFlags -> Maybe KillFlags -- See Note [Killing usage information] killFlags dflags - | not kill_abs && not kill_one_shot = Nothing - | otherwise = Just (kill_abs, kill_one_shot) + | not kf_abs && not kf_used_once = Nothing + | otherwise = Just (KillFlags {..}) where - kill_abs = gopt Opt_KillAbsence dflags - kill_one_shot = gopt Opt_KillOneShot dflags + kf_abs = gopt Opt_KillAbsence dflags + kf_used_once = gopt Opt_KillOneShot dflags + kf_called_once = kf_used_once kill_usage :: KillFlags -> Demand -> Demand kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg (kill_abs, _) Abs - | kill_abs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u) - -zap_count :: KillFlags -> Count -> Count -zap_count (_, kill_one_shot) c - | kill_one_shot = Many - | otherwise = c +zap_musg kfs Abs + | kf_abs kfs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) + | kf_used_once kfs = Use Many (zap_usg kfs u) + | otherwise = Use c (zap_usg kfs u) zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u +zap_usg kfs (UCall c u) + | kf_called_once kfs = UCall Many (zap_usg kfs u) + | otherwise = UCall c (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u -- If the argument is a used non-newtype dictionary, give it strict -- demand. Also split the product type & demand and recur in order to diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index e55259b007..d5b78986ae 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -47,8 +47,9 @@ module Id ( setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapFragileIdInfo, - zapIdStrictness, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, + zapFragileIdInfo, zapIdStrictness, transferPolyIdInfo, -- ** Predicates on Ids @@ -785,6 +786,12 @@ zapIdDemandInfo = zapInfo zapDemandInfo zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + {- Note [transferPolyIdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index fd61a9c6b9..849aea3ff8 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -24,7 +24,7 @@ module IdInfo ( -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, + zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, -- ** The ArityInfo type ArityInfo, @@ -470,6 +470,19 @@ zapDemandInfo info = Just (info {demandInfo = topDmd}) zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (strictnessInfo info) + = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + zapFragileInfo :: IdInfo -> Maybe IdInfo -- ^ Zap info that depends on free variables zapFragileInfo info diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs index aed4e214ad..782e11a42a 100644 --- a/compiler/coreSyn/CoreTidy.hs +++ b/compiler/coreSyn/CoreTidy.hs @@ -18,6 +18,7 @@ import CoreSyn import CoreArity import Id import IdInfo +import Demand ( zapUsageEnvSig ) import Type( tidyType, tidyTyCoVarBndr ) import Coercion( tidyCo ) import Var @@ -187,6 +188,8 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) -- -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) -- -- Similarly arity info for eta expansion in CorePrep -- @@ -196,7 +199,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` exprArity rhs - `setStrictnessInfo` strictnessInfo old_info + `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 98bcf2ad91..1ff0cee4f3 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -319,6 +319,11 @@ getCoreToDo dflags [simpl_phase 0 ["post-late-ww"] max_iter] ), + -- Final run of the demand_analyser, ensures that one-shot thunks are + -- really really one-shot thunks. Only needed if the demand analyser + -- has run at all. See Note [Final Demand Analyser run] in DmdAnal + runWhen (strictness || late_dmd_anal) CoreDoStrictness, + maybe_rule_check (Phase 0) ] diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 20f65d5904..4d3fd09f09 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -1331,4 +1331,32 @@ 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. + + +Note [Final Demand Analyser run] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some of the information that the demand analyser determines is not always +preserved by the simplifier, for example, the simplifier will happily rewrite + \y [Demand=1*U] let x = y in x + x +to + \y [Demand=1*U] y + y +which is quite a lie. + +The once-used information is (currently) only used by the code generator, though. So we + * do not bother keeping this information up-to-date in the simplifier, or + removing it after the demand analyser is done (keeping in mind not to + critically rely on this information in, say, the simplifier). + It should still be fine to use this as in heuristics, e.g. when deciding to + inline things, as the data will usually be correct. + * Just before TidyCore, we add a pass of the demand analyse, without + subsequent worker/wrapper and simplifier, right before TidyCore. + This way, correct information finds its way into the module interface + (strictness signatures!) and the code generator (single-entry thunks!) + +Note that the single-call information (C1(..)) can be relied upon, as the +simplifier tends to be very careful about not duplicating actual function +calls. + +Also see #11731. -} diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs index 7fde65f7a0..e557f44906 100644 --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -16,7 +16,6 @@ import IdInfo import UniqSupply import BasicTypes import DynFlags -import VarEnv ( isEmptyVarEnv ) import Demand import WwLib import Util @@ -107,7 +106,10 @@ wwExpr _ _ e@(Lit {}) = return e wwExpr _ _ e@(Var {}) = return e wwExpr dflags fam_envs (Lam binder expr) - = Lam binder <$> wwExpr dflags fam_envs expr + = Lam new_binder <$> wwExpr dflags fam_envs expr + where new_binder | isId binder = zapIdUsedOnceInfo binder + | otherwise = binder + -- See Note [Zapping Used Once info in WorkWrap] wwExpr dflags fam_envs (App f a) = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a @@ -125,11 +127,16 @@ wwExpr dflags fam_envs (Let bind expr) wwExpr dflags fam_envs (Case expr binder ty alts) = do new_expr <- wwExpr dflags fam_envs expr new_alts <- mapM ww_alt alts - return (Case new_expr binder ty new_alts) + let new_binder = zapIdUsedOnceInfo binder + -- See Note [Zapping Used Once info in WorkWrap] + return (Case new_expr new_binder ty new_alts) where ww_alt (con, binders, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs - return (con, binders, new_rhs) + let new_binders = [ if isId b then zapIdUsedOnceInfo b else b + | b <- binders ] + -- See Note [Zapping Used Once info in WorkWrap] + return (con, new_binders, new_rhs) {- ************************************************************************ @@ -279,9 +286,7 @@ tryWW dflags fam_envs is_rec fn_id rhs -- No point in worker/wrappering if the thing is never inlined! -- Because the no-inline prag will prevent the wrapper ever -- being inlined at a call site. - -- - -- Furthermore, don't even expose strictness info - = return [ (fn_id, rhs) ] + = return [ (new_fn_id, rhs) ] | not loop_breaker , Just stable_unf <- certainlyWillInline dflags fn_unf @@ -304,24 +309,58 @@ tryWW dflags fam_envs is_rec fn_id rhs fn_info = idInfo fn_id inline_act = inlinePragmaActivation (inlinePragInfo fn_info) fn_unf = unfoldingInfo fn_info + (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info) - -- In practice it always will have a strictness - -- signature, even if it's a uninformative one - strict_sig = strictnessInfo fn_info - StrictSig (DmdType env wrap_dmds res_info) = strict_sig - - -- new_fn_id has the DmdEnv zapped. - -- (a) it is never used again - -- (b) it wastes space - -- (c) it becomes incorrect as things are cloned, because - -- we don't push the substitution into it - new_fn_id | isEmptyVarEnv env = fn_id - | otherwise = fn_id `setIdStrictness` - mkClosedStrictSig wrap_dmds res_info + new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) + -- See Note [Zapping DmdEnv after Demand Analyzer] and + -- See Note [Zapping Used Once info in WorkWrap] is_fun = notNull wrap_dmds is_thunk = not is_fun && not (exprIsHNF rhs) +{- +Note [Zapping DmdEnv after Demand Analyzer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the worker-wrapper pass we zap the DmdEnv. + +Why? + (a) it is never used again + (b) it wastes space + (c) it becomes incorrect as things are cloned, because + we don't push the substitution into it + +Why here? + * Because we don’t want to do it in the Demand Analyzer, as we never know + there when we are doing the last pass. + * We want them to be still there at the end of DmdAnal, so that + -ddump-str-anal contains them. + * We don’t want a second pass just for that. + * WorkWrap looks at all bindings anyways. + +We also need to do it in TidyCore to clean up after the final, +worker/wrapper-less run of the demand analyser. + +Note [Zapping Used Once info in WorkWrap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the worker-wrapper pass we zap the used once info in demands and in +strictness signatures. + +Why? + * The simplifier may happen to transform code in a way that invalidates the + data (see #11731 for an example). + * It is not used in later passes, up to code generation. + +So as the data is useless and possibly wrong, we want to remove it. The most +convenient place to do that is the worker wrapper phase, as it runs after every +run of the demand analyser besides the very last one (which is the one where we +want to _keep_ the info for the code generator). + +We do not do it in the demand analyser for the same reasons outlined in +Note [Zapping DmdEnv after Demand Analyzer] above. +-} + --------------------- splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr |