[Git][ghc/ghc][wip/nested-cpr-2019] 2 commits: Refactoring around cprAnalBind
Sebastian Graf
gitlab at gitlab.haskell.org
Mon May 18 15:26:37 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
3dde931c by Sebastian Graf at 2020-05-18T16:36:42+02:00
Refactoring around cprAnalBind
- - - - -
3ae7eb1f by Sebastian Graf at 2020-05-18T17:08:43+02:00
Fix case binder CPR by not looking into unfoldings of case binders
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Types/Cpr.hs
Changes:
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -119,9 +119,9 @@ cprAnalTopBind :: AnalEnv
-> CoreBind
-> (AnalEnv, CoreBind)
cprAnalTopBind env (NonRec id rhs)
- = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')
+ = (env', NonRec id' rhs')
where
- (id', rhs') = cprAnalBind TopLevel env [] id rhs
+ (id', rhs', env') = cprAnalBind TopLevel env noWidening [] id rhs
cprAnalTopBind env (Rec pairs)
= (env', Rec pairs')
@@ -196,7 +196,7 @@ cprAnal' env args (Lam var body)
(arg_ty, body_args)
| ty:args' <- args = (ty, args') -- We know things about the argument, for example from a StrictSig or an incoming argument. NB: This can never be an anonymous (non-let-bound) lambda! The simplifier would have eliminated the necessary (App (Lam{} |> co) _) construct.
| otherwise = (topCprType, []) -- An anonymous lambda or no info on its argument
- env' = extendAnalEnv env var (CprSig arg_ty) -- TODO: I think we also need to store assumed argument strictness (which would be all lazy here) in the env
+ env' = extendSigEnv env var (CprSig arg_ty) -- TODO: I think we also need to store assumed argument strictness (which would be all lazy here) in the env
(body_ty, body') = cprAnal env' body_args body
lam_ty = abstractCprTy body_ty
@@ -213,9 +213,8 @@ cprAnal' env args (Case scrut case_bndr ty alts)
cprAnal' env args (Let (NonRec id rhs) body)
= (body_ty, Let (NonRec id' rhs') body')
where
- (id', rhs') = cprAnalBind NotTopLevel env args id rhs
- env' = extendAnalEnv env id' (idCprInfo id')
- (body_ty, body') = cprAnal env' args body
+ (id', rhs', env') = cprAnalBind NotTopLevel env noWidening args id rhs
+ (body_ty, body') = cprAnal env' args body
cprAnal' env args (Let (Rec pairs) body)
= body_ty `seq` (body_ty, Let (Rec pairs') body')
@@ -239,7 +238,7 @@ cprAnalAlt env args case_bndr case_bndr_ty (con@(DataAlt dc),bndrs,rhs)
cprAnalAlt env args case_bndr case_bndr_ty (con,bndrs,rhs)
= (rhs_ty, (con, bndrs, rhs'))
where
- env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty)
+ env' = extendSigEnv env case_bndr (CprSig case_bndr_ty)
(rhs_ty, rhs') = cprAnal env' args rhs
--
@@ -256,6 +255,9 @@ cprTransform env args id
sig
where
sig
+ -- Local let-bound
+ | Just sig <- lookupSigEnv env id
+ = cprTransformSig (idStrictness id) sig args
-- See Note [CPR for expandable unfoldings]
| Just rhs <- cprExpandUnfolding_maybe id
= fst $ cprAnal env args rhs
@@ -265,9 +267,6 @@ cprTransform env args id
-- Imported function or data con worker
| isGlobalId id
= cprTransformSig (idStrictness id) (idCprInfo id) args
- -- Local let-bound
- | Just sig <- lookupSigEnv env id
- = cprTransformSig (idStrictness id) sig args
| otherwise
= topCprType
@@ -275,57 +274,27 @@ cprTransform env args id
-- * Bindings
--
--- Recursive bindings
-cprFix
- :: TopLevelFlag
- -> AnalEnv -- Does not include bindings for this binding
- -> [CprType]
- -> [(Id,CoreExpr)]
- -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
-cprFix top_lvl env str orig_pairs
- = loop 1 initial_pairs
- where
- init_sig id = mkCprSig (idArity id) divergeCpr
- -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
- initial_pairs | ae_virgin env = [(setIdCprInfo id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
- | otherwise = orig_pairs
-
- -- The fixed-point varies the idCprInfo field of the binders, and terminates if that
- -- annotation does not change any more.
- loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
- loop n pairs
- | found_fixpoint = (final_anal_env, pairs')
- | otherwise = -- pprTrace "cprFix:loop" (ppr n <+> ppr (map fst pairs)) $
- loop (n+1) pairs'
- where
- found_fixpoint = selector pairs' == selector pairs
- selector = map (idCprInfo . fst)
- first_round = n == 1
- pairs' = step first_round pairs
- final_anal_env = extendAnalEnvs env (map fst pairs')
-
- step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
- step first_round pairs = pairs'
- where
- -- In all but the first iteration, delete the virgin flag
- start_env | first_round = env
- | otherwise = nonVirgin env
+--
+-- ** Widening
+--
- start = extendAnalEnvs start_env (map fst pairs)
+type Widening = CprSig -> CprSig
- (_, pairs') = mapAccumL my_downRhs start pairs
+noWidening :: Widening
+noWidening = id
- my_downRhs env (id,rhs)
- = (env', (id2, rhs'))
- where
- (id1, rhs') = cprAnalBind top_lvl env str id rhs
- -- See Note [Ensuring termination of fixed-point iteration]
- id2 = setIdCprInfo id1 $ pruneSig mAX_DEPTH $ markDiverging $ idCprInfo id1
- env' = extendAnalEnv env id2 (idCprInfo id2)
+-- | A widening operator on 'CprSig' to ensure termination of fixed-point
+-- iteration. See Note [Ensuring termination of fixed-point iteration]
+depthWidening :: Widening
+depthWidening = pruneSig mAX_DEPTH . markDiverging
mAX_DEPTH :: Int
mAX_DEPTH = 4
+pruneSig :: Int -> CprSig -> CprSig
+pruneSig d (CprSig cpr_ty)
+ = CprSig $ cpr_ty { ct_cpr = pruneDeepCpr d (ct_cpr cpr_ty) }
+
-- TODO: We need the lubCpr with the initial CPR because
-- of functions like iterate, which we would CPR
-- multiple levels deep, thereby changing termination
@@ -333,35 +302,26 @@ mAX_DEPTH = 4
markDiverging :: CprSig -> CprSig
markDiverging (CprSig cpr_ty) = CprSig $ cpr_ty { ct_cpr = ct_cpr cpr_ty `lubCpr` divergeCpr }
--- | A widening operator on 'CprSig' to ensure termination of fixed-point
--- iteration. See Note [Ensuring termination of fixed-point iteration]
-pruneSig :: Int -> CprSig -> CprSig
-pruneSig d (CprSig cpr_ty)
- = CprSig $ cpr_ty { ct_cpr = pruneDeepCpr d (ct_cpr cpr_ty) }
-
-unboxingStrategy :: AnalEnv -> UnboxingStrategy
-unboxingStrategy env ty dmd
- = prj <$> wantToUnbox (ae_fam_envs env) has_inlineable_prag ty dmd
- where
- prj (dmds, DataConAppContext { dcac_dc = dc, dcac_arg_tys = tys_w_str })
- = (dc, map fst tys_w_str, dmds)
- -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
- -- function, we just assume that we aren't. That flag is only relevant
- -- to Note [Do not unpack class dictionaries], the few unboxing
- -- opportunities on dicts it prohibits are probably irrelevant to CPR.
- has_inlineable_prag = False
+--
+-- ** Analysing a binding (one-round, the non-recursive case)
+--
-- | Process the RHS of the binding for a sensible arity, add the CPR signature
-- to the Id, and augment the environment with the signature as well.
cprAnalBind
:: TopLevelFlag
-> AnalEnv
+ -> Widening -- ^ We want to specify 'depthWidening' in fixed-point iteration
-> [CprType]
-> Id
-> CoreExpr
- -> (Id, CoreExpr)
-cprAnalBind top_lvl env args id rhs
- = (id', rhs')
+ -> (Id, CoreExpr, AnalEnv)
+cprAnalBind top_lvl env widening args id rhs
+ -- See Note [CPR for expandable unfoldings]
+ | isJust (cprExpandUnfolding_maybe id)
+ = (id, rhs, env)
+ | otherwise
+ = (id', rhs', env')
where
arg_tys = fst (splitFunNewTys (idType id))
-- We compute the Termination and CPR transformer based on the strictness
@@ -387,16 +347,13 @@ cprAnalBind top_lvl env args id rhs
| stays_thunk = trimCprTy rhs_ty
-- See Note [CPR for sum types]
| returns_sum = trimCprTy rhs_ty
- -- See Note [CPR for expandable unfoldings]
- | will_expand = topCprType
| otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
- -- We prune so that we discard too deep info on e.g. TyCon bindings
dflags = ae_dflags env
- sig = pruneSig mAX_DEPTH $ mkCprSigForArity dflags (idArity id) rhs_ty'
- id' = -- pprTrace "cprAnalBind" (ppr id $$ ppr sig) $
- setIdCprInfo id sig
+ sig = widening $ mkCprSigForArity dflags (idArity id) rhs_ty'
+ (id', env') = -- pprTrace "cprAnalBind" (ppr id $$ ppr sig) $
+ (setIdCprInfo id sig, extendSigEnv env id sig)
-- See Note [CPR for thunks]
stays_thunk = is_thunk && not_strict
@@ -406,8 +363,18 @@ cprAnalBind top_lvl env args id rhs
(_, ret_ty) = splitPiTys (idType id)
not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)
returns_sum = not (isTopLevel top_lvl) && not_a_prod
- -- See Note [CPR for expandable unfoldings]
- will_expand = isJust (cprExpandUnfolding_maybe id)
+
+unboxingStrategy :: AnalEnv -> UnboxingStrategy
+unboxingStrategy env ty dmd
+ = prj <$> wantToUnbox (ae_fam_envs env) has_inlineable_prag ty dmd
+ where
+ prj (dmds, DataConAppContext { dcac_dc = dc, dcac_arg_tys = tys_w_str })
+ = (dc, map fst tys_w_str, dmds)
+ -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
+ -- function, we just assume that we aren't. That flag is only relevant
+ -- to Note [Do not unpack class dictionaries], the few unboxing
+ -- opportunities on dicts it prohibits are probably irrelevant to CPR.
+ has_inlineable_prag = False
cprExpandUnfolding_maybe :: Id -> Maybe CoreExpr
cprExpandUnfolding_maybe id = do
@@ -416,6 +383,58 @@ cprExpandUnfolding_maybe id = do
guard (isActiveIn 0 (idInlineActivation id))
expandUnfolding_maybe (idUnfolding id)
+--
+-- ** Analysing recursive bindings
+--
+
+-- | Fixed-point iteration
+cprFix
+ :: TopLevelFlag
+ -> AnalEnv -- Does not include bindings for this binding
+ -> [CprType]
+ -> [(Id,CoreExpr)]
+ -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
+cprFix top_lvl env args orig_pairs
+ = loop 1 initial_pairs
+ where
+ init_sig id
+ | isJust (cprExpandUnfolding_maybe id) = topCprSig
+ | otherwise = mkCprSig (idArity id) divergeCpr
+ -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
+ initial_pairs | ae_virgin env = [(setIdCprInfo id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
+ | otherwise = orig_pairs
+
+ -- The fixed-point varies the idCprInfo field of the binders, and terminates if that
+ -- annotation does not change any more.
+ loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
+ loop n pairs
+ | found_fixpoint = (final_anal_env, pairs')
+ | otherwise = -- pprTrace "cprFix:loop" (ppr n <+> ppr (map fst pairs)) $
+ loop (n+1) pairs'
+ where
+ found_fixpoint = selector pairs' == selector pairs
+ selector = map (idCprInfo . fst)
+ first_round = n == 1
+ pairs' = step first_round pairs
+ final_anal_env = extendSigEnvs env (map fst pairs')
+
+ step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+ step first_round pairs = pairs'
+ where
+ -- In all but the first iteration, delete the virgin flag
+ start_env | first_round = env
+ | otherwise = nonVirgin env
+
+ start = extendSigEnvs start_env (map fst pairs)
+
+ (_, pairs') = mapAccumL anal_bind start pairs
+
+ anal_bind env (id,rhs)
+ = (env', (id', rhs'))
+ where
+ -- See Note [Ensuring termination of fixed-point iteration]
+ (id', rhs', env') = cprAnalBind top_lvl env depthWidening args id rhs
+
{- Note [Arity trimming for CPR signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Although it doesn't affect correctness of the analysis per se, we have to trim
@@ -478,17 +497,17 @@ emptyAnalEnv dflags fam_envs
, ae_fam_envs = fam_envs
}
-extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
-extendAnalEnv env id sig
+extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
+extendSigEnv env id sig
= env { ae_sigs = extendVarEnv (ae_sigs env) id sig }
-extendAnalEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
-extendAnalEnvList env ids_cprs
+extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
+extendSigEnvList env ids_cprs
= env { ae_sigs = extendVarEnvList (ae_sigs env) ids_cprs }
-- | Extend an environment with the CPR signatures attached to the id
-extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv
-extendAnalEnvs env ids
+extendSigEnvs :: AnalEnv -> [Id] -> AnalEnv
+extendSigEnvs env ids
= env { ae_sigs = sigs' }
where
sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]
@@ -502,7 +521,7 @@ nonVirgin env = env { ae_virgin = False }
extendEnvForDataAlt :: AnalEnv -> Id -> CprType -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a DataAlt case alternative]
extendEnvForDataAlt env case_bndr case_bndr_ty dc bndrs
- = extendAnalEnv env' case_bndr (CprSig case_bndr_ty')
+ = extendSigEnv env' case_bndr (CprSig case_bndr_ty')
where
tycon = dataConTyCon dc
is_product = isJust (isDataProductTyCon_maybe tycon)
@@ -517,7 +536,7 @@ extendEnvForDataAlt env case_bndr case_bndr_ty dc bndrs
| Just fields <- splitConCprTy dc case_bndr_ty'
, let ids = filter isId bndrs
, let cpr_tys = map (CprSig . CprType 0) fields
- = extendAnalEnvList env (zipEqual "extendEnvForDataAlt" ids cpr_tys)
+ = extendSigEnvList env (zipEqual "extendEnvForDataAlt" ids cpr_tys)
| otherwise
= env
@@ -746,6 +765,14 @@ In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one
for each data declaration. It's wasteful to attach CPR signatures to each of
them (and intractable in case of Nested CPR).
+Also we don't need to analyse RHSs of expandable bindings: The CPR signature of
+the binding is never consulted and there may not be let or case expressions
+nested inside its RHS. In which case we also don't record a signature in the
+local AnalEnv. Doing so would override looking into the unfolding. Why not give
+the expandable case in cprTransform a higher priority then? Because then *all*
+case binders would get the CPR property, regardless of -fcase-binder-cpr-depth,
+because case binders have expandable unfoldings.
+
Tracked by #18154.
Note [CPR examples]
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -318,7 +318,8 @@ conCprType con_tag args = CprType 0 (conCpr con_tag cprs)
markOptimisticConCprType :: DataCon -> CprType -> CprType
markOptimisticConCprType dc _ty@(CprType n cpr)
- = ASSERT2( n == 0, ppr _ty ) CprType 0 (optimisticConCpr con_tag fields)
+ = -- pprTraceWith "markOptimisticConCpr" (\ty' -> ppr _ty $$ ppr ty') $
+ ASSERT2( n == 0, ppr _ty ) CprType 0 (optimisticConCpr con_tag fields)
where
con_tag = dataConTag dc
wkr_arity = dataConRepArity dc
@@ -364,8 +365,9 @@ trimCprTy :: CprType -> CprType
trimCprTy (CprType arty cpr) = CprType arty (trimCpr cpr)
zonkOptimisticCprTy :: Int -> CprType -> CprType
-zonkOptimisticCprTy max_depth (CprType arty cpr)
- = CprType arty (zonk max_depth cpr)
+zonkOptimisticCprTy max_depth _ty@(CprType arty cpr)
+ = -- pprTraceWith "zonkOptimisticCprTy" (\ty' -> ppr max_depth <+> ppr _ty <+> ppr ty') $
+ CprType arty (zonk max_depth cpr)
where
-- | The Int is the amount of "fuel" left; when it reaches 0, we no longer
-- turn OptimisticCpr into Cpr, but into NoMoreCpr.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c2eedad466fabeb8367a3d7617f13e87df9778f...3ae7eb1f530eba8e30fb85a0f5d018e15666b882
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c2eedad466fabeb8367a3d7617f13e87df9778f...3ae7eb1f530eba8e30fb85a0f5d018e15666b882
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200518/9b0cff4c/attachment-0001.html>
More information about the ghc-commits
mailing list