diff options
Diffstat (limited to 'compiler/GHC/Core/Opt/DmdAnal.hs')
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 72 |
1 files changed, 55 insertions, 17 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 373bdcb033..14ee7419bf 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -274,7 +274,7 @@ dmdAnalBindLetUp :: TopLevelFlag dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) where WithDmdType body_ty body' = anal_body env - WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id + WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id !id' = setBindIdDemandInfo top_lvl id id_dmd (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs @@ -412,7 +412,7 @@ dmdAnal' env dmd (Lam var body) -- body_dmd: a demand to analyze the body WithDmdType body_ty body' = dmdAnal env body_dmd body - WithDmdType lam_ty var' = annotateLamIdBndr env notArgOfDfun body_ty var + WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var new_dmd_type = multDmdType n lam_ty in WithDmdType new_dmd_type (Lam var' body') @@ -424,7 +424,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr + WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! (_ :* case_bndr_sd) = case_bndr_dmd @@ -1282,16 +1282,15 @@ annotateBndr env dmd_ty var | otherwise = WithDmdType dmd_ty var where new_id = setIdDemandInfo var dmd - WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var + WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty var annotateLamIdBndr :: AnalEnv - -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body -> Id -- Lambda binder -> WithDmdType Id -- Demand type of lambda -- and binder annotated with demand -annotateLamIdBndr env arg_of_dfun dmd_ty id +annotateLamIdBndr env dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids = assert (isId id) $ @@ -1307,7 +1306,7 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id (unf_ty, _) = dmdAnalStar env dmd unf main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id + WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1394,10 +1393,6 @@ forget that fact, otherwise we might make 'x' absent when it isn't. ************************************************************************ -} -type DFunFlag = Bool -- indicates if the lambda being considered is in the - -- sequence of lambdas at the top of the RHS of a dfun -notArgOfDfun :: DFunFlag -notArgOfDfun = False data AnalEnv = AE { ae_strict_dicts :: !Bool -- ^ Enable strict dict @@ -1464,13 +1459,13 @@ findBndrsDmds env dmd_ty bndrs go dmd_ty [] = WithDmdType dmd_ty [] go dmd_ty (b:bs) | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env False dmd_ty1 b + WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b in WithDmdType dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand +findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] -findBndrDmd env arg_of_dfun dmd_ty id +findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ WithDmdType dmd_ty' dmd' where @@ -1482,19 +1477,62 @@ findBndrDmd env arg_of_dfun dmd_ty id id_ty = idType id strictify dmd + -- See Note [Making dictionaries strict] | ae_strict_dicts env -- We never want to strictify a recursive let. At the moment -- annotateBndr is only call for non-recursive lets; if that -- changes, we need a RecFlag parameter and another guard here. - , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun] = strictifyDictDmd id_ty dmd | otherwise = dmd fam_envs = ae_fam_envs env -{- Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Making dictionaries strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? + +* Generally CBV is more efficient. + +* Dictionaries are always non-bottom; and never take much work to + compute. E.g. a dfun from an instance decl always returns a dicionary + record immediately. See DFunUnfolding in CoreSyn. + See also Note [Recursive superclasses] in TcInstDcls. + +* The strictness analyser will then unbox dictionaries and pass the + methods individually, rather than in a bundle. If there are a lot of + methods that might be bad; but worker/wrapper already does throttling. + +* A newtype dictionary is *not* always non-bottom. E.g. + class C a where op :: a -> a + instance C Int where op = error "urk" + Now a value of type (C Int) is just a newtype wrapper (a cast) around + the error thunk. Don't strictify these! + +See #17758 for more background and perf numbers. + +The implementation is extremly simple: just make the strictness +analyser strictify the demand on a dictionary binder in +'findBndrDmd'. + +However there is one case where this can make performance worse. +For the principle consider some function at the core level: + myEq :: Eq a => a -> a -> Bool + myEq eqDict x y = ((==) eqDict) x y +If we make the dictionary strict then WW can fire turning this into: + $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool + $wmyEq eq x y = eq x y +Which *usually* performs better. However if the dictionary is known we +are far more likely to inline a function applied to the dictionary than +to inline one applied to a function. Sometimes this makes just enough +of a difference to stop a function from inlining. This is documented in +#18421. + +It's somewhat similar to Note [Do not unpack class dictionaries] although +here our problem is with the inliner, not the specializer. + +Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a |