Magnus pushed to branch wip/mangoiv/9.12.5-rc4 at Glasgow Haskell Compiler / GHC Commits: 1b66cc1e by Zubin Duggal at 2026-09-04T14:07:07+02:00 An abstract TyCon may hide a unary class A class declared in an hs-boot file is an AbstractTyCon inside the module loop, and compiling the real declaration may reveal it to be a UnaryClassTyCon. - isTerminatingType returned True for such AbstractTyCons - IfaceToCore set the unary flag to False in the DFunId So we could end up speculating bottom dictionaries because inside a module loop we see an UnaryClassTyCon as an AbstractTyCon Use isTerminatingTyCon, which returns False for an abstract TyCon. The Bool in DFunId is now a cache for isTerminatingTyCon, set in mkDFunIdDetails. Fixes #27704 Note by the backporter (mangoiv): we're backporting by the fact that a tycon is a unary type class con IFF it is a type class con and a newtype prior to 9bd7fcc518111a1549c98720c222cdbabd32ed46. (cherry picked from commit db1e0bda5c3209d75133fa9e2560d684f35f950b) - - - - - e7b125d6 by Zubin Duggal at 2026-09-04T15:53:18+02:00 Specialise: don't replace dead args with absent fillers 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. Dropping dead args in the specialiser is rarely worth it, to quote Simon, "The later worker/wrapper pass will pick up the dead arg later if it is really dead. Keeps the specialiser simpler." So instead of trying to check if the arg really is dead in the stable unfolding, just drop the logic for dropping dead args in the specialiser altogeher. Fixes #27703 (cherry picked from commit 2b3cdef64bbc535bd72e3dfb512b4cfd10a72ca2) - - - - - 30 changed files: - + changelog.d/27703 - + changelog.d/27704 - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - + testsuite/tests/core-to-stg/T27704/Callee.hs - + testsuite/tests/core-to-stg/T27704/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704/Main.hs - + testsuite/tests/core-to-stg/T27704/Mid.hs - + testsuite/tests/core-to-stg/T27704/T27704.stdout - + testsuite/tests/core-to-stg/T27704/all.T - + testsuite/tests/core-to-stg/T27704a/Callee.hs - + testsuite/tests/core-to-stg/T27704a/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704a/Main.hs - + testsuite/tests/core-to-stg/T27704a/Mid.hs - + testsuite/tests/core-to-stg/T27704a/T27704a.stdout - + testsuite/tests/core-to-stg/T27704a/all.T - testsuite/tests/simplCore/should_compile/T17966.stderr - testsuite/tests/simplCore/should_compile/T7785.stderr - testsuite/tests/simplCore/should_compile/spec004.hs - testsuite/tests/simplCore/should_compile/spec004.stderr - + 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: ===================================== changelog.d/27703 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where the specialiser could drop an argument that the + function's stable unfolding still used, resulting in a runtime crash. +mrs: !16519 +issues: #27703 ===================================== changelog.d/27704 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Fix a bug where a class declared abstractly in an hs-boot file was + assumed not to be unary, so GHC speculatively evaluated a dictionary that + could be bottom, crashing the program. +mrs: !16519 +issues: #27704 ===================================== compiler/GHC/Core.hs ===================================== @@ -574,6 +574,17 @@ Wrinkle (NBD1) say that /all/ unary-class constraints might diverge. Remember, almost all classes are non-unary, and thus definitely non-bottom. +Wrinkle (NBD2) + A class declared in an hs-boot file is an AbstractTyCon inside the module + loop: + module Callee where { class UC (a :: Type) } -- Callee.hs-boot + module Callee where { class UC a where { ucm :: a -> a } } -- Callee.hs + isUnaryClassTyCon returns False for it, but compiling the real declaration + may reveal a UnaryClassTyCon, whose dictionary is `ucm` and can be bottom. + + Speculating a superclass selection from such a dictionary crashes (#27704). + So we must treat an AbstractTyCon as possibly unary. + Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions are one of the more complicated elements of the Core ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -20,13 +20,12 @@ import GHC.Core.Multiplicity import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) -import GHC.Core.DataCon ( StrictnessMark (..) ) -import GHC.Core.Opt.Monad +import GHC.Core.DataCon (dataConTyCon) import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core -import GHC.Core.Opt.WorkWrap.Utils ( mkAbsentFiller ) +import GHC.Core.Make ( wrapFloats ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable @@ -70,6 +69,7 @@ import GHC.Core.Unfold import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.Opt.Monad {- ************************************************************************ @@ -1713,7 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; ( useful, rhs_env2, leftover_bndrs , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader this_mod env rhs_bndrs all_call_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args -- ; pprTrace "spec_call" (vcat -- [ text "fun: " <+> ppr fn @@ -1794,7 +1794,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs spec_fn_details = case idDetails fn of JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing - DFunId is_nt -> DFunId is_nt + DFunId terminating -> DFunId terminating _ -> VanillaId ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info @@ -2014,49 +2014,22 @@ In the rule, d1 and d2 are just wildcards, not used in the RHS. Note additionally that 'x' isn't captured by this rule --- we bind only enough etas in order to capture all of the *specialised* arguments. -Note [Drop dead args from specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising a function, it’s possible some of the arguments may -actually be dead. For example, consider: +Note [Do not drop dead args from specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, some of its arguments may be dead. For example f :: forall a. () -> Show a => a -> String f x y = show y ++ "!" -We might generate the following CallInfo for `f @Int`: - - [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] - -Normally we’d include both the x and y arguments in the -specialisation, since we’re not specialising on either of them. But -that’s silly, since x is actually unused! So we might as well drop it -in the specialisation: - - $sf :: Int -> String - $sf y = show y ++ "!" - - {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} - -This doesn’t save us much, since the arg would be removed later by -worker/wrapper, anyway, but it’s easy to do. - -Wrinkles - -* Note that we only drop dead arguments if: - 1. We don’t specialise on them. - 2. They come before an argument we do specialise on. - Doing the latter would require eta-expanding the RULE, which could - make it match less often, so it’s not worth it. Doing the former could - be more useful --- it would stop us from generating pointless - specialisations --- but it’s more involved to implement and unclear if - it actually provides much benefit in practice. - -* 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. +gives the CallInfo [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] +for `f @Int`, in which `x` is dead. We used to drop such an argument from the +specialisation and pass an absent filler in its place. - The right thing to do is to produce a LitRubbish; it should rapidly - disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. +We no longer do so, because the filler is applied to the function's stable +unfolding template rather than to its optimised RHS, and the two may differ: +the argument can be dead in the RHS and not in the template. The specialised +function's unfolding then contains the filler, and any call site that inlines +it evaluates the error thunk. See #27703 for an instance of how this goes wrong. Note [Specialisation modulo dictionary selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2121,8 +2094,7 @@ since we’ll generate a RULE like RULE "SPEC f @Int" forall x [Occ=Dead]. f @Int x $dShow = $sf -and Core Lint complains, even though x only appears on the LHS (due to -Note [Drop dead args from specialisations]). +and Core Lint complains, even though x only appears on the LHS. Why is that a Lint error? Because the arguments on the LHS of a rule are syntactically expressions, not patterns, so Lint treats the @@ -2564,8 +2536,7 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: Module -- The module being compiled, for mkAbsentFiller - -> SpecEnv + :: SpecEnv -> [InBndr] -- The binders from the original function 'f' -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened @@ -2591,7 +2562,7 @@ specHeader -- 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 env (bndr : bndrs) (SpecType ty : args) +specHeader env (bndr : bndrs) (SpecType ty : args) = do { -- Find qvars, the type variables to add to the binders for the rule -- Namely those free in `ty` that aren't in scope -- See (MP2) in Note [Specialising polymorphic dictionaries] @@ -2603,7 +2574,7 @@ specHeader mod env (bndr : bndrs) (SpecType ty : args) ty' = substTy env1 ty env2 = extendTvSubst env1 bndr ty' ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader mod env2 bndrs args + <- specHeader env2 bndrs args ; pure ( useful , env3 , leftover_bndrs @@ -2619,10 +2590,10 @@ specHeader mod env (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 env (bndr : bndrs) (UnspecType : args) +specHeader env (bndr : bndrs) (UnspecType : args) = do { let (env', bndr') = substBndr env bndr ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader mod env' bndrs args + <- specHeader env' bndrs args ; pure ( useful , env'' , leftover_bndrs @@ -2636,14 +2607,14 @@ specHeader mod env (bndr : bndrs) (UnspecType : 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 env (bndr : bndrs) (SpecDict d : args) +specHeader env (bndr : bndrs) (SpecDict d : args) | not (isDeadBinder bndr) , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) -- See Note [Weird special case for SpecDict] = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader mod env2 bndrs args + <- specHeader env2 bndrs args ; pure ( True -- Ha! A useful specialisation! , env3 , leftover_bndrs @@ -2668,27 +2639,14 @@ specHeader mod env (bndr : bndrs) (SpecDict d : 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 env (bndr : bndrs) (_ : args) +specHeader env (bndr : bndrs) (_ : args) -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead = do { -- see Note [Zap occ info in rule binders] let (env', bndr') = substBndr env (zapIdOccInfo bndr) ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader mod env' bndrs args - - ; let -- See Note [Drop dead args from specialisations] - -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let - (mb_spec_bndr, spec_arg) - | isDeadBinder bndr - , Just filler <- mkAbsentFiller mod bndr' NotMarkedStrict - -- NB: mkAbsentFiller returns Nothing for a terminating type (e.g. a - -- dictionary), so this guard fails and we fall through, keeping the - -- argument instead of dropping it. - -- See Note [Don't make fillers for terminating types] - -- in GHC.Core.Opt.WorkWrap.Utils - = (Nothing, filler) - | otherwise - = (Just bndr', varToCoreExpr bndr') + <- specHeader env' bndrs args + ; let (mb_spec_bndr, spec_arg) = (Just bndr', varToCoreExpr bndr') ; pure ( useful , env'' , leftover_bndrs @@ -2704,12 +2662,12 @@ specHeader mod env (bndr : bndrs) (_ : args) -- If we run out of binders, stop immediately -- See Note [Specialisation Must Preserve Sharing] -specHeader _ env [] _ = pure (False, env, [], [], [], [], [], []) +specHeader env [] _ = pure (False, env, [], [], [], [], [], []) -- Return all remaining binders from the original function. These have the -- invariant that they should all correspond to unspecialised arguments, so -- it's safe to stop processing at this point. -specHeader _ env bndrs [] +specHeader env bndrs [] = pure (False, env', bndrs', [], [], [], [], []) where (env', bndrs') = substBndrs env bndrs ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -46,8 +46,9 @@ module GHC.Core.TyCon( noTcTyConScopedTyVars, -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, + isUnaryClassTyCon, isUnaryClassTyCon_maybe, isTerminatingTyCon, + isFamInstTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, @@ -2721,6 +2722,27 @@ famTyConFlav_maybe (TyCon { tyConDetails = details }) | FamilyTyCon {famTcFlav = flav} <- details = Just flav | otherwise = Nothing +isUnaryClassTyCon :: TyCon -> Bool +isUnaryClassTyCon tc = isClassTyCon tc && isNewTyCon tc + +isTerminatingTyCon :: TyCon -> Bool +-- ^ True <=> a value of type (T t1..tn), where `T` is this TyCon, cannot be bottom. +-- The only TyCons that satisfy `isTerminatingTyCon` are non-unary class TyCons. +-- See (UCM3) in Note [Unary class magic], and +-- Note [NON-BOTTOM-DICTS invariant] in GHC.Core. +-- An AbstractTyCon returns False: it comes from an hs-boot file, and the real +-- declaration may turn out to be a unary class. See (NBD2) in that Note. +isTerminatingTyCon tc = isClassTyCon tc && not (isUnaryClassTyCon tc) + && not (isAbstractTyCon tc) + +isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon) +isUnaryClassTyCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = ClassTyCon cls _ + , algTcRhs = NewTyCon {data_con = dc} } <- details + = Just (cls, dc) + | otherwise + = Nothing + -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool isClassTyCon (TyCon { tyConDetails = details }) ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -2479,7 +2479,7 @@ isTerminatingType :: HasDebugCallStack => Type -> Bool -- NB: unlifted types are not terminating types! -- e.g. you can write a term (loop 1)::Int# that diverges. isTerminatingType ty = case tyConAppTyCon_maybe ty of - Just tc -> isClassTyCon tc && not (isNewTyCon tc) + Just tc -> isTerminatingTyCon tc _ -> False isPrimitiveType :: Type -> Bool ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -1934,7 +1934,7 @@ app_ok fun_ok primop_ok fun args | otherwise = case idDetails fun of - DFunId new_type -> not new_type + DFunId terminating -> terminating -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1749,8 +1749,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ _ IfVanillaId = return VanillaId tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds -tcIdDetails _ ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails _ ty IfDFunId = return (mkDFunIdDetails cls) where (_, _, cls, _) = tcSplitDFunTy ty ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -20,6 +20,7 @@ Haskell. [WDP 94/11]) module GHC.Types.Id.Info ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + mkDFunIdDetails, JoinArity, isJoinIdDetails_maybe, RecSelParent(..), recSelParentName, recSelFirstConName, recSelParentCons, idDetailsConcreteTvs, @@ -201,9 +202,8 @@ data IdDetails | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) | DFunId Bool -- ^ A dictionary function. - -- Bool = True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary + -- Bool = True <=> a dictionary of this class cannot be bottom + -- See Note [NON-BOTTOM-DICTS invariant] in GHC.Core | CoVarId -- ^ A coercion variable -- This only covers /un-lifted/ coercions, of type @@ -372,6 +372,9 @@ isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinArity, (Maybe [CbvMark])) isJoinIdDetails_maybe (JoinId join_arity marks) = Just (join_arity, marks) isJoinIdDetails_maybe _ = Nothing +mkDFunIdDetails :: Class -> IdDetails +mkDFunIdDetails cls = DFunId (isTerminatingTyCon (classTyCon cls)) + instance Outputable IdDetails where ppr = pprIdDetails @@ -388,7 +391,8 @@ pprIdDetails other = brackets (pp other) pp (PrimOpId {}) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" - pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (DFunId terminating) = text "DFunId" + <> ppWhen (not terminating) (text "(may-be-bottom)") pp (RecSelId { sel_naughty = is_naughty }) = brackets $ text "RecSel" <> ppWhen is_naughty (text "(naughty)") ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1849,11 +1849,10 @@ mkDictFunId :: Name -- Name to use for the dict fun; -- See Note [Dict funs and default methods] mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) + = mkExportedLocalId (mkDFunIdDetails clas) dfun_name dfun_ty where - is_nt = isNewTyCon (classTyCon clas) dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) {- ===================================== testsuite/tests/core-to-stg/T27704/Callee.hs ===================================== @@ -0,0 +1,14 @@ +module Callee where + +import Mid + +-- The real UC is a *unary* class: one method, no superclasses. So a (UC a) +-- dictionary *is* the function ucm, and it can be bottom. +class UC a where + ucm :: a -> a + +instance UC Int where + ucm = undefined + +instance MC Int where + mcm _ = 7 ===================================== testsuite/tests/core-to-stg/T27704/Callee.hs-boot ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE KindSignatures #-} +module Callee where + +import Data.Kind (Type) + +-- Abstract class declaration: no context, no methods, no associated types, +-- so GHC.Tc.TyCl builds an AbstractTyCon rather than a UnaryClassTyCon. +class UC (a :: Type) ===================================== testsuite/tests/core-to-stg/T27704/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main where +import Mid +import Callee () + +main :: IO () +main = print (f (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27704/Mid.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-} +module Mid where + +import {-# SOURCE #-} Callee + +class UC a => MC a where + mcm :: a -> Int + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE keep #-} +keep :: [Dict c] -> Int +keep xs = length xs + 41 + +{-# NOINLINE f #-} +f :: forall a. MC a => a -> Int +f _ = keep [Dict :: Dict (UC a)] ===================================== testsuite/tests/core-to-stg/T27704/T27704.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/core-to-stg/T27704/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27704', + [extra_files(['Main.hs', 'Mid.hs', 'Callee.hs', 'Callee.hs-boot'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T27704a/Callee.hs ===================================== @@ -0,0 +1,13 @@ +module Callee where + +import Mid () + +-- Really unary: the dictionary /is/ ucm, so it can be bottom. +class UC a where + ucm :: a -> a + +instance UC Int where + ucm = id + +instance UC a => UC [a] where + ucm = error "ucm[] forced" ===================================== testsuite/tests/core-to-stg/T27704a/Callee.hs-boot ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE KindSignatures #-} +module Callee where + +import Data.Kind (Type) + +-- No context, no methods, no associated types, so buildAbstractClass makes an +-- AbstractTyCon rather than a UnaryClassTyCon: Mid cannot see that UC is unary. +class UC (a :: Type) + +instance UC a => UC [a] ===================================== testsuite/tests/core-to-stg/T27704a/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main where +import Mid +import Callee () + +main :: IO () +main = print (f (1 :: Int)) ===================================== testsuite/tests/core-to-stg/T27704a/Mid.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables #-} +module Mid where + +import {-# SOURCE #-} Callee + +data Dict c where + Dict :: c => Dict c + +{-# NOINLINE keep #-} +keep :: [Dict c] -> Int +keep xs = length xs + 41 + +-- Builds a (UC [a]) dictionary but never forces it. The dfun comes from the +-- hs-boot file, where UC looks non-unary, so its DFunId must not claim to +-- terminate: with -fspec-eval-dictfun, CorePrep would speculate it. +{-# NOINLINE f #-} +f :: forall a. UC a => a -> Int +f _ = keep [Dict :: Dict (UC [a])] ===================================== testsuite/tests/core-to-stg/T27704a/T27704a.stdout ===================================== @@ -0,0 +1 @@ +42 ===================================== testsuite/tests/core-to-stg/T27704a/all.T ===================================== @@ -0,0 +1,4 @@ +test('T27704a', + [extra_files(['Main.hs', 'Mid.hs', 'Callee.hs', 'Callee.hs-boot'])], + multimod_compile_and_run, + ['Main', '-O -fspec-eval-dictfun']) ===================================== testsuite/tests/simplCore/should_compile/T17966.stderr ===================================== @@ -113,19 +113,15 @@ $cm_aHo (show @c_aHr $dShow_aHs c_aBh)) end Rec } --- RHS size: {terms: 1, types: 0, coercions: 10, joins: 0/0} -T17966.$fCBoolb [InlPrag=INLINE (sat-args=0)] - :: forall b. Show b => C Bool b -[LclIdX[DFunId(nt)], - Arity=5, - Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) - Tmpl= $cm_aHo - `cast` (forall (b :: <*>_N). - <Show b>_R %<'Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N) - :: (forall {b} c. (Show b, Show c) => Bool -> b -> c -> String) - ~R# (forall {b}. Show b => C Bool b))}] +-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0} +T17966.$fCBoolb [InlPrag=CONLIKE] :: forall b. Show b => C Bool b +[LclIdX[DFunId(may-be-bottom)], + Arity=1, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (@b_anX) (v_B1 [Occ=Once1] :: Show b_anX) -> + T17966.C:C @Bool @b_anX ($cm_aJp @b_anX v_B1)}] T17966.$fCBoolb = $cm_aHo `cast` (forall (b :: <*>_N). ===================================== testsuite/tests/simplCore/should_compile/T7785.stderr ===================================== @@ -37,7 +37,7 @@ $cmyfmap_aG7 -- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} Foo.$fMyFunctor[] [InlPrag=INLINE (sat-args=0)] :: MyFunctor [] -[LclIdX[DFunId(nt)], +[LclIdX[DFunId(may-be-bottom)], Arity=4, Str=<A><A><U><SU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, ===================================== testsuite/tests/simplCore/should_compile/spec004.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} --- Dead arguments should be dropped in specialisations. See !2913. +-- Dead arguments are kept in specialisations. +-- See Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise module ShouldCompile where ===================================== testsuite/tests/simplCore/should_compile/spec004.stderr ===================================== @@ -1,22 +1,22 @@ ==================== Specialise ==================== Result size of Specialise - = {terms: 52, types: 41, coercions: 0, joins: 0/0} + = {terms: 39, types: 38, coercions: 0, joins: 0/0} --- RHS size: {terms: 13, types: 10, coercions: 0, joins: 0/0} -$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char] -[LclId, Arity=1] +-- RHS size: {terms: 14, types: 11, coercions: 0, joins: 0/0} +$sfoo [InlPrag=NOINLINE[0]] :: () -> Int -> [Char] +[LclId, Arity=2] $sfoo - = \ (y :: Int) -> - GHC.Base.build + = \ (ds :: ()) (y :: Int) -> + GHC.Internal.Base.build @Char (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) -> GHC.Base.foldr @Char @b c - (GHC.CString.unpackFoldrCString# @b "!"# c n) - (GHC.Show.$fShowInt_$cshow y)) + (GHC.Internal.Types.unpackFoldrCString# @b "!"# c n) + (GHC.Internal.Show.$fShowInt_$cshow y)) -- RHS size: {terms: 17, types: 15, coercions: 0, joins: 0/0} foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String @@ -25,7 +25,9 @@ foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40}, RULES: "SPEC foo @Int" [0] - forall (ds :: ()) ($dShow :: Show Int). foo @Int ds $dShow = $sfoo] + forall (ds [Occ=Once1] :: ()) ($dShow [Occ=Dead] :: Show Int). + foo @Int ds $dShow + = $sfoo ds] foo = \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) -> GHC.Base.build @@ -35,44 +37,9 @@ foo @Char @b c - (GHC.CString.unpackFoldrCString# @b "!"# c n) + (GHC.Internal.Types.unpackFoldrCString# @b "!"# c n) (show @a $dShow y)) --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$trModule :: GHC.Prim.Addr# -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] -$trModule = "main"# - --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$trModule :: GHC.Types.TrName -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$trModule = GHC.Types.TrNameS $trModule - --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$trModule :: GHC.Prim.Addr# -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}] -$trModule = "ShouldCompile"# - --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$trModule :: GHC.Types.TrName -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$trModule = GHC.Types.TrNameS $trModule - --- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -ShouldCompile.$trModule :: GHC.Types.Module -[LclIdX, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule - -- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0} bar :: String [LclIdX, ===================================== 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/feec438d628b953c892fdbcc35bc2c5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/feec438d628b953c892fdbcc35bc2c5... 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