Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: f7e9b9c5 by Zubin Duggal at 2026-07-11T11:19:06+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 Metric Increase: T9872b_defer (cherry picked from commit 4a59b3eece9b7106fcbe73d2d06a49755be4ea8f) - - - - - 8 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/dmdanal/should_compile/T18982.stderr Changes: ===================================== changelog.d/fix-absent-dict-projection ===================================== @@ -1,5 +1,8 @@ section: compiler -synopsis: Fix a CorePrep miscompilation that could project a field out of an absent dictionary, resulting in a segfault. +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 speculatively evaluate bindings that we have already discovered are absent. +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,13 @@ 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 +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 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 +2564,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 +2591,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 +2603,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 +2619,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 +2633,17 @@ specHeader env (bndr : bndrs) (UnspecType : args) , varToCoreExpr bndr' : 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,21 +2668,24 @@ 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 - - ; let bndr_ty = idType bndr' + <- specHeader mod env' bndrs args - -- See Note [Drop dead args from specialisations] + ; 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 lit_expr <- mkLitRubbish bndr_ty - = (Nothing, lit_expr) + , 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') @@ -2699,12 +2704,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,20 +1960,19 @@ 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. -Another Nasty Wrinkle: do not speculate absent bindings +Belt and braces: do not speculate absent bindings -Speculative evaluation is in conflict with absent fillers (see Note [Absent -fillers] in GHC.Core.Opt.WorkWrap.Utils). +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. -When an argument is found to be absent, worker/wrapper drops it and binds an -absent filler in its place. This is supposed to be OK because the filler is -absent (i.e. not evaluated by the program). - -But speculation can force it anyway! See #25924 for how this goes wrong. - -So in 'decideFloatInfo' we decline to speculate a binding whose demand is -absent. An absent value is by definition never needed, so we lose nothing by not -speculating it. +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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2227,7 +2226,7 @@ mkNonRecFloat env is_unlifted bndr rhs -- (where it is actually bound lazily). -- -- Don't speculate an absent binding. See #25924 and - -- "Another Nasty Wrinkle" in Note [Speculative evaluation]. + -- "Belt and braces" in Note [Speculative evaluation]. | is_unlifted || is_strict = (CaseBound, StrictContextFloatable) -- These will never be floated out of a lazy RHS context ===================================== 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/dmdanal/should_compile/T18982.stderr ===================================== @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 295, types: 206, coercions: 4, joins: 0/0} +Result size of Tidy Core = {terms: 297, types: 214, 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 @@ -194,13 +194,13 @@ T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3 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 --- 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.Prim.~# Int, e ~ Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) _ (ww2 :: e) (ww3 :: GHC.Prim.Int#) -> case ww2 of { __DEFAULT -> GHC.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.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww1 ww2 ww4 of ww5 { __DEFAULT -> GHC.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/-/commit/f7e9b9c5fd79c402f609fd7dab2ea59e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7e9b9c5fd79c402f609fd7dab2ea59e... You're receiving this email because of your account on gitlab.haskell.org.