10 Jul '26
Cheng Shao pushed new branch wip/hadrian-shuffle at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/hadrian-shuffle
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] Don't make absent fillers for terminating types
by Magnus (＠MangoIV) 10 Jul '26
by Magnus (＠MangoIV) 10 Jul '26
10 Jul '26
Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC
Commits:
6c91e5e1 by Zubin Duggal at 2026-07-10T13:25:28+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)
- - - - -
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,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/-/commit/6c91e5e1a5fd411cd1e467063e699e7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c91e5e1a5fd411cd1e467063e699e7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[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
by Magnus (＠MangoIV) 10 Jul '26
by Magnus (＠MangoIV) 10 Jul '26
10 Jul '26
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/01918e9ae6564c5f24993cfd607913…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/01918e9ae6564c5f24993cfd607913…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/TTG-No-Orphans] First pass of orphan instance removal.
by recursion-ninja (＠recursion-ninja) 10 Jul '26
by recursion-ninja (＠recursion-ninja) 10 Jul '26
10 Jul '26
recursion-ninja pushed to branch wip/TTG-No-Orphans at Glasgow Haskell Compiler / GHC
Commits:
906959a1 by Recursion Ninja at 2026-07-10T06:49:06-04:00
First pass of orphan instance removal.
This is part of a technical debt removal effort made possible
now that seperating out the AST via TTG comes to a close.
As the AST in 'L.H.S' has been incrementally separated from the GHC internals,
there are many accumulated orphan instance of 'Binary', 'Outputable', 'Uniquable', etc.
The orphan instance of data-types from within 'L.H.S' are having thier orphan
instances moved to the module which defined the type-class; i.e. moving an orphan
'Binary' instance to 'GHC.Utils.Binary'.
Orphan instances resolved (57):
| Data-type | Resolved instance(s) | Former orphan module(s) |
| -------------------- | -------------------------- | ------------------------- |
| Role | Binary, NFData, Outputable | GHC.Core.Coercion.Axiom |
| SrcStrictness | Binary, NFData, Outputable | GHC.Core.DataCon |
| SrcUnpackedness | Binary, NFData, Outputable | GHC.Core.DataCon |
| Fixity | Binary, Outputable | GHC.Hs.Basic |
| FixityDirection | Binary, Outputable | GHC.Hs.Basic |
| LexicalFixity | Outputable | GHC.Hs.Basic |
| CCallTarget | NFData | GHC.Hs.Decls.Foreign |
| CType | NFData | GHC.Hs.Decls.Foreign |
| Header | NFData | GHC.Hs.Decls.Foreign |
| OverlapMode | Binary, NFData | GHC.Hs.Decls.Overlap |
| WithHsDocIdentifiers | Eq, NFData, Outputable | GHC.Hs.Doc |
| HsDocString | Eq, NFData, Show | GHC.Hs.DocString |
| HsDocStringChunk | Binary, Outputable | GHC.Hs.DocString |
| HsDocStringDecorator | Binary, Outputable | GHC.Hs.DocString |
| IEWrappedName | Eq, Outputable | GHC.Hs.ImpExp |
| NamespaceSpecifier | Eq, Outputable | GHC.Hs.ImpExp |
| IE | Eq | GHC.Hs.Instances |
| HsLit | Eq | GHC.Hs.Lit |
| HsOverLit | Eq | GHC.Hs.Lit |
| OverLitVal | Eq | GHC.Hs.Lit |
| HsQualLit | Eq | GHC.Hs.Lit |
| QualLitVal | Eq | GHC.Hs.Lit |
| FractionalLit | Eq, Show | GHC.Hs.Lit |
| IntegralLit | Eq, Show | GHC.Hs.Lit |
| StringLiteral | Eq, Show | GHC.Hs.Lit |
| ForAllTyFlag | Binary, NFData, Outputable | GHC.Hs.Specificity |
| Specificity | Binary, NFData | GHC.Hs.Specificity |
| PromotionFlag | Binary, Outputable | GHC.Types.Basic |
| FieldLabelString | Outputable, Uniquable | GHC.Types.FieldLabel |
| CCallTarget | Eq | GHC.Types.ForeignCall |
| Header | Eq | GHC.Types.ForeignCall |
| InlinePragma | Binary | GHC.Types.InlinePragma |
| InWarningCategory | Eq | GHC.Unit.Module.Warnings |
| WarningTxt | Eq | GHC.Unit.Module.Warnings |
-------------------------
Metric Decrease:
hard_hole_fits
-------------------------
Closes #21262, #27469
- - - - -
31 changed files:
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- − compiler/GHC/Hs/Specificity.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Fixity.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Types/InlinePragma.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Decls/Foreign.hs
- compiler/Language/Haskell/Syntax/Doc.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- compiler/Language/Haskell/Syntax/Specificity.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsParser.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/906959a148dddb2c0aa9a8589bb2f30…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/906959a148dddb2c0aa9a8589bb2f30…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
10 Jul '26
Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC
Commits:
2ca68dd2 by Rodrigo Mesquita at 2026-07-10T11:26:30+01:00
WIP
- - - - -
37b51e9b by Rodrigo Mesquita at 2026-07-10T11:42:23+01:00
Revert "WIP"
This reverts commit 2ca68dd2d60cf70726b396be53f42b4d52408c9c.
- - - - -
a9357c77 by Rodrigo Mesquita at 2026-07-10T11:48:58+01:00
Reapply "WIP"
This reverts commit 37b51e9b188d35ce88051744170c0c1c1c0ef9a8.
- - - - -
1 changed file:
- compiler/GHC/Driver/Downsweep.hs
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -5,6 +5,8 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
module GHC.Driver.Downsweep
( downsweep
, downsweepThunk
@@ -109,6 +111,7 @@ import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
import Control.Monad.Trans.Class
import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.IORef
{-
Note [Downsweep and the ModuleGraph]
@@ -143,6 +146,7 @@ The result is having a uniform graph available for the whole compilation pipelin
-- This caches the answer to the question, if we are in this unit, what does
-- an import of this module mean.
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]
+-- TODO: kill this type alias and see what can be removed
moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
moduleGraphNodeMap graph
@@ -193,8 +197,10 @@ downsweep :: HscEnv
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do
- n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
- (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary
+ n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
+ summ_cache <- newIORef (mkModSummaryCache old_summaries)
+ (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg
+ (getRootSummary excl_mods summ_cache)
let closure_errs = checkHomeUnitsClosed unit_env
unit_env = hsc_unit_env hsc_env
@@ -202,7 +208,7 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
case all_errs of
[] -> do
- (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
+ (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
@@ -220,17 +226,6 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
return (all_errs, th_configured_nodes)
_ -> return (all_errs, emptyMG)
where
- summary = getRootSummary excl_mods old_summary_map
-
- -- A cache from file paths to the already summarised modules. The same file
- -- can be used in multiple units so the map is also keyed by which unit the
- -- file was used in.
- -- Reuse these if we can because the most expensive part of downsweep is
- -- reading the headers.
- old_summary_map :: M.Map (UnitId, OsPath) ModSummary
- old_summary_map =
- M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries]
-
-- Dependencies arising on a unit (backpack and module linking deps)
unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
unitModuleNodes summaries uid hue =
@@ -313,8 +308,9 @@ loopFromInteractive :: HscEnv
-> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
-> M.Map NodeKey ModuleGraphNode
-> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
-loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
-loopFromInteractive hsc_env (edge:edges) cached_nodes =
+loopFromInteractive = error "TODO"
+{-
+loopFromInteractive = return ([], cached_nodes)
case edge of
Left edge -> do
(edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
@@ -342,7 +338,7 @@ loopFromInteractive hsc_env (edge:edges) cached_nodes =
return (edge : edges, cached_nodes')
-- And if it's not found.. just carry on and hope.
_ -> loopFromInteractive hsc_env edges cached_nodes
-
+-}
-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
@@ -395,7 +391,7 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed
-- This function will start at the given roots, and traverse downwards to find
-- all the dependencies, all the way to the leaf units.
downsweepFromRootNodes :: HscEnv
- -> M.Map (UnitId, OsPath) ModSummary
+ -> [ModSummary]
-> Maybe ModuleGraph
-> [ModuleName]
-> Bool
@@ -407,17 +403,16 @@ downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_du
= do
let root_map = mkRootMap root_nodes
checkDuplicates root_map
- let env = DownsweepEnv hsc_env mode old_summaries excl_mods
- (deps', map0) <- runDownsweepM env $ do
- let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
- (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map)
- let all_deps = loopUnit hsc_env module_deps root_uids
- let all_instantiations = getHomeUnitInstantiations hsc_env
- deps' <- loopInstantiations all_instantiations all_deps
- return (deps', map0)
-
-
- let downsweep_errs = lefts $ concat $ M.elems map0
+ summ_cache <- newIORef (foldr insertRoot (mkModSummaryCache old_summaries) root_nodes)
+ let env = DownsweepEnv hsc_env mode summ_cache excl_mods
+ deps' <- runDownsweepM env $ do
+ let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
+ module_deps <- loopModuleNodeInfos base_nodes root_nodes
+ all_deps <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids
+ deps' <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env)
+ return deps'
+ (m_cache, f_cache) <- readIORef summ_cache
+ let downsweep_errs = lefts (moduleEnvElts m_cache) ++ lefts (M.elems f_cache)
downsweep_nodes = M.elems deps'
return (downsweep_errs, downsweep_nodes)
@@ -441,6 +436,8 @@ downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_du
dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
+ insertRoot (ModuleNodeCompile ms) = addModSummaryCache ms
+ insertRoot (ModuleNodeFixed _ _) = id
calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
calcDeps ms =
@@ -455,104 +452,186 @@ type DownsweepM a = ReaderT DownsweepEnv IO a
data DownsweepEnv = DownsweepEnv {
downsweep_hsc_env :: HscEnv
, _downsweep_mode :: DownsweepMode
- , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary
+ , _downsweep_summaries_cache :: ModSummaryCache
, _downsweep_excl_mods :: [ModuleName]
}
-runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
-runDownsweepM env act = runReaderT act env
+type ModSummaryCache = IORef ModSummaryCacheMap
+
+-- | A cache both from 'Module' or file paths to the already summarised
+-- modules. The same file can be used in multiple units so the file-path map is
+-- actually also keyed by which unit the file was used in.
+--
+-- We want to reuse ModSummaries as far as possible because the most expensive
+-- part of downsweep is reading the headers.
+type ModSummaryCacheMap
+ = ( ModuleEnv (Either DriverMessages ModSummary)
+ , M.Map (UnitId, OsPath) (Either DriverMessages ModSummary) )
+mkModSummaryCache :: [ModSummary] -> ModSummaryCacheMap
+mkModSummaryCache summs = foldr addModSummaryCache (emptyModuleEnv, M.empty) summs
-loopInstantiations :: [(UnitId, InstantiatedUnit)]
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopInstantiations [] done = pure done
-loopInstantiations ((home_uid, iud) :xs) done = do
- hsc_env <- asks downsweep_hsc_env
- let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
- payload = InstantiationNode home_uid iud
- loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
-
-
--- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
-loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode,
- DownsweepCache)
- -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
-loopSummaries [] done = pure done
-loopSummaries (ms:next) (done, summarised)
- | Just {} <- M.lookup k done
- = loopSummaries next (done, summarised)
- -- Didn't work out what the imports mean yet, now do that.
- | otherwise = do
- (final_deps, done', summarised') <- loopImports (ms_unitid ms) (calcDeps ms) done summarised
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, done'', summarised'') <- loopImports (ms_unitid ms) (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
+addModSummaryCache :: ModSummary -> ModSummaryCacheMap -> ModSummaryCacheMap
+addModSummaryCache ms (me, fe) = (upd_me me, upd_fe fe)
where
- k = NodeKey_Module (msKey ms)
+ upd_me me = extendModuleEnv me (ms_mod ms) (Right ms)
+ upd_fe fe
+ | Just src_fn_os <- ml_hs_file_ospath (ms_location ms)
+ = M.insert (ms_unitid ms, src_fn_os) (Right ms) fe
+ | otherwise = fe
- hs_file_for_boot
- | HsBootFile <- ms_hsc_src ms
- = Just (NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
- | otherwise
- = Nothing
-
-loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
-loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
-
-loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
-loopModuleNodeInfo mod_node_info (done, summarised) = do
- case mod_node_info of
- ModuleNodeCompile ms -> do
- loopSummaries [ms] (done, summarised)
- ModuleNodeFixed mod ml -> do
- done' <- loopFixedModule mod ml done
- return (done', summarised)
-
--- NB: loopFixedModule does not take a downsweep cache, because if you
--- ever reach a Fixed node, everything under that also must be fixed.
-loopFixedModule :: ModNodeKeyWithUid -> ModLocation
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedModule key loc done = do
- let nk = NodeKey_Module key
- hsc_env <- asks downsweep_hsc_env
- case M.lookup nk done of
- Just {} -> return done
- Nothing -> do
- -- MP: TODO, we should just read the dependency info from the interface rather than either
- -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
- -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
- read_result <- liftIO $
- -- 1. Check if the interface is already loaded into the EPS by some other
- -- part of the compiler.
- lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
- Just iface -> return (M.Succeeded iface)
- Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
+runDownsweepM env act = runReaderT act env
+
+loopDownsweepNodes :: M.Map NodeKey ModuleGraphNode -> [DownsweepNode] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopModuleNodeInfos :: M.Map NodeKey ModuleGraphNode -> [ModuleNodeInfo] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopUnits :: M.Map NodeKey ModuleGraphNode -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopInstantiations :: M.Map NodeKey ModuleGraphNode -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopDownsweepNodes base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
+loopModuleNodeInfos base_map = loopDownsweepNodes base_map . map DSMod
+loopUnits base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
+loopInstantiations base_map = loopDownsweepNodes base_map . map (uncurry DSInst)
+
+--------------------------------------------------------------------------------
+
+-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
+-- encompasses the types of nodes we can iteratively expand to construct the
+-- full module graph. See 'loopDownsweepNodes'.
+data DownsweepNode
+ = DSMod ModuleNodeInfo
+ -- ^ A module node to expand
+ | DSUnit
+ { home_context_uid :: UnitId
+ -- ^ The home unit which introduced the dependency on this 'node_uid'. This
+ -- 'node_uid' can only be expanded in the context ('HscEnv') where
+ -- 'home_context_uid' is the active home unit, to make sure the package flags
+ -- are the ones attributed to the home package that introduced this node.
+ , node_uid :: UnitId
+ -- ^ The unit node to expand
+ }
+ | DSInst
+ { home_context_uid :: UnitId
+ , instantiated_ud :: InstantiatedUnit
+ }
+
+-- | They key by which to cache previously visited 'DownsweepNode's
+dsNodeInfoKey :: DownsweepNode -> NodeKey
+dsNodeInfoKey = \case
+ DSMod (ModuleNodeCompile ms) -> NodeKey_Module (msKey ms)
+ DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod
+ DSUnit uid _ctx_uid -> NodeKey_ExternalUnit uid
+ DSInst{instantiated_ud} -> NodeKey_Unit instantiated_ud
+
+dsNodeExpand :: DownsweepNode -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
+dsNodeExpand = \case
+ DSMod (ModuleNodeCompile ms) -> expandModuleSummary ms
+ DSMod (ModuleNodeFixed key loc) -> expandFixedModuleNode key loc
+ DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid
+ DSInst{ instantiated_ud
+ , home_context_uid } -> expandInstantiatedUnit instantiated_ud home_context_uid
+
+expandModuleSummary :: ModSummary -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
+expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
+ hsc_env <- asks downsweep_hsc_env
+ let home_uid = ms_unitid ms
+ home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do
+ let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
+ wanted_mod = L loc mod
+ mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing
+ case mb_s of
+ NotThere -> return
+ ( Nothing, [] )
+ External uid -> return
+ ( Just $ mkModuleEdge imp (NodeKey_ExternalUnit uid)
+ -- Specify home unit, as each unit might have a different visible package database.
+ , [DSUnit{node_uid = uid, home_context_uid = home_uid}] )
+ FoundInstantiation iud -> return
+ ( Just (mkModuleEdge imp (NodeKey_Unit iud)), [] )
+ FoundHomeWithError (_uid, _e) -> return
+ ( Nothing, [] )
+ -- the error @e@ is already stored in the summarisation cache,
+ -- (the IORef in DownsweepM) and will get reported at the end.
+ FoundHome s -> return
+ -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
+ ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))
+ , [DSMod s] )
+ -- TODO: if this FoundHome was already in the cache, we shouldn't
+ -- return any dependencies right? or will it all work out?
+
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ if | HsBootFile <- ms_hsc_src ms
+ -> void $
+ downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
+ | otherwise
+ -> pure ()
+
+ return $ Just
+ ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
+ , concat todo )
+
+-- | Expand a 'ModuleNodeFixed' node
+-- NB: If you ever reach a Fixed node, everything under that also must be fixed.
+expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
+expandFixedModuleNode key loc = do
+ hsc_env <- asks downsweep_hsc_env
+ -- MP: TODO, we should just read the dependency info from the interface rather than either
+ -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
+ -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
+ read_result <- liftIO $
+ -- 1. Check if the interface is already loaded into the EPS by some other
+ -- part of the compiler.
+ lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
+ Just iface -> return (M.Succeeded iface)
+ Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+ case read_result of
+ M.Succeeded iface -> do
+ -- Computer information about this node
+ let node_deps = ifaceDeps (mi_deps iface)
+ edges = map mkFixedEdge node_deps
+ node = ModuleNode edges (ModuleNodeFixed key loc)
+ deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps)
+ pure $ Just (node, deps')
+
+ -- Ignore any failure, we might try to read a .hi-boot file for
+ -- example, even if there is not one.
+ M.Failed {} ->
+ pure Nothing
+ where
+ mk_dep hsc_env (Left key) = do
+ -- Like expandImports, but we already know exactly which module we are looking for.
+ read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
case read_result of
- M.Succeeded iface -> do
- -- Computer information about this node
- let node_deps = ifaceDeps (mi_deps iface)
- edges = map mkFixedEdge node_deps
- node = ModuleNode edges (ModuleNodeFixed key loc)
- foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
- -- Ignore any failure, we might try to read a .hi-boot file for
- -- example, even if there is not one.
- M.Failed {} ->
- return done
-
-loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedNodeKey _ done (Left key) = do
- loopFixedImports [key] done
-loopFixedNodeKey home_uid done (Right uid) = do
- -- Set active unit so that looking loopUnit finds the correct
- -- -package flags in the unit state.
- hsc_env <- asks downsweep_hsc_env
- let hsc_env' = hscSetActiveUnitId home_uid hsc_env
- return $ loopUnit hsc_env' done [uid]
+ InstalledFound loc -> do
+ pure $ Just $ DSMod (ModuleNodeFixed key loc)
+ _otherwise ->
+ -- If the finder fails, just keep going, there will be another
+ -- error later.
+ pure Nothing
+ mk_dep _ (Right uid_dep) = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ let home_uid = mnkUnitId key
+ pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
+
+-- | Expand a unit id under the context of a certain home unit
+expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
+ -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
+expandUnitNode node_uid home_context_uid = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ hsc_env <- asks downsweep_hsc_env
+ let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env
+ case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of
+ Just us -> pure $ Just ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)
+
+expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
+expandInstantiatedUnit iud home_uid = pure $ Just
+ ( InstantiationNode home_uid iud
+ , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )
+
+--------------------------------------------------------------------------------
mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
@@ -567,27 +646,6 @@ ifaceDeps deps =
| (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
]
--- Like loopImports, but we already know exactly which module we are looking for.
-loopFixedImports :: [ModNodeKeyWithUid]
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepM (M.Map NodeKey ModuleGraphNode)
-loopFixedImports [] done = pure done
-loopFixedImports (key:keys) done = do
- let nk = NodeKey_Module key
- hsc_env <- asks downsweep_hsc_env
- case M.lookup nk done of
- Just {} -> loopFixedImports keys done
- Nothing -> do
- read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
- case read_result of
- InstalledFound loc -> do
- done' <- loopFixedModule key loc done
- loopFixedImports keys done'
- _otherwise ->
- -- If the finder fails, just keep going, there will be another
- -- error later.
- loopFixedImports keys done
-
downsweepSummarise :: HomeUnit
-> IsBootInterface
-> Located ModuleName
@@ -595,82 +653,11 @@ downsweepSummarise :: HomeUnit
-> Maybe (StringBuffer, UTCTime)
-> DownsweepM SummariseResult
downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
- DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
+ DownsweepEnv hsc_env mode summaries_cache_ref excl_mods <- ask
case mode of
- DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
+ DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit summaries_cache_ref is_boot wanted_mod mb_pkg maybe_buf excl_mods
DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
-
--- This loops over each import in each summary. It is mutually recursive with
--- loopSummaries if we discover a new module by doing this.
-loopImports
- :: UnitId
- -- ^ UnitId of home unit of summary whose imports are being processed
- -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
- -- ^ Work list: process these modules
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepCache
- -- ^ Visited set; the range is a list because
- -- the roots can have the same module names
- -- if allow_dup_roots is True
- -> DownsweepM ([ModuleNodeEdge],
- M.Map NodeKey ModuleGraphNode, DownsweepCache)
- -- ^ The result is the completed NodeMap
-loopImports _ [] done summarised = return ([], done, summarised)
-loopImports home_uid ((imp, mb_pkg, gwib) : ss) done summarised
- | Just summs <- M.lookup cache_key summarised
- = case summs of
- [Right ms] -> do
- let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
- (rest, summarised', done') <- loopImportsNext done summarised
- return (nk: rest, summarised', done')
- [Left _err] ->
- loopImportsNext done summarised
- _errs -> do
- loopImportsNext done summarised
- | otherwise
- = do
- hsc_env <- asks downsweep_hsc_env
- let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- mb_s <- downsweepSummarise home_unit
- is_boot wanted_mod mb_pkg
- Nothing
- case mb_s of
- NotThere -> loopImportsNext done summarised
- External uid -> do
- -- Pass an updated hsc_env to loopUnit, as each unit might
- -- have a different visible package database.
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- let done' = loopUnit hsc_env' done [uid]
- (other_deps, done'', summarised') <- loopImportsNext done' summarised
- return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
- FoundInstantiation iud -> do
- (other_deps, done', summarised') <- loopImportsNext done summarised
- return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
- FoundHomeWithError (_uid, e) -> loopImportsNext done (Map.insert cache_key [(Left e)] summarised)
- FoundHome s -> do
- (done', summarised') <-
- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
- (other_deps, final_done, final_summarised) <- loopImportsNext done' summarised'
-
- -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
- where
- loopImportsNext = loopImports home_uid ss
- cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
- wanted_mod = L loc mod
-
-loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
-loopUnit _ cache [] = cache
-loopUnit lcl_hsc_env cache (u:uxs) = do
- let nk = (NodeKey_ExternalUnit u)
- case Map.lookup nk cache of
- Just {} -> loopUnit lcl_hsc_env cache uxs
- Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
- Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
- Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
-
multiRootsErr :: SourceErrorContext -> [ModuleNodeInfo] -> IO ()
multiRootsErr _ [] = panic "multiRootsErr"
multiRootsErr sec summs@(summ1:_)
@@ -732,24 +719,24 @@ linkNodes summaries uid hue =
getRootSummary ::
[ModuleName] ->
- M.Map (UnitId, OsPath) ModSummary ->
+ ModSummaryCache ->
HscEnv ->
Target ->
IO (Either DriverMessages ModSummary)
-getRootSummary excl_mods old_summary_map hsc_env target
+getRootSummary excl_mods summ_cache hsc_env target
| TargetFile file mb_phase <- targetId
= do
let offset_file = augmentByWorkingDirectory dflags file
exists <- liftIO $ doesFileExist offset_file
if exists || isJust maybe_buf
- then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
+ then summariseFile hsc_env home_unit summ_cache offset_file mb_phase
maybe_buf
else
return $ Left $ singleMessage $
mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
| TargetModule modl <- targetId
= do
- maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
+ maybe_summary <- summariseModule hsc_env home_unit summ_cache NotBoot
(L rootLoc modl) (ThisPkg (homeUnitId home_unit))
maybe_buf excl_mods
pure case maybe_summary of
@@ -1178,9 +1165,7 @@ Potential TODOS:
-}
-- | Populate the Downsweep cache with the root modules.
-mkRootMap
- :: [ModuleNodeInfo]
- -> DownsweepCache
+mkRootMap :: [ModuleNodeInfo] -> DownsweepCache
mkRootMap summaries = Map.fromListWith (flip (++))
[ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ]
@@ -1200,33 +1185,32 @@ mkRootMap summaries = Map.fromListWith (flip (++))
summariseFile
:: HscEnv
-> HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary -- old summaries
+ -> ModSummaryCache
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Maybe (StringBuffer,UTCTime)
-> IO (Either DriverMessages ModSummary)
-summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
- -- we can use a cached summary if one is available and the
- -- source file hasn't changed,
- | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
- = do
- let location = ms_location $ old_summary
-
- src_hash <- get_src_hash
- -- The file exists; we checked in getRootSummary above.
- -- If it gets removed subsequently, then this
- -- getFileHash may fail, but that's the right
- -- behaviour.
-
- -- return the cached summary if the source didn't change
- checkSummaryHash
- hsc_env (new_summary src_fn)
- old_summary location src_hash
-
- | otherwise
- = do src_hash <- get_src_hash
- new_summary src_fn src_hash
+summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf
+ = do (_, file_summ_cache) <- readIORef summ_cache_ref
+ case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of
+ Just (Right old_summary) -> do
+ -- we can use a cached summary if one is available and the
+ -- source file hasn't changed,
+ let location = ms_location $ old_summary
+
+ src_hash <- get_src_hash
+ -- The file exists; we checked in getRootSummary above.
+ -- If it gets removed subsequently, then this
+ -- getFileHash may fail, but that's the right
+ -- behaviour.
+
+ -- return the cached summary if the source didn't change
+ checkSummaryHash
+ hsc_env (new_summary src_fn)
+ old_summary location src_hash
+ _ -> do src_hash <- get_src_hash
+ new_summary src_fn src_hash
where
-- change the main active unit so all operations happen relative to the given unit
hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
@@ -1237,7 +1221,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
Just (buf,_) -> return $ fingerprintStringBuffer buf
Nothing -> liftIO $ getFileHash src_fn
- new_summary src_fn src_hash = runExceptT $ do
+ new_summary src_fn src_hash = do
+ res <- runExceptT $ do
preimps@PreprocessedImports {..}
<- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
@@ -1268,6 +1253,11 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
, nms_mod = mod
, nms_preimps = preimps
}
+ case res of
+ Left e -> modifyIORef' summ_cache_ref
+ (\(me, fe) -> (me, M.insert (homeUnitId home_unit, src_fn_os) (Left e) fe))
+ Right ms -> modifyIORef' summ_cache_ref (addModSummaryCache ms)
+ return res
checkSummaryHash
:: HscEnv
@@ -1320,7 +1310,7 @@ data SummariseResult =
-- --make mode.
summariseModule :: HscEnv
-> HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary
+ -> ModSummaryCache
-> IsBootInterface
-> Located ModuleName
-> PkgQual
@@ -1400,15 +1390,15 @@ summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg exc
-- for it and potentially compile it.
summariseModuleWithSource
:: HomeUnit
- -> M.Map (UnitId, OsPath) ModSummary
- -- ^ Map of old summaries
+ -> ModSummaryCache
+ -- ^ Cache of constructed summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Maybe (StringBuffer, UTCTime)
-> HscEnv
-> ModLocation
-> Module
-> IO SummariseResult
-summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do
+summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env location mod = do
-- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
let src_fn = expectJust (ml_hs_file location)
@@ -1428,20 +1418,19 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo
where
dflags = hsc_dflags hsc_env
- new_summary_cache_check loc mod src_fn h
- | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
-
- -- check the hash on the source file, and
- -- return the cached summary if it hasn't changed. If the
- -- file has changed then need to resummarise.
- case maybe_buf of
- Just (buf,_) ->
- checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
- Nothing ->
- checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
- | otherwise = new_summary loc mod src_fn h
- where
- src_fn_os = unsafeEncodeUtf src_fn
+ new_summary_cache_check loc mod src_fn h = do
+ (summ_cache, _) <- readIORef summ_cache_ref
+ case lookupModuleEnv summ_cache mod of
+ Just (Right old_summary) -> do
+ -- check the hash on the source file, and
+ -- return the cached summary if it hasn't changed. If the
+ -- file has changed then need to resummarise.
+ case maybe_buf of
+ Just (buf,_) ->
+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
+ Nothing ->
+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
+ _ -> new_summary loc mod src_fn h
new_summary :: ModLocation
-> Module
@@ -1449,41 +1438,48 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary location mod src_fn src_hash
- = runExceptT $ do
- preimps@PreprocessedImports {..}
- -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
- -- See multiHomeUnits_cpp2 test
- <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
-
- -- NB: Despite the fact that is_boot is a top-level parameter, we
- -- don't actually know coming into this function what the HscSource
- -- of the module in question is. This is because we may be processing
- -- this module because another module in the graph imported it: in this
- -- case, we know if it's a boot or not because of the {-# SOURCE #-}
- -- annotation, but we don't know if it's a signature or a regular
- -- module until we actually look it up on the filesystem.
- let hsc_src
- | is_boot == IsBoot = HsBootFile
- | isHaskellSigFilename src_fn = HsigFile
- | otherwise = HsSrcFile
-
- when (pi_mod_name /= moduleName mod) $
- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
- $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
-
- let instantiations = homeUnitInstantiations home_unit
- when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
- $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
+ = pprTrace "new_summary" (ppr mod) $ do
+ res <- runExceptT $ do
+ preimps@PreprocessedImports {..}
+ -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
+ -- See multiHomeUnits_cpp2 test
+ <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
+
+ -- NB: Despite the fact that is_boot is a top-level parameter, we
+ -- don't actually know coming into this function what the HscSource
+ -- of the module in question is. This is because we may be processing
+ -- this module because another module in the graph imported it: in this
+ -- case, we know if it's a boot or not because of the {-# SOURCE #-}
+ -- annotation, but we don't know if it's a signature or a regular
+ -- module until we actually look it up on the filesystem.
+ let hsc_src
+ | is_boot == IsBoot = HsBootFile
+ | isHaskellSigFilename src_fn = HsigFile
+ | otherwise = HsSrcFile
+
+ when (pi_mod_name /= moduleName mod) $
+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
+ $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
+
+ let instantiations = homeUnitInstantiations home_unit
+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
+ $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
+
+ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
+ { nms_src_fn = src_fn
+ , nms_src_hash = src_hash
+ , nms_hsc_src = hsc_src
+ , nms_location = location
+ , nms_mod = mod
+ , nms_preimps = preimps
+ }
+ case res of
+ Left e -> modifyIORef' summ_cache_ref
+ (\(me, fe) -> (extendModuleEnv me mod (Left e), fe))
+ Right ms -> modifyIORef' summ_cache_ref (addModSummaryCache ms)
+ return res
- liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
- { nms_src_fn = src_fn
- , nms_src_hash = src_hash
- , nms_hsc_src = hsc_src
- , nms_location = location
- , nms_mod = mod
- , nms_preimps = preimps
- }
-- | Convenience named arguments for 'makeNewModSummary' only used to make
-- code more readable, not exported.
@@ -1563,3 +1559,37 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
let pi_srcimps = pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
return PreprocessedImports {..}
+
+--------------------------------------------------------------------------------
+
+-- ToDo: MiniQuickCheck me that I don't ever expand the same node twice (by key)
+-- ToDo: Docs
+-- base, roots, node to key, expand
+--
+-- @n@: a graph node, from which you can recover the key and dependencies
+-- @k@: a key from which you can compute the graph node (thus, transitively, the dependencies of that key too)
+--
+-- @n@ instanced by @ModuleGraphNode@
+-- @k@ instanced by @NodeKey@
+--
+-- Returning 'Nothing' in the @expand@ function means that node couldn't be
+-- expanded yet, and we should continue without failure. Do NOT cache a
+-- "negative" result for the 'Nothing', because we may yet discover new
+-- information and try to expand that node in the future again, then
+-- successfully.
+dfsBuild :: (Ord k, Monad m) => Maybe (Map.Map k v) -> [n] -> (n -> k) -> (n -> m (Maybe (v,[n]))) -> m (Map.Map k v)
+dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
+ where
+ go [] visited = pure visited
+ go (s:ss) visited
+ | k `Map.member` visited
+ = go ss visited
+ | otherwise
+ = do r <- expand s
+ case r of
+ Nothing -> go ss visited -- Skip!
+ Just (v,ns) ->
+ go (ns ++ ss {- todo: not use ++ here? -})
+ (Map.insert k v visited)
+ where
+ k = key s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfe34135622aad8352d191a3d13352…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dfe34135622aad8352d191a3d13352…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
10 Jul '26
Simon Jakobi pushed new branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/mr16259
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: hadrian: binary-dist-dir should not be the default target
by Marge Bot (＠marge-bot) 10 Jul '26
by Marge Bot (＠marge-bot) 10 Jul '26
10 Jul '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2ecabb4f by Zubin Duggal at 2026-07-09T09:23:25-04:00
hadrian: binary-dist-dir should not be the default target
Revert behaviour to pre 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
In 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2, we applied the following behaviour change:
```
hadrian: Build stage 2 cross compilers
...
* hadrian: Make binary-dist-dir the default build target. This allows us
to have the logic in one place about which libraries/stages to build
with cross compilers. Fixes #24192
```
This is a major regression to development experience, a plain hadrian/build
--freeze1 now takes ages because we rebuild all docs (which need to go in the
binary dist dir).
`binary-dist-dir` is the wrong default target for regular GHC development work
Fixes #27445
- - - - -
e16388e3 by Zubin Duggal at 2026-07-09T09:23:25-04:00
.gitignore: Add the hadrian system.config introduced by commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
Since
commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2
Author: Matthew Pickering <matthewtpickering(a)gmail.com>
Date: Thu Dec 21 16:17:41 2023 +0000
hadrian: Build stage 2 cross compilers
./configure produces /hadrian/cfg/system.config.{host,target}
Add these to .gitignore
- - - - -
7e8abf41 by Alan Zimmerman at 2026-07-09T09:24:12-04:00
EPA: Replace AnnListItem with simply [TrailingAnn]
Remove the unnecessary wrapper around a single field.
- - - - -
29032f17 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Keep real reason for fragile test failures
- - - - -
c34e03a7 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Fall back to the failure reason for empty JUnit bodies
- - - - -
409d40f0 by Zubin Duggal at 2026-07-09T09:24:58-04:00
testsuite: Show output diffs in JUnit output
Also refactor compare_outputs to return essentially a `Maybe Diff`
(`CompareOutput`) instead of a bool, but more pythonic. This
allows us to pass the diff through nice.
- - - - -
06fee1ab by Zubin Duggal at 2026-07-09T09:24:58-04:00
perf notes: include stat deviation and acceptance window in notes so they show up in gitlab
- - - - -
977f25ec by mangoiv at 2026-07-10T06:08:10-04:00
driver: enable -finter-module-far-jumps by default
this fixes a compatibility bug with certain binutils/gcc versions where
we were seeing jump offset overflow errors.
This commit can probably reverted if we stop supporting the problematic
binutils/gcc verions (2.44 and 14.2, respectively)
Reolves #26994
- - - - -
fa3783c6 by Andrea Vezzosi at 2026-07-10T06:08:14-04:00
[Fix #27287] preserve ModBreaks in ModIface
- - - - -
67 changed files:
- .gitignore
- + changelog.d/inter-module-far-jumps-aarch64-default
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Main/Hsc.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- + compiler/GHC/HsToCore/Breakpoints/Types.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Platform/Ways.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/using-optimisation.rst
- hadrian/src/Rules.hs
- hadrian/src/Rules/BinaryDist.hs
- testsuite/driver/junit.py
- testsuite/driver/perf_notes.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/driver/testutil.py
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/ghci/should_run/Makefile
- + testsuite/tests/ghci/should_run/T27287.hs
- + testsuite/tests/ghci/should_run/T27287.stdout
- testsuite/tests/ghci/should_run/all.T
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/typecheck/should_compile/T15242.stderr
- testsuite/tests/typecheck/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/993ef77031ae2fd423e0d4f427d70f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/993ef77031ae2fd423e0d4f427d70f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] 2 commits: Fix a profiling race condition resulting in segfaults.
by Magnus (＠MangoIV) 10 Jul '26
by Magnus (＠MangoIV) 10 Jul '26
10 Jul '26
Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC
Commits:
a363de14 by Andreas Klebinger at 2026-07-10T11:44:10+02:00
Fix a profiling race condition resulting in segfaults.
StgToCmm: Don't assume tagged FUN closures in closureCodeBody.
When entering a closure the self/node pointer might not be tagged in
some situations when a thunk is evaluated by multiple threads.
So we most AND away the tag bits rather than subtracting an expected tag.
Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC.
In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens
another thread or the GC itself might mutate the closure making entering it no longer
valid. We now check for this.
Add test and changelog for #27123 fixes.
(cherry picked from commit ed09895d7de1ca116a561868c151fd825a16ad0c)
- - - - -
01918e9a by Zubin Duggal at 2026-07-10T11:44:10+02:00
Bump semaphore-compat submodule to 2.0.1
This versions includes some cruicial fixes for darwin
(cherry picked from commit 4180af3f71754472dbd49b85179b25fd29bd9998)
- - - - -
8 changed files:
- + changelog.d/T27123.md
- changelog.d/semaphore-v2
- compiler/GHC/StgToCmm/Bind.hs
- hadrian/src/Settings/Warnings.hs
- libraries/semaphore-compat
- rts/Apply.cmm
- + testsuite/tests/rts/T27123.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/T27123.md
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+synopsis: Fix two crashes that could happen in a multithreaded setting when profiling.
+description: There were two bugs that could cause occasional segfaults or crashes with
+an `PAP object entered` error when profiling. They only happened when two threads
+where racing to evaluate the same thunk, and specific GC timings.
+mrs: !16214
+issues: #27123
=====================================
changelog.d/semaphore-v2
=====================================
@@ -2,7 +2,7 @@ section: compiler
issues: #25087
mrs: !15729
synopsis:
- Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2)
+ Update to semaphore-compat 2.0.1 (``-jsem`` protocol v2)
description:
On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client
now speaks v2 of the semaphore-compat protocol, which uses Unix
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -587,9 +587,8 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
-- ticky after heap check to avoid double counting
; tickyEnterFun cl_info
; enterCostCentreFun cc
- (CmmMachOp (mo_wordSub platform)
- [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
- , mkIntExpr platform (funTag platform cl_info) ])
+ (cmmUntag platform (CmmReg (CmmLocal node))) -- See [NodeReg clobbered with loopification]
+
; fv_bindings <- mapM bind_fv fv_details
-- Load free vars out of closure *after*
-- heap check, to reduce live vars over check
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -89,4 +89,6 @@ ghcWarningsArgs = do
, "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240
, "-Wno-deriving-typeable"
]
- , package xhtml ? pure [ "-Wno-unused-imports" ] ] ]
+ , package xhtml ? pure [ "-Wno-unused-imports" ]
+ , package semaphoreCompat ? pure [ "-Wno-unused-imports" ]
+ ] ]
=====================================
libraries/semaphore-compat
=====================================
@@ -1 +1 @@
-Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f
+Subproject commit ebcb68506e67de9c8190c0394e10c913593d85da
=====================================
rts/Apply.cmm
=====================================
@@ -99,12 +99,14 @@ again:
W_ info;
P_ untaggedfun;
W_ arity;
+ W_ closure_type;
// We must obey the correct heap object observation pattern in
// Note [Heap memory barriers] in SMP.h.
untaggedfun = UNTAG(fun);
info = %INFO_PTR(untaggedfun);
+ closure_type = TO_W_( %INFO_TYPE(%STD_INFO(info)) );
switch [INVALID_OBJECT .. N_CLOSURE_TYPES]
- (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {
+ (closure_type) {
case
IND,
IND_STATIC:
@@ -212,10 +214,17 @@ again:
// We can't use the value of 'info' any more, because if
// STK_CHK_GEN() did a GC then the closure we're looking
// at may have changed, e.g. a THUNK_SELECTOR may have
- // been evaluated by the GC. So we reload the info
- // pointer now.
+ // been evaluated by the GC.
+ // We always reload the info pointer now. And if
+ // the closure type changed we need to take a different case
+ // alt altogether so we retry from the start in that case.
+
untaggedfun = UNTAG(fun);
info = %INFO_PTR(untaggedfun);
+ if(closure_type != TO_W_( %INFO_TYPE(%STD_INFO(info)) ) )
+ {
+ goto again;
+ }
jump %ENTRY_CODE(info)
(stg_restore_cccs_eval_info, CCCS)
=====================================
testsuite/tests/rts/T27123.hs
=====================================
@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
+-- against another thread or the GC evaluating a closure at the same time.
+
+module Main
+ -- (main)
+where
+
+import Control.Monad
+import Control.Concurrent
+import System.IO
+import GHC.Data.SmallArray
+import GHC.Exts
+import GHC.IO
+
+type Arr = SmallMutableArray RealWorld (Int->Int)
+
+io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
+io f = IO f
+
+io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
+io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
+
+{-# NOINLINE readSmallArray #-}
+readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
+ (# s2, r #) -> (# s2, r #)
+
+-- Continually overwrites the array with unevaluated thunks that will evaluated to
+-- a PAP under profiling.
+{-# NOINLINE mkThunks #-}
+mkThunks :: Arr -> IO ()
+mkThunks arr = do
+ forever $ do
+ yield
+ forM_ [0..100] $ \_j -> do
+ forM_ [0..5 :: Int] $ \i -> do
+ -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
+ let g = {-# SCC g #-} succ
+ io_ (writeSmallArray arr i g)
+
+-- Evaluate the array repeatedly in the given order.
+{-# NOINLINE evaluateThunks #-}
+evaluateThunks :: Arr -> [Int] -> IO ()
+evaluateThunks arr idxs = do
+ forever $ do
+ yield
+ -- putStr "." >> hFlush stdout
+ forM [0..5000::Int] $ \j -> do
+ forM_ idxs $ \i -> do
+ !g <- readSmallArray arr i
+ seq (g i) (pure ())
+
+main :: IO ()
+main = do
+ -- We spawn three threads.
+ -- * Two are evaluating the thunks in the array in opposite directions
+ -- * One thread is writing thunks to the array.
+ -- The reading threads will race to evaluate the same thunk triggering potential
+ -- race conditions.
+ arr <- io (newSmallArray 6 (id))
+ _ <- forkIO $ do
+ evaluateThunks arr [0..5]
+ _ <- forkIO $ do
+ evaluateThunks arr [5,4..0]
+ forkIO $ mkThunks arr
+ threadDelay 10_000_000
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -639,3 +639,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+
+test('T27123', [when(have_profiling(), extra_ways(['prof']))], compile_and_run, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/654a77942f94776053b3a7ad15e002…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/654a77942f94776053b3a7ad15e002…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/andreask/test-output
by Andreas Klebinger (＠AndreasK) 10 Jul '26
by Andreas Klebinger (＠AndreasK) 10 Jul '26
10 Jul '26
Andreas Klebinger pushed new branch wip/andreask/test-output at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/test-output
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/andreask/bump-nofib
by Andreas Klebinger (＠AndreasK) 10 Jul '26
by Andreas Klebinger (＠AndreasK) 10 Jul '26
10 Jul '26
Andreas Klebinger pushed new branch wip/andreask/bump-nofib at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/bump-nofib
You're receiving this email because of your account on gitlab.haskell.org.
1
0