[Git][ghc/ghc][wip/simplifier-tweaks] More changes
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Aug 2 19:38:07 UTC 2023
Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC
Commits:
44c2a9f6 by Simon Peyton Jones at 2023-08-02T20:33:02+01:00
More changes
* No floating at all for join points
* Never inline j x = I x
Example: integerSignum !j = IS (integerSignum# j)
We want this to inline and then cancel with an enclosing case.
But it won't if we have changed it to
integerSignum x = case x of
IN a -> IS (...)
IS b -> IS (...)
IP c -> IS (...)
This involved changing
- UnfoldingGuidance to not say always-inline for j x = Ix
- callSiteInline to inline join points only if there is a real
benefit
- ok_to_dup_alt in Simplify.Iteration
* Row back (for now) on changes to GHC.Core.Utils.ExprIsCheap
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/IfaceToCore.hs
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1131,6 +1131,7 @@ lvlBind env (AnnNonRec bndr rhs)
-- (simplifier gets rid of them pronto)
|| isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
-- so we will ignore this case for now
+ || isJoinId bndr -- Don't float join points
|| not (profitableFloat env dest_lvl)
|| (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
-- We can't float an unlifted binding to top level (except
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -303,13 +303,17 @@ tryUnfolding logger opts !case_depth !inline_depth id lone_variable arg_infos
enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
- | unfoldingVeryAggressive opts
- -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
- | is_wf && some_benefit && small_enough
- -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
- | otherwise
- -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing
+ | isJoinId id
+ -> if or (zipWith scrut_arg arg_discounts arg_infos) && small_enough
+ then yes
+ else no
+ | unfoldingVeryAggressive opts -> yes
+ | is_wf && some_benefit && small_enough -> yes
+ | otherwise -> no
where
+ yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
+ no = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing
+
some_benefit = calc_some_benefit (length arg_discounts)
-- See Note [Avoid inlining into deeply nested cases]
depth_treshold = unfoldingCaseThreshold opts
@@ -322,6 +326,11 @@ tryUnfolding logger opts !case_depth !inline_depth id lone_variable arg_infos
extra_doc = vcat [ text "depth based penalty =" <+> int depth_penalty
, text "discounted size =" <+> int adjusted_size ]
+
+ -- True if the function body has a discount and the arg is a value
+ scrut_arg disc ValueArg = disc > 0
+ scrut_arg _ _ = False
+
where
-- Unpack the UnfoldingCache lazily because it may not be needed, and all
-- its fields are strict; so evaluating unf_cache at all forces all the
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -631,7 +631,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
, extendIdSubst (setInScopeFromF env floats) old_bndr $
DoneEx triv_rhs NotJoinPoint ) }
- else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs
+ else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs
; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
`setIdUnfolding` wrap_unf
floats' = floats `extendFloats` NonRec bndr' triv_rhs
@@ -639,7 +639,6 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
where
-- Force the occ_fs so that the old Id is not retained in the new Id.
!occ_fs = getOccFS bndr
- uf_opts = seUnfoldingOpts env
work_ty = coercionLKind co
info = idInfo bndr
work_arity = arityInfo info `min` typeArity work_ty
@@ -662,7 +661,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
= case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
| isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })
- _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs
+ _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs
tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings
= do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr
@@ -849,7 +848,7 @@ makeTrivial env top_lvl dmd occ_fs expr
-- the 'floats' from prepareRHS; but they are all fresh, so there is
-- no danger of introducing name shadowig in eta expansion
- ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2
+ ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2
; let final_id = addLetBndrInfo var arity_type unf
bind = NonRec final_id expr2
@@ -859,7 +858,6 @@ makeTrivial env top_lvl dmd occ_fs expr
where
id_info = vanillaIdInfo `setDemandInfo` dmd
expr_ty = exprType expr
- uf_opts = seUnfoldingOpts env
bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
-- True iff we can have a binding of this expression at this level
@@ -3785,7 +3783,7 @@ mkDupableContWithDmds env _
thumbsUpPlanA (Stop {}) = True
thumbsUpPlanA (Select {}) = dup_fun fun
-- False -- Using Plan B benefits carryPropagate
- -- in nofib digits-of-e2
+ -- in nofib digits-of-e2
thumbsUpPlanA (StrictArg {}) = False
thumbsUpPlanA (CastIt { sc_cont = k }) = thumbsUpPlanA k
thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k
@@ -3974,7 +3972,7 @@ ok_to_dup_alt case_bndr alt_bndrs alt_rhs
= if isJust (isDataConId_maybe v)
then -- See Note [Duplicating join points] (DJ3) for the
-- reason for this apparently strange test
- exprsFreeIds args `subVarSet` bndr_set
+ False -- exprsFreeIds args `subVarSet` bndr_set
else True -- Duplicating a simple call (f a b c) is fine,
-- (especially if f is itself a join point).
@@ -4411,29 +4409,29 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
| isStableUnfolding unf
= simplStableUnfolding env bind_cxt id rhs_ty arity unf
- | isExitJoinId id
- = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
- return noUnfolding
-
| freshly_born_join_point id
= -- This is a tricky one!
-- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]
return noUnfolding
+ | isExitJoinId id
+ = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
+ return noUnfolding
+
| otherwise
- = -- Otherwise, we end up retaining all the SimpleEnv
- let !opts = seUnfoldingOpts env
- in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs
+ = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs
where
- freshly_born_join_point id = isJoinId id && isManyOccs (idOccInfo id)
+ is_join_point = isJoinId id
+ freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id)
-- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627
-------------------
-mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
- -> InId -> OutExpr -> SimplM Unfolding
-mkLetUnfolding !uf_opts top_lvl src id new_rhs
- = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing)
+mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource
+ -> InId -> Bool -- True <=> this is a join point
+ -> OutExpr -> SimplM Unfolding
+mkLetUnfolding env top_lvl src id is_join new_rhs
+ = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In GHC.Iface.Tidy we currently assume that, if we want to
@@ -4441,8 +4439,11 @@ mkLetUnfolding !uf_opts top_lvl src id new_rhs
-- to expose. (We could instead use the RHS, but currently
-- we don't.) The simple thing is always to have one.
where
- -- Might as well force this, profiles indicate up to 0.5MB of thunks
- -- just from this site.
+ -- !opts: otherwise, we end up retaining all the SimpleEnv
+ !uf_opts = seUnfoldingOpts env
+
+ -- Might as well force this, profiles indicate up to
+ -- 0.5MB of thunks just from this site.
!is_top_lvl = isTopLevel top_lvl
-- See Note [Force bottoming field]
!is_bottoming = isDeadEndId id
@@ -4497,14 +4498,13 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
-- See Note [Top-level flag on inline rules] in GHC.Core.Unfold
_other -- Happens for INLINABLE things
- -> mkLetUnfolding uf_opts top_lvl src id expr' }
+ -> mkLetUnfolding env top_lvl src id False expr' }
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
| otherwise -> return noUnfolding -- Discard unstable unfoldings
where
- uf_opts = seUnfoldingOpts env
-- Forcing this can save about 0.5MB of max residency and the result
-- is small and easy to compute so might as well force it.
top_lvl = bindContextLevel bind_cxt
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2190,7 +2190,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
= (poly_id `setIdUnfolding` unf, poly_rhs)
where
poly_rhs = mkLams tvs_here rhs
- unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing
+ unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing
-- We want the unfolding. Consider
-- let
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -771,6 +771,7 @@ add_info env old_bndr top_level new_rhs new_bndr
unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc
(isTopLevel top_level)
False -- may be bottom or not
+ False -- Not a join point
new_rhs Nothing
wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -239,16 +239,17 @@ inlineBoringOk e
calcUnfoldingGuidance
:: UnfoldingOpts
-> Bool -- Definitely a top-level, bottoming binding
+ -> Bool -- True <=> join point
-> CoreExpr -- Expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
+calcUnfoldingGuidance opts is_top_bottoming is_join (Tick t expr)
| not (tickishIsCode t) -- non-code ticks don't matter for unfolding
- = calcUnfoldingGuidance opts is_top_bottoming expr
-calcUnfoldingGuidance opts is_top_bottoming expr
+ = calcUnfoldingGuidance opts is_top_bottoming is_join expr
+calcUnfoldingGuidance opts is_top_bottoming is_join expr
= case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
- | uncondInline expr n_val_bndrs size
+ | uncondInline is_join expr n_val_bndrs body size
-> UnfWhen { ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtOk
, ug_arity = n_val_bndrs } -- Note [INLINE for small functions]
@@ -414,11 +415,14 @@ sharing the wrapper closure.
The solution: don’t ignore coercion arguments after all.
-}
-uncondInline :: CoreExpr -> Arity -> Int -> Bool
+uncondInline :: Bool -> CoreExpr -> Arity -> CoreExpr -> Int -> Bool
-- Inline unconditionally if there no size increase
-- Size of call is arity (+1 for the function)
-- See Note [INLINE for small functions]
-uncondInline rhs arity size
+uncondInline is_join rhs arity body size
+ | is_join = case collectArgs body of
+ (Var {}, args) -> all exprIsTrivial args
+ _ -> False
| arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
| otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4)
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -57,6 +57,7 @@ mkFinalUnfolding' opts src strict_sig expr
= mkUnfolding opts src
True {- Top level -}
(isDeadEndSig strict_sig)
+ False {- Not a join point -}
expr
-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first
@@ -79,7 +80,7 @@ mkCompulsoryUnfolding expr
mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
mkSimpleUnfolding !opts rhs
- = mkUnfolding opts VanillaSrc False False rhs Nothing
+ = mkUnfolding opts VanillaSrc False False False rhs Nothing
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
@@ -117,7 +118,7 @@ mkWorkerUnfolding opts work_fn
= mkCoreUnfolding src top_lvl new_tmpl Nothing guidance
where
new_tmpl = simpleOptExpr opts (work_fn tmpl)
- guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
+ guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl
mkWorkerUnfolding _ _ _ = noUnfolding
@@ -156,7 +157,7 @@ mkInlineUnfoldingWithArity opts src arity expr
mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
mkInlinableUnfolding opts src expr
- = mkUnfolding (so_uf_opts opts) src False False expr' Nothing
+ = mkUnfolding (so_uf_opts opts) src False False False expr' Nothing
where
expr' = simpleOptExpr opts expr
@@ -319,16 +320,17 @@ mkUnfolding :: UnfoldingOpts
-> Bool -- Is top-level
-> Bool -- Definitely a bottoming binding
-- (only relevant for top-level bindings)
+ -> Bool -- True <=> join point
-> CoreExpr
-> Maybe UnfoldingCache
-> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
-mkUnfolding opts src top_lvl is_bottoming expr cache
+mkUnfolding opts src top_lvl is_bottoming is_join expr cache
= mkCoreUnfolding src top_lvl expr cache guidance
where
is_top_bottoming = top_lvl && is_bottoming
- guidance = calcUnfoldingGuidance opts is_top_bottoming expr
+ guidance = calcUnfoldingGuidance opts is_top_bottoming is_join expr
-- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1266,11 +1266,13 @@ exprIsCheapX ok_app e
go _ (Type {}) = True
go _ (Coercion {}) = True
go n (Cast e _) = go n e
- go n (Case scrut _ _ alts)
- | [Alt _ _ rhs] <- alts = ok scrut && ok rhs
- | otherwise = False
--- go n (Case scrut _ _ alts) = ok scrut &&
--- and [ go n rhs | Alt _ _ rhs <- alts ]
+-- Experiment: try restricting single-branch cases
+-- Another idea: use Simplify.Iteration.alts_would_dup
+-- go n (Case scrut _ _ alts)
+-- | [Alt _ _ rhs] <- alts = ok scrut && ok rhs
+-- | otherwise = False
+ go n (Case scrut _ _ alts) = ok scrut &&
+ and [ go n rhs | Alt _ _ rhs <- alts ]
go n (Tick t e) | tickishCounts t = False
| otherwise = go n e
go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1783,7 +1783,7 @@ tcUnfolding toplvl name _ info (IfCoreUnfold src cache if_guidance if_expr)
; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr
; let guidance = case if_guidance of
IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok
- IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming expr
+ IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming False expr
-- See Note [Tying the 'CoreUnfolding' knot]
; return $ mkCoreUnfolding src True expr (Just cache) guidance }
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44c2a9f659e8d67e9b8fdb46c32764b6dfb2b339
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44c2a9f659e8d67e9b8fdb46c32764b6dfb2b339
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/20230802/642b8791/attachment-0001.html>
More information about the ghc-commits
mailing list