GitLab

Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC

Commits:

9201a2cf

by Andreas Klebinger at 2026-09-13T10:53:23+02:00

Tweak inlining discout for unary class ops.

Count the cost of applying the extra arguments to the result of a
class op being applied to a unary class dictionary.

That is if we have `(op d) x y z` charge for x y z even if we don't
carge for the class op application.

Fixes #27802

5 changed files:

+ changelog.d/27802-classop-arg-size
compiler/GHC/Core/Unfold.hs
+ testsuite/tests/simplCore/should_compile/T27802.hs
+ testsuite/tests/simplCore/should_compile/T27802.stderr
testsuite/tests/simplCore/should_compile/all.T

Changes:

changelog.d/27802-classop-arg-size

 +section: compiler
 +synopsis: For code like `m x y z` where m is a class method of a unary type class
 +  we now account (again) for the size of applying the x/y/z arguments.
 +mrs: !16675
 +issues: #27802

compiler/GHC/Core/Unfold.hs

@@ -42,7 +42,7 @@ import GHC.Core.Utils
  import GHC.Core.DataCon
  import GHC.Core.Type
  import GHC.Core.Class( Class )
 -import GHC.Core.Predicate( isUnaryClass )
 +import GHC.Core.Predicate( isUnaryClass, isDictId )
  import GHC.Types.Id
  import GHC.Types.Literal
@@ -782,16 +782,26 @@ classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize
  classOpSize _opts _cls _top_args []
    = sizeZero   -- A non-applied classop
  classOpSize opts cls top_args (dict_arg:other_val_args)
 -  = SizeIs size (arg_discount dict_arg) 0
 +  = SizeIs size dict_arg_discount 0
    where
 -    size | isUnaryClass cls = 0    -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon
 -         | otherwise        = 20 + (10 * length other_val_args)
 +    -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon
 +    op_app_size = if isUnaryClass cls then 0 else 20
++
 +    -- Size penalty for applying the extracted class method to it's
 +    -- arguments.
 +    method_app_size
 +      | null other_val_args = 0
 +      | otherwise           = callSize (length other_val_args) 0
++
 +    size = op_app_size + method_app_size
      -- If the class op is scrutinising a lambda bound dictionary then
      -- give it a discount, to encourage the inlining of this function
 -    arg_discount (Cast arg _co)                    = arg_discount arg
 -    arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount)
 -    arg_discount _                                 = emptyBag
 +    dict_arg_discount = case getIdFromTrivialExpr_maybe dict_arg of
 +      Nothing -> emptyBag
 +      Just dict
 +        | dict `elem` top_args -> unitBag (dict, dict_discount)
 +        | otherwise -> emptyBag
      -- If we have (class-op d arg1 .. argn) then it's super-good to inline
      -- to expose `d`; not only can we do the dictionary selection
@@ -802,6 +812,12 @@ classOpSize opts cls top_args (dict_arg:other_val_args)
        | null other_val_args = unfoldingDictDiscount opts
        | otherwise           = unfoldingDictDiscount opts + unfoldingFunAppDiscount opts
 +    isTopArgDict expr
 +      | Just v <- getIdFromTrivialExpr_maybe expr
 +      = v `elem` top_args
 +      | otherwise
 +      = False
++
  -- | The size of a function call
  callSize
   :: Int  -- ^ number of value args

testsuite/tests/simplCore/should_compile/T27802.hs

 +-- See #27802.
 +-- The whole idea is that if we have `(op d) x1 x2 ... xn` even if the dictionary
 +-- is known we have to account for the size resulting from applying `x1 .. xn`.
++
 +-- For this we construct functions containing the pattern `(op d) x .. xn`.
 +-- with: `d` being either a unary or regular class dictionary, and n either being
 +-- small enough for the function containing the pattern to inline, or large enough
 +-- that we surely shouldn't inline the containing function.
++
 +-- We test this by grepping -ddump-inlinings
++
 +module T27802
 +  -- We export the functions to avoid unconditional ininlining to fire.
 +  ( applyUnaryFew, applyRegularFew, applyUnaryMany, applyRegularMany
 +  , useUnaryFew, useRegularFew, useUnaryMany, useRegularMany
 +  ) where
++
++
 +class Unary a where
 +  m_unary :: (a -> b) -> b
++
 +-- The super dict makes it a non-unary type class.
 +class Eq a => Regular a where
 +  m_regular :: (a -> b) -> b
++
 +instance Unary Int where
 +  m_unary f = f 42
++
 +instance Regular Int where
 +  m_regular f = f 43
++
 +-- We instantiate `b` with these function types.
 +type Args4 = Int -> Int -> Int -> Int -> Int
++
 +type Args50 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
 +              Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
 +              Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
 +              Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
 +              Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
 +              Int
++
 +-- apply* functions are the ones containing the `op d x1 .. xn` pattern.
 +applyUnaryFew :: Unary a => (a -> Args4) -> Int
 +applyUnaryFew g = m_unary g 1 2 3 4
++
 +applyRegularFew :: Regular a => (a -> Args4) -> Int
 +applyRegularFew g = m_regular g 1 2 3 4
++
 +applyUnaryMany :: Unary a => (a -> Args50) -> Int
 +applyUnaryMany g = m_unary g
 +      1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 +      1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 +      1 1 1 1 1 1 1 1 1 1
++
 +applyRegularMany :: Regular a => (a -> Args50) -> Int
 +applyRegularMany g = m_regular g
 +      1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 +      1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 +      1 1 1 1 1 1 1 1 1 1
++
 +-- The call sites, where the dictionary is known. And we check if we should inline the
 +-- apply* functions.
 +useUnaryFew, useRegularFew :: (Int -> Args4) -> Int
 +useUnaryFew   g = applyUnaryFew g
 +useRegularFew g = applyRegularFew g
++
 +useUnaryMany, useRegularMany :: (Int -> Args50) -> Int
 +useUnaryMany   g = applyUnaryMany g
 +useRegularMany g = applyRegularMany g

testsuite/tests/simplCore/should_compile/T27802.stderr

	1	+Inlining done: T27802.applyUnaryFew
	2	+Inlining done: T27802.applyRegularFew

testsuite/tests/simplCore/should_compile/all.T

@@ -618,3 +618,8 @@ test('T27556', [only_ways('ghci'), extra_hc_opts('-O -fno-unoptimized-core-for-i
  test('T27749',
       multiline_grep_errmsg(r'ordering\n.*\n(\s+src<[^>]*>\n)+'),
       compile, ['-O -g3 -ddump-simpl -dsuppress-uniques'])
++
 +# Check that we account for the size of arguments x1..xn when calculating size
 +# of expressions like `op d x1 ... xn`  See #27802.
 +test('T27802', [grep_errmsg(r'Inlining done: T27802\.apply')], compile,
 +     ['-O -fno-specialise -ddump-inlinings -dsuppress-uniques'])