Zubin pushed to branch wip/27627 at Glasgow Haskell Compiler / GHC Commits: 5d1e5e02 by Zubin Duggal at 2026-08-20T20:14:48+05:30 Specialise: don't drop a dead arg that the stable unfolding uses specHeader decides an argument is dead by calling isDeadBinder on a binder of the /optimised RHS/, then applies the filler to the /stable unfolding/ template instead. The two may differ, so the argument can be dead in the RHS and not in the template. The specialised function's unfolding then has an absent filler, and any call site that inlines it evaluates the error thunk. Thread the template's binders through specHeader alongside the RHS binders and make a filler only when the argument is dead in both. See Note [Dead args and stable unfoldings]. Fixes #27703 - - - - - efd3a5cf by Zubin Duggal at 2026-08-20T20:14:48+05:30 Never make an absent filler at a constraint type, isDictTy doesn't catch constraints hidden behind unreduced type family applications Example: type family F a :: Constraint type instance F W = TC W a :: F W => Int -> Int -- (F W) argument is absent Oops! Entered absent arg Arg: irred Type: F W also in the test T27627f Use `ConstraintLike <- typeTypeOrConstraint arg_ty` instead??? - - - - - a307ee3b by Zubin Duggal at 2026-08-20T20:14:48+05:30 CorePrep: don't speculate a call across an hs-boot edge We take care not to evaluate things that might be bottom, like a looping dictionary group, but our analysis is defeated by boot files. We only track recursion within a module, so two dictionaries that depend on each other across a module loop each look non-recursive, and we might speculate them. Any recursion we cannot see must cross an hs-boot edge, so refuse to speculate calls that cross one. Fixes #27717 - - - - - 20 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - + testsuite/tests/core-to-stg/T27627f/Callee.hs - + testsuite/tests/core-to-stg/T27627f/Caller.hs - + testsuite/tests/core-to-stg/T27627f/Inst.hs - + testsuite/tests/core-to-stg/T27627f/Main.hs - + testsuite/tests/core-to-stg/T27627f/T27627f.stdout - + testsuite/tests/core-to-stg/T27627f/all.T - + testsuite/tests/core-to-stg/T27717/Callee.hs - + testsuite/tests/core-to-stg/T27717/Callee.hs-boot - + testsuite/tests/core-to-stg/T27717/Main.hs - + testsuite/tests/core-to-stg/T27717/Mid.hs - + testsuite/tests/core-to-stg/T27717/T27717.stdout - + testsuite/tests/core-to-stg/T27717/Ty.hs - + testsuite/tests/core-to-stg/T27717/all.T - + testsuite/tests/simplCore/should_run/T27703/Lib.hs - + testsuite/tests/simplCore/should_run/T27703/Main.hs - + testsuite/tests/simplCore/should_run/T27703/T27703.stdout - + testsuite/tests/simplCore/should_run/T27703/all.T Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1647,6 +1647,14 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] + -- Binders of the stable unfolding template, if there is one. + -- See Note [Dead args and stable unfoldings] + unf_bndrs | isStableUnfolding fn_unf + , Just tmpl <- maybeUnfoldingTemplate fn_unf + = Just (fst (collectBinders tmpl)) + | otherwise + = Nothing + -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn spec_inl_prag @@ -1670,7 +1678,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs | otherwise = UnspecArg ; (useful, subst', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) - <- specHeader this_mod subst rhs_bndrs all_call_args + <- specHeader this_mod subst rhs_bndrs unf_bndrs all_call_args ; let env' = env { se_subst = subst' } -- Check for (a) usefulness and (b) not already covered @@ -2049,10 +2057,26 @@ Wrinkles * If the function has a stable unfolding, specHeader has to come up with arguments to pass to that stable unfolding, when building the stable unfolding of the specialised function: this is the last field in specHeader's - big result tuple. + big result tuple. We pass an absent filler, but only once we have checked + that the unfolding does not use the argument either. + See Note [Dead args and stable unfoldings] + +Note [Dead args and stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +specHeader decides an argument is dead with isDeadBinder on a binder of the +optimised RHS, then applies the filler to the stable unfolding template instead. +The two may differ, so the argument can be dead in the RHS and not in the +template. See #27703 for an instance of this. The specialised function's +unfolding then contains the filler, and any call site that inlines it evaluates +the error thunk. - The right thing to do is to produce a LitRubbish; it should rapidly - disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. +It is not enough to ask whether the RHS binder occurs free in the template: the +template has its own binders, so it never does. We must walk the arguments in +lockstep. If the template runs out of binders, the RHS was eta-expanded past +it, and we assume the argument is used. + +DmdAnal does the same job in addUnfoldingDemands. See Wrinkle (W3) of +Note [Absence analysis for stable unfoldings and RULES]. Note [Specialisation modulo dictionary selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2577,6 +2601,9 @@ specHeader :: Module -- The module being compiled, for mkAbsentFiller -> Core.Subst -- This substitution applies to the [InBndr] -> [InBndr] -- Binders from the original function `f` + -> Maybe [InBndr] + -- Binders of f's stable unfolding template, if it has one + -- See Note [Dead args and stable unfoldings] -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened -- Not the same as any (isSpecDict args) because @@ -2600,13 +2627,13 @@ specHeader -- If we run out of binders, stop immediately -- See Note [Specialisation Must Preserve Sharing] -specHeader _ subst [] _ = pure (False, subst, [], [], [], [], []) -specHeader _ subst _ [] = pure (False, subst, [], [], [], [], []) +specHeader _ subst [] _ _ = pure (False, subst, [], [], [], [], []) +specHeader _ subst _ _ [] = pure (False, subst, [], [], [], [], []) -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader mod subst (bndr:bndrs) (SpecType ty : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (SpecType ty : args) = do { -- Find free_tvs, the type variables to add to the binders for the rule -- Namely those deeply free in `ty` that aren't in scope -- See (MP2) in Note [Specialising polymorphic dictionaries] @@ -2619,7 +2646,7 @@ specHeader mod subst (bndr:bndrs) (SpecType ty : args) ; let subst2 = Core.extendTvSubst subst1 bndr ty ; (useful, subst3, rule_bs, rule_args, spec_bs, dx, spec_args) - <- specHeader mod subst2 bndrs args + <- specHeader mod subst2 bndrs (fmap (drop 1) unf_bndrs) args ; pure ( useful, subst3 , free_tvs ++ rule_bs, Type ty : rule_args , free_tvs ++ spec_bs, dx, Type ty : spec_args ) } @@ -2628,17 +2655,19 @@ specHeader mod subst (bndr:bndrs) (SpecType ty : args) -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader mod subst (bndr:bndrs) (UnspecType : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (UnspecType : args) = do { let (subst1, bndr') = Core.substBndr subst bndr ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) - <- specHeader mod subst1 bndrs args + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; let ty_e' = Type (mkTyVarTy bndr') ; pure ( useful, subst2 , bndr' : rule_bs, ty_e' : rule_es , bndr' : spec_bs, dx, ty_e' : spec_args ) } -specHeader mod subst (bndr:bndrs) (_ : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (_ : args) | isDeadBinder bndr + , dead_in_unfolding unf_bndrs + -- See Note [Dead args and stable unfoldings] , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) , Just filler <- mkAbsentFiller mod bndr' NotMarkedStrict -- NB: mkAbsentFiller returns Nothing for a terminating type (e.g. a @@ -2647,7 +2676,8 @@ specHeader mod subst (bndr:bndrs) (_ : args) -- See Note [Don't make fillers for dictionary types] -- in GHC.Core.Opt.WorkWrap.Utils = -- See Note [Drop dead args from specialisations] - do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args + do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; pure ( useful, subst2 , bndr' : rule_bs, Var bndr' : rule_es , spec_bs, dx, filler : spec_args ) } @@ -2655,7 +2685,7 @@ specHeader mod subst (bndr:bndrs) (_ : args) -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (SpecDict dict_arg : args) = do { -- Make up a fresh binder to use in the RULE -- It might turn into a dict binding (via bindAuxiliaryDict) which we -- then float, so we use cloneIdBndr to get a completely fresh binder @@ -2666,7 +2696,8 @@ specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg - ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst2 bndrs args + ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst2 bndrs (fmap (drop 1) unf_bndrs) args ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } ; pure ( True, subst3 -- Ha! A useful specialisation! @@ -2681,10 +2712,11 @@ specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader mod subst (bndr:bndrs) (UnspecArg : args) +specHeader mod subst (bndr:bndrs) unf_bndrs (UnspecArg : args) = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) -- zapIdOccInfo: see Note [Zap occ info in rule binders] - ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader mod subst1 bndrs (fmap (drop 1) unf_bndrs) args ; let dummy_arg = varToCoreExpr bndr' -- dummy_arg is usually just (Var bndr), @@ -2698,6 +2730,14 @@ specHeader mod subst (bndr:bndrs) (UnspecArg : args) , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } +dead_in_unfolding :: Maybe [InBndr] -> Bool +-- ^ Is the argument at this position dead in the stable unfolding template? +-- Nothing means there is no stable unfolding, so no filler can escape into one. +-- If the template runs out of binders we cannot tell, so we say No. +dead_in_unfolding Nothing = True +dead_in_unfolding (Just (unf_bndr : _)) = isDeadBinder unf_bndr +dead_in_unfolding (Just []) = False + -- | Binds a dictionary argument to a fresh name, to preserve sharing bindAuxiliaryDict :: Subst ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -32,7 +32,7 @@ import GHC.Core.Multiplicity import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.FamInstEnv -import GHC.Core.Predicate( isEqualityClass, isDictTy ) +import GHC.Core.Predicate( isEqualityClass ) import GHC.Core.TyCon import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk @@ -1072,7 +1072,7 @@ mkAbsentFiller mod arg str -- evaluated or have a field projected out of it. -- See (AF4) in Note [Absent fillers], and -- Note [Don't make fillers for dictionary types]. - | isDictTy arg_ty + | ConstraintLike <- typeTypeOrConstraint arg_ty = Nothing -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1977,6 +1977,26 @@ prep up `rhs1`, we have to include not only `f1`, but all binders of the group `f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive DFuns. +cpe_rec_ids is module-local, so it does not catch a recursion that goes through +an hs-boot import. Suppose Mid and Callee form a module loop, and Mid sees +Callee through its hs-boot file: + + -- Mid.hs + $fCAT = \ @a $dCB -> C:CA ($fxCBT $dCB) ... + -- Callee.hs + $fCBT = \ @a $dCB -> C:CB ($fCAT $dCB) ... + +Neither module can see that these two call each other, so each looks +non-recursive, and we speculate the inner call in both: + + $fCAT = \ @a $dCB -> case $fxCBT $dCB of s { __DEFAULT -> C:CA s ... } + $fCBT = \ @a $dCB -> case $fCAT $dCB of s { __DEFAULT -> C:CB s ... } + +Now each forces the other and the program loops. Such a cycle must cross an +hs-boot edge, so we do not speculate a call whose callee has a BootUnfolding. +Note [Inlining and hs-boot files] in GHC.CoreToIface does the same for +infinite inlining. + NB: If at some point we decide to have a termination analysis for general functions (#8655, !1866), we need to take similar precautions for (guarded) recursive functions: @@ -2323,10 +2343,13 @@ mkNonRecFloat env lev bndr rhs -- See Note [Controlling Speculative Evaluation] call_ok_for_spec x | is_rec_call x = False + | is_boot_call x = False | not (cp_specEval cfg) = False | not (cp_specEvalDFun cfg) && isDFunId x = False | otherwise = True - is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + is_boot_call = isBootUnfolding . realIdUnfolding + -- See Note [Speculative evaluation], Very Nasty Wrinkle -- See Note [Pin evaluatedness on floats] bndr' | is_hnf = bndr `setIdUnfolding` evaldUnfolding ===================================== testsuite/tests/core-to-stg/T27627f/Callee.hs ===================================== @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-worker-wrapper #-} +module Callee where + +-- Not unary: a superclass field and a method field, so (Eq a) can be +-- speculatively selected out of a (TC a) dictionary. +class Eq a => TC a where + tcDummy :: a -> Int + +data W = W +instance Eq W where _ == _ = True + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE discard #-} +discard :: Dict c -> Int +discard _ = 42 + +-- Never forces its dictionary, so demand analysis marks it absent, and +-- Caller's `a` inherits that absence. +{-# NOINLINE b #-} +b :: forall a. TC a => a -> Int +b _ = discard (Dict :: Dict (Eq a)) ===================================== testsuite/tests/core-to-stg/T27627f/Caller.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Caller where + +import Callee +import Data.Kind (Constraint) + +-- A Constraint-kinded type family. It reduces to (TC W), so the dictionary +-- `a` receives really is a (TC W) dictionary; but (F W) is not class-headed, +-- so isDictTy says False. Worker/wrapper must still not replace it with a +-- filler: Callee speculates a superclass selection out of it. +type family F a :: Constraint +type instance F W = TC W + +-- Note there is no `instance TC W` in scope here: `b W` must take its +-- dictionary from this Given, rather than from an instance. +{-# NOINLINE a #-} +a :: F W => Int -> Int +a x = b W + x ===================================== testsuite/tests/core-to-stg/T27627f/Inst.hs ===================================== @@ -0,0 +1,6 @@ +module Inst where + +import Callee + +-- Deliberately not in Callee or Caller: see the comment in Caller.hs +instance TC W where tcDummy _ = 7 ===================================== testsuite/tests/core-to-stg/T27627f/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main where + +import Caller +import Inst () + +main :: IO () +main = print (a 1) ===================================== testsuite/tests/core-to-stg/T27627f/T27627f.stdout ===================================== @@ -0,0 +1 @@ +43 ===================================== testsuite/tests/core-to-stg/T27627f/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27627f', + [extra_files(['Main.hs', 'Inst.hs', 'Caller.hs', 'Callee.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27717/Callee.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} +module Callee where + +import Ty +import Mid + +instance CB a => CB (T a) where + opB _ = 2 + +instance CB Int where + opB _ = 8 ===================================== testsuite/tests/core-to-stg/T27717/Callee.hs-boot ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +module Callee where + +import Ty + +instance CB a => CB (T a) +instance CB Int ===================================== testsuite/tests/core-to-stg/T27717/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main where +import Mid +import Callee () + +main :: IO () +main = print (g (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27717/Mid.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +module Mid where + +import Ty +import {-# SOURCE #-} Callee + +-- $fCATa calls Callee's $fxCBT, and that calls this one back. The cycle runs +-- through the hs-boot import, so both dfuns are NonRec in their own module and +-- cpe_rec_ids cannot see it. Speculating either one loops. +instance CB a => CA (T a) where + opA _ = 1 + +instance CA Int where + opA _ = 9 + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE keep #-} +keep :: [Dict c] -> Int +keep xs = length xs + 41 + +{-# NOINLINE g #-} +g :: forall a. CB a => a -> Int +g _ = keep [Dict :: Dict (CA (T a))] ===================================== testsuite/tests/core-to-stg/T27717/T27717.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/core-to-stg/T27717/Ty.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE UndecidableSuperClasses #-} +module Ty where + +data T a = MkT a + +class CB a => CA a where + opA :: a -> Int + +class CA a => CB a where + opB :: a -> Int ===================================== testsuite/tests/core-to-stg/T27717/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27717', + [extra_files(['Main.hs', 'Mid.hs', 'Ty.hs', 'Callee.hs', 'Callee.hs-boot'])], + multimod_compile_and_run, + ['Main', '-O -fspec-eval-dictfun']) ===================================== testsuite/tests/simplCore/should_run/T27703/Lib.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE RankNTypes #-} +module Lib (g) where + +{-# NOINLINE consume #-} +consume :: Int -> Int +consume n = n `seq` 0 + +{-# RULES "consume/drop" [~1] forall n. consume n = 0 #-} + +-- A dead value argument (n) that comes *before* the dictionary we +-- specialise on. No implicit parameters involved. +{-# INLINE [1] f #-} +f :: forall a. Int -> Show a => a -> String +f n y = show y ++ replicate (consume n) '!' + +{-# NOINLINE g #-} +g :: Bool -> String +g b = f 7 b ++ "." ===================================== testsuite/tests/simplCore/should_run/T27703/Main.hs ===================================== @@ -0,0 +1,5 @@ +module Main where +import Lib + +main :: IO () +main = putStrLn (g True) ===================================== testsuite/tests/simplCore/should_run/T27703/T27703.stdout ===================================== @@ -0,0 +1 @@ +True. ===================================== testsuite/tests/simplCore/should_run/T27703/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27703', + [extra_files(['Main.hs', 'Lib.hs'])], + multimod_compile_and_run, + ['Main', '-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3618220bed95ae0b965f1be3b7e222... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3618220bed95ae0b965f1be3b7e222... 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