Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC Commits: 3520030f by Andreas Klebinger at 2026-09-13T11:06:33+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 ------------------------- Metric Increase: T21839c T21839r ------------------------- - - - - - 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 ===================================== @@ -0,0 +1,5 @@ +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 ===================================== @@ -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 ===================================== testsuite/tests/simplCore/should_compile/T27802.hs ===================================== @@ -0,0 +1,69 @@ +-- 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 ===================================== @@ -0,0 +1,2 @@ +Inlining done: T27802.applyUnaryFew +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']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3520030fa377abd59eaca4a61d16f38e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3520030fa377abd59eaca4a61d16f38e... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help