[Git][ghc/ghc][wip/T24623] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jun 14 18:53:55 UTC 2024
Simon Peyton Jones pushed to branch wip/T24623 at Glasgow Haskell Compiler / GHC
Commits:
d92d78a5 by Simon Peyton Jones at 2024-06-14T19:53:30+01:00
Wibbles
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Types/Demand.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1081,30 +1081,30 @@ dmdAnalRhsSig
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
-dmdAnalRhsSig top_lvl rec_flag env let_subdmd id rhs
+dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs
= -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $
(final_env, weak_fvs, final_id, final_rhs)
where
ww_arity = workWrapArity id rhs
-- See Note [WorkWrap arity and join points, point (1)]
- body_subdmd | isJoinId id = let_subdmd
- | otherwise = topSubDmd
+ body_sd | isJoinId id = let_sd
+ | otherwise = topSubDmd
-- See Note [Demand analysis for join points]
-- See Note [Invariants on join points] invariant 2b, in GHC.Core
-- ww_arity matches the join arity of the join point
- adjusted_body_subdmd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_subdmd
+ adjusted_body_sd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_sd
-- See Note [Unboxed demand on function bodies returning small products]
- rhs_subdmd = mkCalledOnceDmds ww_arity adjusted_body_subdmd
+ rhs_sd = mkCalledOnceDmds ww_arity adjusted_body_sd
- WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_subdmd rhs
+ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs
DmdType rhs_env rhs_dmds = rhs_dmd_ty
(final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity
rhs_dmds (de_div rhs_env) rhs'
- dmd_sig_arity = ww_arity + calledOnceArity body_subdmd
+ dmd_sig_arity = ww_arity + calledOnceArity body_sd
sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)
opts = ae_opts env
@@ -1248,9 +1248,9 @@ branch does so too, so we are fine. So, as usual, we need to transport demands
on free variables to the call site(s). Compare Note [Lazy and unleashable free
variables].
-The implementation is easy: see `body_subdmd` in`dmdAnalRhsSig`. When analysing
+The implementation is easy: see `body_sd` in`dmdAnalRhsSig`. When analysing
a join point, we can analyse its body (after stripping off the join binders,
-here just 'y') with the demand from the entire join-binding (written `let_subdmd`
+here just 'y') with the demand from the entire join-binding (written `let_sd`
here).
Another win for join points! #13543.
@@ -1277,7 +1277,7 @@ Consider
The entire thing is in a C(1,L) context, so we will analyse j's body, namely
\y. error "urk"
-with demand C(C(1,L)). See `rhs_subdmd` in `dmdAnalRhsSig`. That will produce
+with demand C(C(1,L)). See `rhs_sd` in `dmdAnalRhsSig`. That will produce
a demand signature of <A><A>b: and indeed `j` diverges when given two arguments.
BUT we do /not/ want to worker/wrapper `j` with two arguments. Suppose we have
@@ -1321,7 +1321,7 @@ Conclusion:
Note [The demand for the RHS of a binding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_subdmd` in
+Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_sd` in
which to analyse `rhs`.
The demand we use is:
@@ -2009,12 +2009,9 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
-- of the function, both because that's kosher, and because CPR analysis
-- uses the info on the binders directly.
where
- opts = ae_opts env
- (bndrs, _body) = collectBinders rhs -- length bndrs >= ww_arity
- unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ]
- max_wkr_args = dmd_max_worker_args opts `max` unarise_arity
- -- This is the budget initialisation step of
- -- Note [Worker argument budget]
+ opts = ae_opts env
+ (bndrs, _body) = collectBinders rhs
+ -- NB: in the interesting code path, count isId bndrs >= ww_arity
arg_triples :: [(Type, StrictnessMark, Demand)]
arg_triples = take ww_arity $
@@ -2030,6 +2027,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
-- The remaining budget from one layer becomes the initial
-- budget for the next layer down. See Note [Worker argument budget]
(remaining_budget, ww_arg_dmds) = go_args (MkB max_wkr_args remaining_budget) arg_triples
+ unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ]
+ max_wkr_args = dmd_max_worker_args opts `max` unarise_arity
+ -- This is the budget initialisation step of
+ -- Note [Worker argument budget]
get_dmd :: Id -> Demand
get_dmd bndr
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -762,7 +762,7 @@ splitFun ww_opts fn_id rhs
= warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
"splitFun"
(ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
- do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr
+ do { mb_stuff <- mkWwBodies ww_opts fn_id ww_arity arg_vars (exprType body) wrap_dmds cpr
; case mb_stuff of
Nothing -> -- No useful wrapper; leave the binding alone
return [(fn_id, rhs)]
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -159,6 +159,7 @@ nop_fn body = body
mkWwBodies :: WwOpts
-> Id -- ^ The original function
+ -> Arity -- ^ Worker/wrapper arity
-> [Var] -- ^ Manifest args of original function
-> Type -- ^ Result type of the original function,
-- after being stripped of args
@@ -205,7 +206,7 @@ mkWwBodies :: WwOpts
-- and beta-redexes]), which allows us to apply the same split to function body
-- and its unfolding(s) alike.
--
-mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
+mkWwBodies opts fun_id ww_arity arg_vars res_ty demands res_cpr
= do { massertPpr arity_ok
(text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands)
@@ -271,8 +272,7 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
| otherwise
= False
- ww_arity = count isId arg_vars -- Work/wrap arity
- n_dmds = length demands
+ n_dmds = length demands
arity_ok | isJoinId fun_id = ww_arity <= n_dmds
| otherwise = ww_arity == n_dmds
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -1041,11 +1041,7 @@ peelManyCalls k sd = go k C_11 sd
calledOnceArity :: SubDemand -> Arity
calledOnceArity sd = go 0 sd
where
- go n (Call C_11 sd) = go (n+1) sd
- -- NB: /Not/ viewCall, because we'd go infinitely deep on a Poly without
- -- knowing the type arity (the upper bound for the threshold).
- -- Besides, we only really are interested in C_11 or C_01 Calls for
- -- which we'll never use Poly anyway (cf. 'CardNonOnce').
+ go n (viewCall -> Call C_11 sd) = go (n+1) sd
go n _ = n
-- | Extract the 'SubDemand' of a 'Demand'.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d92d78a5021a10571a1629afa335c70a562eb62b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d92d78a5021a10571a1629afa335c70a562eb62b
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/20240614/aebd52e8/attachment-0001.html>
More information about the ghc-commits
mailing list