GitLab

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]
  ~~~~~~~~~~~~~~~~~~~~~~