[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] 2 commits: CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent
Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: 594e584e by Zubin Duggal at 2026-07-10T11:56:08+02:00 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 (cherry picked from commit 9b714c4c833461c621f0a050680848d7248aa57e) - - - - - a9436d43 by Zubin Duggal at 2026-07-10T13:04:53+02:00 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf (cherry picked from commit 4a59b3eece9b7106fcbe73d2d06a49755be4ea8f) - - - - - 14 changed files: - + changelog.d/fix-absent-dict-projection - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Types/Literal.hs - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - testsuite/tests/dmdanal/should_compile/T18982.stderr Changes: ===================================== changelog.d/fix-absent-dict-projection ===================================== @@ -0,0 +1,8 @@ +section: compiler +synopsis: Fix a miscompilation that could project a field out of an absent dictionary, resulting in a segfault. +issues: #25924 +mrs: !16219 +description: + We no longer make an absent filler (a rubbish literal or error thunk) for an + absent dictionary or other terminating type. We also no longer speculatively + evaluate a binding once we have discovered that it is absent. ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -219,13 +219,16 @@ mkLitRubbish :: Type -> Maybe CoreExpr -- Fail (returning Nothing) if -- * the RuntimeRep of the Type is not monomorphic; -- * the type is (a ~# b), the type of coercion --- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals] +-- * the type is terminating (isTerminatingType), e.g. a dictionary +-- See INVARIANT 1, 2 and 3 of item (2) in Note [Rubbish literals] -- in GHC.Types.Literal mkLitRubbish ty | not (noFreeVarsOfType rep) = Nothing -- Satisfy INVARIANT 1 | isCoVarType ty = Nothing -- Satisfy INVARIANT 2 + | isTerminatingType ty + = Nothing -- Satisfy INVARIANT 3 | otherwise = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) where ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -20,11 +20,14 @@ 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 qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core import GHC.Core.Make ( mkLitRubbish ) +import GHC.Core.Opt.WorkWrap.Utils ( mkAbsentFiller ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable @@ -1711,7 +1714,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 env rhs_bndrs all_call_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader this_mod env rhs_bndrs all_call_args -- ; pprTrace "spec_call" (vcat -- [ text "fun: " <+> ppr fn @@ -2562,7 +2565,8 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: SpecEnv + :: Module -- The module being compiled, for mkAbsentFiller + -> SpecEnv -> [InBndr] -- The binders from the original function 'f' -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened @@ -2588,7 +2592,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 env (bndr : bndrs) (SpecType ty : args) +specHeader mod 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] @@ -2600,7 +2604,7 @@ specHeader 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 env2 bndrs args + <- specHeader mod env2 bndrs args ; pure ( useful , env3 , leftover_bndrs @@ -2616,10 +2620,10 @@ specHeader 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 env (bndr : bndrs) (UnspecType : args) +specHeader mod 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 env' bndrs args + <- specHeader mod env' bndrs args ; pure ( useful , env'' , leftover_bndrs @@ -2630,18 +2634,33 @@ specHeader env (bndr : bndrs) (UnspecType : args) , varToCoreExpr bndr' : spec_args ) } +specHeader mod env (bndr:bndrs) (_ : args) + | isDeadBinder bndr + , let subst = se_subst env + , 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 + -- 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 + = -- See Note [Drop dead args from specialisations] + do { (useful, env, leftover_bndrs, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod env { se_subst = subst1 } bndrs args + ; pure ( useful, env, leftover_bndrs + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dx, filler : spec_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 env (bndr : bndrs) (SpecDict d : args) +specHeader mod 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 env2 bndrs args + <- specHeader mod env2 bndrs args ; pure ( True -- Ha! A useful specialisation! , env3 , leftover_bndrs @@ -2666,12 +2685,12 @@ specHeader 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 env (bndr : bndrs) (_ : args) +specHeader mod 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 env' bndrs args + <- specHeader mod env' bndrs args ; let bndr_ty = idType bndr' @@ -2699,12 +2718,12 @@ specHeader 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/Opt/WorkWrap.hs ===================================== @@ -550,7 +550,7 @@ tryWW ww_opts is_rec fn_id rhs -- See Note [Drop absent bindings] | isAbsDmd (demandInfo fn_info) , not (isJoinId fn_id) - , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict + , Just filler <- mkAbsentFiller (wo_module ww_opts) fn_id NotMarkedStrict = return [(new_fn_id, filler)] -- See Note [Don't w/w INLINE things] ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Core.Subst import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion -import GHC.Core.Predicate( isDictTy ) import GHC.Core.Reduction import GHC.Core.FamInstEnv import GHC.Core.TyCon @@ -936,7 +935,7 @@ mkWWstr_one opts arg str_mark = _ | isTyVar arg -> do_nothing DropAbsent - | Just absent_filler <- mkAbsentFiller opts arg str_mark + | Just absent_filler <- mkAbsentFiller (wo_module opts) arg str_mark -- Absent case. Drop the argument from the worker. -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can @@ -1007,14 +1006,20 @@ unbox_one_arg opts arg_var -- -- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the -- same type as @id@. Otherwise, no suitable filler could be found. -mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr -mkAbsentFiller opts arg str +mkAbsentFiller :: Module -> Id -> StrictnessMark -> Maybe CoreExpr +mkAbsentFiller mod arg str + -- We never make a filler for a terminating type: it might be speculatively + -- evaluated or have a field projected out of it. + -- See (AF4) in Note [Absent fillers], and + -- Note [Don't make fillers for terminating types]. + | isTerminatingType arg_ty + = Nothing + -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers] -- We want to use this case if possible, because we get a nice runtime panic message -- if we are wrong (like we were in #11126). Otherwise we fall through to the -- less-desirable mkLitRubbish case. | mightBeLiftedType arg_ty - , not (isDictTy arg_ty) -- See (AF4) in Note [Absent fillers] , not (isStrictDmd (idDemandInfo arg)) -- See (AF2) , not (isMarkedStrict str) -- in Note [Absent fillers] = Just (mkAbsentErrorApp arg_ty msg) @@ -1041,7 +1046,7 @@ mkAbsentFiller opts arg str -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - file_msg = text "In module" <+> quotes (ppr $ wo_module opts) + file_msg = text "In module" <+> quotes (ppr mod) {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1234,27 +1239,8 @@ Needless to say, there are some wrinkles: have to be representation monomorphic. But in the future, we might allow levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. -(AF4) Consider (#24934) - f :: (a~b) => blah {-# INLINE f #-} - f d x = case eq_sel d of co -> body - In #24934 it turned out that `co` was unused; and we discarded the - entire case-scrutinisation via the `exprOkToDiscard` test in - `GHC.Core.Opt.Simplify.Iteration.rebuildCase`. So now `d` is absent. - But in the /unfolding/ for some reason we did not discard the `case`; - so when we inline `f` we end up evaluating that `d` argument. So we had - better not replace it with an error thunk! - - The root of it is this: `exprOkToDiscard` assumes that a dictionary is - non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace - the (a~b) dictionary with an error thunk, breaking the invariant that every - dictionary is non-bottom. (If -XDictsStrict is on, the invariant is even - more important.) - - Simple solution: never use an error thunk for a dictionary; instead fall - through to mkRubbishLit. (The only downside is that we lose the compiler - debugging advantages of (AF1).) - - This is quite delicate. +(AF4) We never make an absent filler for a terminating type. + See Note [Don't make fillers for terminating types]. While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging experience, (AF3) should be irrelevant in most programs, if not all. @@ -1276,6 +1262,47 @@ fragile because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! +Note [Don't make fillers for terminating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never make an absent filler, error thunk or rubbish literal, for a terminating +type (isTerminatingType): a non-unary class dictionary, a boxed equality, or a +constraint tuple. + +GHC relies on a dictionary value never being bottom (see +Note [NON-BOTTOM-DICTS invariant] in GHC.Core). GHC uses "speculation" to +evaluated guaranteed-non-bottom values: see Note [Speculative evaluation] in +GHC.CoreToStg.Prep. This speculative evaluation is fundamentally incompatible +with replacing a dictionary with an absent filler. Attempts to to do so gave +rise to a succession of bugs including: + + * #24934: we evaluated an absent dictionary + * #25924: we selected a superclass from an absent dictionary + +A terminating type is exactly what speculation will force: see +Note [exprOkForSpeculation and type classes] in GHC.Core.Utils. So we refuse to +make a filler for precisely those types. + +So the safe thing is to make no filler at all for a terminating type. Then there +is no bogus dictionary to evaluate or project from. Specifically + + * `mkAbsentFiller` returns `Nothing` for a terminating type, so worker/wrapper + keeps the real argument. + + * `Specialise.specHeader` calls `mkAbsentFiller` too, so it likewise keeps the + dead dictionary argument rather than dropping it for a filler. + +Prior failed approaches + +We used to paper over this. !13233 replaced the error thunk for an absent +dictionary with a rubbish literal, so that it could at least be evaluated +without complaint. But #25924 showed that this is not enough, because we do not +only evaluate the absent dictionary, we also select a superclass from it. + +We could instead teach speculation to leave absent bindings alone, and we do +that too (see Note [Speculative evaluation] in GHC.CoreToStg.Prep). But that is +not a guarantee. After optimisation a binding that holds an absent filler may no +longer be marked absent, so we cannot rely on the demand to protect us. + Note [Unboxing through unboxed tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We should not to a worker/wrapper split just for unboxing the components of ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1960,6 +1960,20 @@ It is also similar to Note [Do not strictify a DFun's parameter dictionaries], where marking recursive DFuns (of undecidable *instances*) strict in dictionary *parameters* leads to quite the same change in termination as above. +Belt and braces: do not speculate absent bindings + +In 'decideFloatInfo' we decline to speculate a binding whose demand is absent. +There is no point in speculating an absent binding, since its value is +(presumably) not needed. + +This used to matter more. Worker/wrapper would bind an absent dictionary to a +rubbish literal filler, and speculation could force a superclass selection out +of that rubbish literal, causing a segfault (#25924). Nowadays we never make a +filler for a dictionary in the first place, so this can no longer happen and +the guard is merely belt and braces. +See Note [Don't make fillers for terminating types] +in GHC.Core.Opt.WorkWrap.Utils. + Note [BindInfo and FloatInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The `BindInfo` of a `Float` describes whether it will be case-bound or @@ -2204,12 +2218,16 @@ mkNonRecFloat env is_unlifted bndr rhs | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level - | is_unlifted, ok_for_spec = (CaseBound, LazyContextFloatable) - | is_lifted, ok_for_spec = (CaseBound, TopLvlFloatable) + | is_unlifted, ok_for_spec, not (isAbsDmd dmd) = (CaseBound, LazyContextFloatable) + | is_lifted, ok_for_spec, not (isAbsDmd dmd) = (CaseBound, TopLvlFloatable) -- See Note [Speculative evaluation] -- Ok-for-spec-eval things will be case-bound, lifted or not. -- But when it's lifted we are ok with floating it to top-level -- (where it is actually bound lazily). + -- + -- Don't speculate an absent binding. See #25924 and + -- "Belt and braces" in Note [Speculative evaluation]. + | is_unlifted || is_strict = (CaseBound, StrictContextFloatable) -- These will never be floated out of a lazy RHS context | otherwise = assertPpr is_lifted (ppr rhs) $ ===================================== compiler/GHC/Types/Literal.hs ===================================== @@ -988,6 +988,14 @@ data type. Here are the moving parts: This is sad, though: see #18983. + INVARIANT 3: we never make a rubbish literal of a terminating type + (isTerminatingType), such as a class dictionary. GHC relies on a value of + a terminating type never being bottom, and so may speculatively evaluate + a dictionary or select a superclass from it. Either would crash on a + rubbish literal (#24934, #25924). + See Note [Don't make fillers for terminating types] + in GHC.Core.Opt.WorkWrap.Utils. + 3. STG: The type app in `RUBBISH[IntRep] @Int# :: Int#` is erased and we get the (untyped) 'StgLit' `RUBBISH[IntRep] :: Int#` in STG. ===================================== testsuite/tests/core-to-stg/T25924/B.hs ===================================== @@ -0,0 +1,89 @@ +{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-} +module B where + +import Data.Kind + +class ABITypeable a where + abiTypeInfo :: String + abiTypeInfo = "" + + unused :: a -> a + unused x = x + +data REF a + +instance ABITypeable () where +instance ABITypeable a => ABITypeable (REF a) where + +class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint +instance YulCatObj () +instance YulCatObj a => YulCatObj (REF a) + +type YulO1 a = YulCatObj a +type YulO2 a b = (YulCatObj a, YulCatObj b) + + +type YulCat :: Type -> Type -> Type +data YulCat a b where + YulExtendType :: forall b. (YulO2 () b) => YulCat () b + YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b + YulJmpB :: forall a b. (YulO2 a b) => YulCat a b + +data Trie a b where + Z :: Trie a a + (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c + +type Cat a b = forall c. Trie b c -> Trie a c + +normalize :: forall a b unused ξ. (Int ~ unused, YulCatObj a, YulCatObj b) + => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ +normalize t0 k = case t0 of + Z -> k Z undefined + φ :. f -> normalize f $ \f' s -> case f' of + Z -> k Z (s `YulComp` φ) + _ -> undefined + + +toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b +toSMC t = normalize (t Z) $ \f g -> case f of + Z -> g + _ -> error "toSMC: normalisation process failed" + + +encode :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b) +encode φ (Y f) = Y (\x -> f (φ :. x)) + + +type P :: Type -> Type -> Type +data P r a = Y (Cat r a) + +fromP :: P r a -> Cat r a +fromP (Y f) = f + + +decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b +decode f = toSMC (extract f) + +extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b +extract f = fromP (f (Y id)) + + +yulShow :: YulCat a' b' -> String +yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b +yulShow (YulComp cb ac) = yulShow ac <> yulShow cb +yulShow YulJmpB = "Jb" + + +lfn' :: forall b unused. + ( YulO1 (REF b) + , () ~ unused + ) => + (forall r. YulO1 r => P r () -> P r (REF b)) -> String +lfn' f = yulShow (decode f) + + +extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a +extendType'l = encode YulExtendType + +keccak256'l :: forall a r. YulO2 r a => P r a -> P r () +keccak256'l = encode YulJmpB ===================================== testsuite/tests/core-to-stg/T25924/Main.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import B + +getCounterRef' :: forall b r. + ( YulO1 b + , YulO1 r + -- , YulO1 (REF b) + ) => + P r () -> P r (REF b) +getCounterRef' a = extendType'l (keccak256'l a) +{-# NOINLINE getCounterRef' #-} + +main :: IO () +main = putStrLn $ lfn' @() getCounterRef' ===================================== testsuite/tests/core-to-stg/T25924/all.T ===================================== @@ -0,0 +1,4 @@ +test('T25924', + [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T25924a.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-} +module Main where + +class D a where + m :: a -> Int + m _ = 0 + n :: a -> Int + n _ = 0 + +class (D a, D a) => C a + +data T a + +instance D a => D (T a) +instance C a => C (T a) + +instance D () +instance C () + +data G where + MkG :: forall a. C (T a) => T a -> G + +sh :: G -> Int +sh (MkG x) = m x + +f :: forall b. C b => G +f = MkG (undefined :: T b) +{-# NOINLINE f #-} + +main :: IO () +main = print (sh (f @())) ===================================== testsuite/tests/core-to-stg/T25924a.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -7,3 +7,4 @@ test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) test('T24334', normal, compile_and_run, ['-O']) test('T24463', normal, compile, ['-O']) +test('T25924a', [ignore_stderr], compile_and_run, ['-O']) ===================================== testsuite/tests/dmdanal/should_compile/T18982.stderr ===================================== @@ -1,38 +1,26 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 295, types: 206, coercions: 4, joins: 0/0} - --- RHS size: {terms: 8, types: 9, coercions: 1, joins: 0/0} -T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int -T18982.$WExGADT = \ (@e) (conrep :: e ~ Int) (conrep1 :: e) (conrep2 :: Int) -> T18982.ExGADT @Int @e @~(<Int>_N :: Int GHC.Prim.~# Int) conrep conrep1 conrep2 - --- RHS size: {terms: 3, types: 2, coercions: 1, joins: 0/0} -T18982.$WGADT :: Int %1 -> GADT Int -T18982.$WGADT = \ (conrep :: Int) -> T18982.GADT @Int @~(<Int>_N :: Int GHC.Prim.~# Int) conrep - --- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0} -T18982.$WEx :: forall e a. e %1 -> a %1 -> Ex a -T18982.$WEx = \ (@e) (@a) (conrep :: e) (conrep1 :: a) -> T18982.Ex @a @e conrep conrep1 +Result size of Tidy Core = {terms: 276, types: 179, coercions: 2, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$trModule4 :: GHC.Prim.Addr# -T18982.$trModule4 = "main"# +$trModule1 :: GHC.Internal.Prim.Addr# +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$trModule3 :: GHC.Types.TrName -T18982.$trModule3 = GHC.Types.TrNameS T18982.$trModule4 +$trModule2 :: GHC.Internal.Types.TrName +$trModule2 = GHC.Internal.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$trModule2 :: GHC.Prim.Addr# -T18982.$trModule2 = "T18982"# +$trModule3 :: GHC.Internal.Prim.Addr# +$trModule3 = "T18982"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$trModule1 :: GHC.Types.TrName -T18982.$trModule1 = GHC.Types.TrNameS T18982.$trModule2 +$trModule4 :: GHC.Internal.Types.TrName +$trModule4 = GHC.Internal.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$trModule :: GHC.Types.Module -T18982.$trModule = GHC.Types.Module T18982.$trModule3 T18982.$trModule1 +T18982.$trModule :: GHC.Internal.Types.Module +T18982.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep :: GHC.Types.KindRep @@ -47,16 +35,16 @@ $krep2 :: GHC.Types.KindRep $krep2 = GHC.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tcBox2 :: GHC.Prim.Addr# -T18982.$tcBox2 = "Box"# +$tcBox1 :: GHC.Internal.Prim.Addr# +$tcBox1 = "Box"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tcBox1 :: GHC.Types.TrName -T18982.$tcBox1 = GHC.Types.TrNameS T18982.$tcBox2 +$tcBox2 :: GHC.Internal.Types.TrName +$tcBox2 = GHC.Internal.Types.TrNameS $tcBox1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tcBox :: GHC.Types.TyCon -T18982.$tcBox = GHC.Types.TyCon 16948648223906549518#Word64 2491460178135962649#Word64 T18982.$trModule T18982.$tcBox1 0# GHC.Types.krep$*Arr* +T18982.$tcBox :: GHC.Internal.Types.TyCon +T18982.$tcBox = GHC.Internal.Types.TyCon 16948648223906549518#Word64 2491460178135962649#Word64 T18982.$trModule $tcBox2 0# GHC.Internal.Types.krep$*Arr* -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} $krep3 :: [GHC.Types.KindRep] @@ -67,140 +55,140 @@ $krep4 :: GHC.Types.KindRep $krep4 = GHC.Types.KindRepTyConApp T18982.$tcBox $krep3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Box1 :: GHC.Types.KindRep -T18982.$tc'Box1 = GHC.Types.KindRepFun $krep2 $krep4 +$krep5 :: GHC.Internal.Types.KindRep +$krep5 = GHC.Internal.Types.KindRepFun $krep2 $krep4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Box3 :: GHC.Prim.Addr# -T18982.$tc'Box3 = "'Box"# +$tc'Box1 :: GHC.Internal.Prim.Addr# +$tc'Box1 = "'Box"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Box2 :: GHC.Types.TrName -T18982.$tc'Box2 = GHC.Types.TrNameS T18982.$tc'Box3 +$tc'Box2 :: GHC.Internal.Types.TrName +$tc'Box2 = GHC.Internal.Types.TrNameS $tc'Box1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Box :: GHC.Types.TyCon -T18982.$tc'Box = GHC.Types.TyCon 1412068769125067428#Word64 8727214667407894081#Word64 T18982.$trModule T18982.$tc'Box2 1# T18982.$tc'Box1 +T18982.$tc'Box :: GHC.Internal.Types.TyCon +T18982.$tc'Box = GHC.Internal.Types.TyCon 1412068769125067428#Word64 8727214667407894081#Word64 T18982.$trModule $tc'Box2 1# $krep5 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tcEx2 :: GHC.Prim.Addr# -T18982.$tcEx2 = "Ex"# +$tcEx1 :: GHC.Internal.Prim.Addr# +$tcEx1 = "Ex"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tcEx1 :: GHC.Types.TrName -T18982.$tcEx1 = GHC.Types.TrNameS T18982.$tcEx2 +$tcEx2 :: GHC.Internal.Types.TrName +$tcEx2 = GHC.Internal.Types.TrNameS $tcEx1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tcEx :: GHC.Types.TyCon -T18982.$tcEx = GHC.Types.TyCon 4376661818164435927#Word64 18005417598910668817#Word64 T18982.$trModule T18982.$tcEx1 0# GHC.Types.krep$*Arr* +T18982.$tcEx :: GHC.Internal.Types.TyCon +T18982.$tcEx = GHC.Internal.Types.TyCon 4376661818164435927#Word64 18005417598910668817#Word64 T18982.$trModule $tcEx2 0# GHC.Internal.Types.krep$*Arr* -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep5 :: [GHC.Types.KindRep] -$krep5 = GHC.Types.: @GHC.Types.KindRep $krep1 (GHC.Types.[] @GHC.Types.KindRep) +$krep6 :: [GHC.Internal.Types.KindRep] +$krep6 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep1 (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep6 :: GHC.Types.KindRep -$krep6 = GHC.Types.KindRepTyConApp T18982.$tcEx $krep5 +$krep7 :: GHC.Internal.Types.KindRep +$krep7 = GHC.Internal.Types.KindRepTyConApp T18982.$tcEx $krep6 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep7 :: GHC.Types.KindRep -$krep7 = GHC.Types.KindRepFun $krep1 $krep6 +$krep8 :: GHC.Internal.Types.KindRep +$krep8 = GHC.Internal.Types.KindRepFun $krep1 $krep7 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Ex1 :: GHC.Types.KindRep -T18982.$tc'Ex1 = GHC.Types.KindRepFun $krep2 $krep7 +$krep9 :: GHC.Internal.Types.KindRep +$krep9 = GHC.Internal.Types.KindRepFun $krep2 $krep8 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Ex3 :: GHC.Prim.Addr# -T18982.$tc'Ex3 = "'Ex"# +$tc'Ex1 :: GHC.Internal.Prim.Addr# +$tc'Ex1 = "'Ex"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Ex2 :: GHC.Types.TrName -T18982.$tc'Ex2 = GHC.Types.TrNameS T18982.$tc'Ex3 +$tc'Ex2 :: GHC.Internal.Types.TrName +$tc'Ex2 = GHC.Internal.Types.TrNameS $tc'Ex1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Ex :: GHC.Types.TyCon -T18982.$tc'Ex = GHC.Types.TyCon 14609381081172201359#Word64 3077219645053200509#Word64 T18982.$trModule T18982.$tc'Ex2 2# T18982.$tc'Ex1 +T18982.$tc'Ex :: GHC.Internal.Types.TyCon +T18982.$tc'Ex = GHC.Internal.Types.TyCon 14609381081172201359#Word64 3077219645053200509#Word64 T18982.$trModule $tc'Ex2 2# $krep9 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tcGADT2 :: GHC.Prim.Addr# -T18982.$tcGADT2 = "GADT"# +$tcGADT1 :: GHC.Internal.Prim.Addr# +$tcGADT1 = "GADT"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tcGADT1 :: GHC.Types.TrName -T18982.$tcGADT1 = GHC.Types.TrNameS T18982.$tcGADT2 +$tcGADT2 :: GHC.Internal.Types.TrName +$tcGADT2 = GHC.Internal.Types.TrNameS $tcGADT1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tcGADT :: GHC.Types.TyCon -T18982.$tcGADT = GHC.Types.TyCon 9243924476135839950#Word64 5096619276488416461#Word64 T18982.$trModule T18982.$tcGADT1 0# GHC.Types.krep$*Arr* +T18982.$tcGADT :: GHC.Internal.Types.TyCon +T18982.$tcGADT = GHC.Internal.Types.TyCon 9243924476135839950#Word64 5096619276488416461#Word64 T18982.$trModule $tcGADT2 0# GHC.Internal.Types.krep$*Arr* -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep8 :: [GHC.Types.KindRep] -$krep8 = GHC.Types.: @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep) +$krep10 :: [GHC.Internal.Types.KindRep] +$krep10 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep9 :: GHC.Types.KindRep -$krep9 = GHC.Types.KindRepTyConApp T18982.$tcGADT $krep8 +$krep11 :: GHC.Internal.Types.KindRep +$krep11 = GHC.Internal.Types.KindRepTyConApp T18982.$tcGADT $krep10 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'GADT1 :: GHC.Types.KindRep -T18982.$tc'GADT1 = GHC.Types.KindRepFun $krep $krep9 +$krep12 :: GHC.Internal.Types.KindRep +$krep12 = GHC.Internal.Types.KindRepFun $krep $krep11 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'GADT3 :: GHC.Prim.Addr# -T18982.$tc'GADT3 = "'GADT"# +$tc'GADT1 :: GHC.Internal.Prim.Addr# +$tc'GADT1 = "'GADT"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'GADT2 :: GHC.Types.TrName -T18982.$tc'GADT2 = GHC.Types.TrNameS T18982.$tc'GADT3 +$tc'GADT2 :: GHC.Internal.Types.TrName +$tc'GADT2 = GHC.Internal.Types.TrNameS $tc'GADT1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'GADT :: GHC.Types.TyCon -T18982.$tc'GADT = GHC.Types.TyCon 2077850259354179864#Word64 16731205864486799217#Word64 T18982.$trModule T18982.$tc'GADT2 0# T18982.$tc'GADT1 +T18982.$tc'GADT :: GHC.Internal.Types.TyCon +T18982.$tc'GADT = GHC.Internal.Types.TyCon 2077850259354179864#Word64 16731205864486799217#Word64 T18982.$trModule $tc'GADT2 0# $krep12 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tcExGADT2 :: GHC.Prim.Addr# -T18982.$tcExGADT2 = "ExGADT"# +$tcExGADT1 :: GHC.Internal.Prim.Addr# +$tcExGADT1 = "ExGADT"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tcExGADT1 :: GHC.Types.TrName -T18982.$tcExGADT1 = GHC.Types.TrNameS T18982.$tcExGADT2 +$tcExGADT2 :: GHC.Internal.Types.TrName +$tcExGADT2 = GHC.Internal.Types.TrNameS $tcExGADT1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tcExGADT :: GHC.Types.TyCon -T18982.$tcExGADT = GHC.Types.TyCon 6470898418160489500#Word64 10361108917441214060#Word64 T18982.$trModule T18982.$tcExGADT1 0# GHC.Types.krep$*Arr* +T18982.$tcExGADT :: GHC.Internal.Types.TyCon +T18982.$tcExGADT = GHC.Internal.Types.TyCon 6470898418160489500#Word64 10361108917441214060#Word64 T18982.$trModule $tcExGADT2 0# GHC.Internal.Types.krep$*Arr* -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep10 :: GHC.Types.KindRep -$krep10 = GHC.Types.KindRepTyConApp T18982.$tcExGADT $krep8 +$krep13 :: GHC.Internal.Types.KindRep +$krep13 = GHC.Internal.Types.KindRepTyConApp T18982.$tcExGADT $krep10 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep11 :: GHC.Types.KindRep -$krep11 = GHC.Types.KindRepFun $krep $krep10 +$krep14 :: GHC.Internal.Types.KindRep +$krep14 = GHC.Internal.Types.KindRepFun $krep $krep13 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'ExGADT1 :: GHC.Types.KindRep -T18982.$tc'ExGADT1 = GHC.Types.KindRepFun $krep2 $krep11 +$krep15 :: GHC.Internal.Types.KindRep +$krep15 = GHC.Internal.Types.KindRepFun $krep2 $krep14 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'ExGADT3 :: GHC.Prim.Addr# -T18982.$tc'ExGADT3 = "'ExGADT"# +$tc'ExGADT1 :: GHC.Internal.Prim.Addr# +$tc'ExGADT1 = "'ExGADT"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'ExGADT2 :: GHC.Types.TrName -T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3 +$tc'ExGADT2 :: GHC.Internal.Types.TrName +$tc'ExGADT2 = GHC.Internal.Types.TrNameS $tc'ExGADT1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'ExGADT :: GHC.Types.TyCon -T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1 +T18982.$tc'ExGADT :: GHC.Internal.Types.TyCon +T18982.$tc'ExGADT = GHC.Internal.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule $tc'ExGADT2 1# $krep15 --- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0} -T18982.$wi :: forall a e. (a GHC.Prim.~# Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int# -T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# } +-- RHS size: {terms: 12, types: 14, coercions: 0, joins: 0/0} +T18982.$wi :: forall a e. (a GHC.Internal.Prim.~# Int, e ~ Int) => e -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Internal.Prim.~# Int) (ww1 :: e ~ Int) (ww2 :: e) (ww3 :: GHC.Internal.Prim.Int#) -> case ww2 of { __DEFAULT -> GHC.Internal.Prim.+# ww3 1# } --- RHS size: {terms: 15, types: 22, coercions: 1, joins: 0/0} +-- RHS size: {terms: 16, types: 22, coercions: 1, joins: 0/0} i :: forall a. ExGADT a -> Int -i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww2 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } } +i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Internal.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Internal.Prim.~# Int) ww1 ww2 ww4 of ww5 { __DEFAULT -> GHC.Internal.Types.I# ww5 } } } -- RHS size: {terms: 6, types: 7, coercions: 0, joins: 0/0} T18982.$wh :: forall a. (a GHC.Prim.~# Int) => GHC.Prim.Int# -> GHC.Prim.Int# View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/01918e9ae6564c5f24993cfd6079137... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/01918e9ae6564c5f24993cfd6079137... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Magnus (＠MangoIV)