Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: 2c0b59c5 by Simon Peyton Jones at 2025-07-02T16:32:44+01:00 Fix inlineBoringOk See (IB6) in Note [inlineBoringOk] This appears to solve the slowdown in `countdownEffectfulDynLocal` in the `effectful` library. - - - - - 3 changed files: - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/CoreToStg.hs Changes: ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -1506,6 +1506,10 @@ There are a number of wrinkles guide inlining) treats (MkUC e) as the same size as `e`, and similarly (op d). + - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we + always-inline (MkUC op), even into a boring context. See (IB6) + in Note [inlineBoringOk] + (UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for non-unary classes, but just an /ordinary/ unfolding for unary classes. instance Num a => Num [a] where { .. } -- (I1) ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -278,6 +278,14 @@ inlining a saturated call is no bigger than `body`. Some wrinkles: whose body is, in some sense, just as small as (g x y z). But `inlineBoringOk` doesn't attempt anything fancy; it just looks for a function call with trivial arguments, Keep it simple. + +(IB6) If we have an unfolding (K op) where K is a unary-class data constructor, + we want to inline it! So that we get calls (f op), which in turn can see (in + STG land) that `op` is already evaluated and properly tagged. (If `op` isn't + trivial we will have baled out before we get to the Var case.) This made + a big difference in benchmarks for the `effectful` library; details in !10479. + + See Note [Unary class magic] in GHC/Core/TyCon. -} inlineBoringOk :: CoreExpr -> Bool @@ -291,6 +299,7 @@ inlineBoringOk e is_fun = isValFun e go :: Int -> CoreExpr -> Bool + -- credit = #(value lambdas) = #(value args) go credit (Lam x e) | isRuntimeVar x = go (credit+1) e | otherwise = go credit e -- See (IB3) @@ -309,13 +318,15 @@ inlineBoringOk e go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e -- See (IB3) + -- Lit: we assume credit >= 0; literals aren't functions go _ (Lit l) = litIsTrivial l && boringCxtOk - -- We assume credit >= 0; literals aren't functions go credit (Var v) | isDataConWorkId v, is_fun = boringCxtOk -- See (IB2) + | isUnaryClassId v = boringCxtOk -- See (IB6) | credit >= 0 = boringCxtOk | otherwise = boringCxtNotOk - go _ _ = boringCxtNotOk + + go _ _ = boringCxtNotOk isValFun :: CoreExpr -> Bool -- True of functions with at least ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -836,19 +836,20 @@ myCollectArgs expr res_ty where go h@(Var f) as ts | isUnaryClassId f, (the_arg:as') <- dropWhile isTypeArg as - = go the_arg as' ts + = go the_arg as' ts -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon -- isUnaryClassId includes both the class op and the data-con - | otherwise = (h, as, ts) - go (App f a) as ts = go f (a:as) ts - go (Cast e _) as ts = go e as ts + | otherwise + = (h, as, ts) - go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as) - (ppr e $$ ppr as $$ ppr ts) $ - -- See Note [Ticks in applications] - -- ticks can appear in type apps - go e as (coreToStgTick res_ty t : ts) + go (App f a) as ts = go f (a:as) ts + go (Cast e _) as ts = go e as ts + go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as) + (ppr e $$ ppr as $$ ppr ts) $ + -- See Note [Ticks in applications] + -- ticks can appear in type apps + go e as (coreToStgTick res_ty t : ts) go (Case e b _ alts) as ts -- Just like in exprIsTrivial! -- Otherwise we fall over in case we encounter @@ -859,10 +860,11 @@ myCollectArgs expr res_ty | Just rhs <- isUnsafeEqualityCase e b alts = go rhs as ts -- Discards unsafeCoerce in App heads - go (Lam b e) as ts - | isTyVar b = go e (drop 1 as) ts -- Note [Collect args] + go (Lam b e) as ts + | isTyVar b + = go e (drop 1 as) ts -- Note [Collect args] - go e as ts = (e, as, ts) + go e as ts = (e, as, ts) {- Note [Collect args] ~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c0b59c57c4c28abcf62b838e56870d6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c0b59c57c4c28abcf62b838e56870d6... You're receiving this email because of your account on gitlab.haskell.org.