July 2026 - ghc-commits

[Git][ghc/ghc][wip/25924] Don't make absent fillers for terminating types
by Zubin (＠wz1000) 03 Jul '26

03 Jul '26

Zubin pushed to branch wip/25924 at Glasgow Haskell Compiler / GHC Commits: 0d938a44 by Zubin Duggal at 2026-07-03T10:26:32+05:30 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 - - - - - 6 changed files: - changelog.d/fix-absent-dict-projection - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - testsuite/tests/dmdanal/should_compile/T18982.stderr - testsuite/tests/simplCore/should_compile/T26615.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/Opt/Specialise.hs ===================================== @@ -19,12 +19,13 @@ import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_ma import GHC.Core.Predicate import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) -import GHC.Core.DataCon (dataConTyCon) +import GHC.Core.DataCon (dataConTyCon, StrictnessMark(NotMarkedStrict)) import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core -import GHC.Core.Make ( mkLitRubbish, wrapFloats ) +import GHC.Core.Make ( wrapFloats ) +import GHC.Core.Opt.WorkWrap.Utils ( mkAbsentFiller ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Subst (substTickish) @@ -1669,7 +1670,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs | otherwise = UnspecArg ; (useful, subst', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) - <- specHeader subst rhs_bndrs all_call_args + <- specHeader this_mod subst rhs_bndrs all_call_args ; let env' = env { se_subst = subst' } -- Check for (a) usefulness and (b) not already covered @@ -2573,7 +2574,8 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: Core.Subst -- This substitution applies to the [InBndr] + :: Module -- The module being compiled, for mkAbsentFiller + -> Core.Subst -- This substitution applies to the [InBndr] -> [InBndr] -- Binders from the original function `f` -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened @@ -2598,13 +2600,13 @@ specHeader -- If we run out of binders, stop immediately -- See Note [Specialisation Must Preserve Sharing] -specHeader subst [] _ = pure (False, subst, [], [], [], [], []) -specHeader subst _ [] = pure (False, subst, [], [], [], [], []) +specHeader _ subst [] _ = pure (False, subst, [], [], [], [], []) +specHeader _ subst _ [] = pure (False, subst, [], [], [], [], []) -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader subst (bndr:bndrs) (SpecType ty : args) +specHeader mod subst (bndr:bndrs) (SpecType ty : args) = do { -- Find free_tvs, the type variables to add to the binders for the rule -- Namely those deeply free in `ty` that aren't in scope -- See (MP2) in Note [Specialising polymorphic dictionaries] @@ -2617,7 +2619,7 @@ specHeader subst (bndr:bndrs) (SpecType ty : args) ; let subst2 = Core.extendTvSubst subst1 bndr ty ; (useful, subst3, rule_bs, rule_args, spec_bs, dx, spec_args) - <- specHeader subst2 bndrs args + <- specHeader mod subst2 bndrs args ; pure ( useful, subst3 , free_tvs ++ rule_bs, Type ty : rule_args , free_tvs ++ spec_bs, dx, Type ty : spec_args ) } @@ -2626,29 +2628,34 @@ specHeader subst (bndr:bndrs) (SpecType ty : args) -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader subst (bndr:bndrs) (UnspecType : args) +specHeader mod subst (bndr:bndrs) (UnspecType : args) = do { let (subst1, bndr') = Core.substBndr subst bndr ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) - <- specHeader subst1 bndrs args + <- specHeader mod subst1 bndrs args ; let ty_e' = Type (mkTyVarTy bndr') ; pure ( useful, subst2 , bndr' : rule_bs, ty_e' : rule_es , bndr' : spec_bs, dx, ty_e' : spec_args ) } -specHeader subst (bndr:bndrs) (_ : args) +specHeader mod subst (bndr:bndrs) (_ : args) | isDeadBinder bndr , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) - , Just rubbish_lit <- mkLitRubbish (idType 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, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args + do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args ; pure ( useful, subst2 , bndr' : rule_bs, Var bndr' : rule_es - , spec_bs, dx, rubbish_lit : spec_args ) } + , 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 subst (bndr:bndrs) (SpecDict dict_arg : args) +specHeader mod subst (bndr:bndrs) (SpecDict dict_arg : args) = do { -- Make up a fresh binder to use in the RULE -- It might turn into a dict binding (via bindAuxiliaryDict) which we -- then float, so we use cloneIdBndr to get a completely fresh binder @@ -2659,7 +2666,7 @@ specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg - ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args + ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst2 bndrs args ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } ; pure ( True, subst3 -- Ha! A useful specialisation! @@ -2674,10 +2681,10 @@ specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader subst (bndr:bndrs) (UnspecArg : args) +specHeader mod subst (bndr:bndrs) (UnspecArg : args) = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) -- zapIdOccInfo: see Note [Zap occ info in rule binders] - ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader mod subst1 bndrs args ; let dummy_arg = varToCoreExpr bndr' -- dummy_arg is usually just (Var bndr), ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -554,7 +554,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 ===================================== @@ -30,7 +30,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.Predicate( isEqualityClass ) @@ -996,7 +995,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 @@ -1067,14 +1066,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) @@ -1101,7 +1106,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1295,27 +1300,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. @@ -1337,6 +1323,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 ===================================== 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.Internal.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.Internal.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.Internal.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.Internal.Types.TrName -T18982.$trModule3 = GHC.Internal.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.Internal.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.Internal.Types.TrName -T18982.$trModule1 = GHC.Internal.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.Internal.Types.Module -T18982.$trModule = GHC.Internal.Types.Module T18982.$trModule3 T18982.$trModule1 +T18982.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep :: GHC.Internal.Types.KindRep @@ -47,16 +35,16 @@ $krep2 :: GHC.Internal.Types.KindRep $krep2 = GHC.Internal.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T18982.$tcBox2 :: GHC.Internal.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.Internal.Types.TrName -T18982.$tcBox1 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tcBox = GHC.Internal.Types.TyCon 16948648223906549518#Word64 2491460178135962649#Word64 T18982.$trModule T18982.$tcBox1 0# GHC.Internal.Types.krep$*Arr* +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.Internal.Types.KindRep] @@ -67,140 +55,140 @@ $krep4 :: GHC.Internal.Types.KindRep $krep4 = GHC.Internal.Types.KindRepTyConApp T18982.$tcBox $krep3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T18982.$tc'Box1 :: GHC.Internal.Types.KindRep -T18982.$tc'Box1 = GHC.Internal.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.Internal.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.Internal.Types.TrName -T18982.$tc'Box2 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tc'Box = GHC.Internal.Types.TyCon 1412068769125067428#Word64 8727214667407894081#Word64 T18982.$trModule T18982.$tc'Box2 1# T18982.$tc'Box1 +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.Internal.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.Internal.Types.TrName -T18982.$tcEx1 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tcEx = GHC.Internal.Types.TyCon 4376661818164435927#Word64 18005417598910668817#Word64 T18982.$trModule T18982.$tcEx1 0# GHC.Internal.Types.krep$*Arr* +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.Internal.Types.KindRep] -$krep5 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep1 (GHC.Internal.Types.[] @GHC.Internal.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.Internal.Types.KindRep -$krep6 = GHC.Internal.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.Internal.Types.KindRep -$krep7 = GHC.Internal.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.Internal.Types.KindRep -T18982.$tc'Ex1 = GHC.Internal.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.Internal.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.Internal.Types.TrName -T18982.$tc'Ex2 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tc'Ex = GHC.Internal.Types.TyCon 14609381081172201359#Word64 3077219645053200509#Word64 T18982.$trModule T18982.$tc'Ex2 2# T18982.$tc'Ex1 +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.Internal.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.Internal.Types.TrName -T18982.$tcGADT1 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tcGADT = GHC.Internal.Types.TyCon 9243924476135839950#Word64 5096619276488416461#Word64 T18982.$trModule T18982.$tcGADT1 0# GHC.Internal.Types.krep$*Arr* +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.Internal.Types.KindRep] -$krep8 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep (GHC.Internal.Types.[] @GHC.Internal.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.Internal.Types.KindRep -$krep9 = GHC.Internal.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.Internal.Types.KindRep -T18982.$tc'GADT1 = GHC.Internal.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.Internal.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.Internal.Types.TrName -T18982.$tc'GADT2 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tc'GADT = GHC.Internal.Types.TyCon 2077850259354179864#Word64 16731205864486799217#Word64 T18982.$trModule T18982.$tc'GADT2 0# T18982.$tc'GADT1 +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.Internal.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.Internal.Types.TrName -T18982.$tcExGADT1 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tcExGADT = GHC.Internal.Types.TyCon 6470898418160489500#Word64 10361108917441214060#Word64 T18982.$trModule T18982.$tcExGADT1 0# GHC.Internal.Types.krep$*Arr* +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.Internal.Types.KindRep -$krep10 = GHC.Internal.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.Internal.Types.KindRep -$krep11 = GHC.Internal.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.Internal.Types.KindRep -T18982.$tc'ExGADT1 = GHC.Internal.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.Internal.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.Internal.Types.TrName -T18982.$tc'ExGADT2 = GHC.Internal.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.Internal.Types.TyCon -T18982.$tc'ExGADT = GHC.Internal.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1 +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.Internal.Prim.~# Int) => e -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -T18982.$wi = \ (@a) (@e) (ww :: a GHC.Internal.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Internal.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Internal.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.Internal.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Internal.Prim.~# Int) ww2 ww4 of ww5 { __DEFAULT -> GHC.Internal.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.Internal.Prim.~# Int) => GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# ===================================== testsuite/tests/simplCore/should_compile/T26615.stderr ===================================== @@ -2,7 +2,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 1,209, types: 1,155, coercions: 18, joins: 17/29} + = {terms: 1,229, types: 1,163, coercions: 18, joins: 17/29} -- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0} unArray :: forall a. Array a -> SmallArray# a @@ -414,7 +414,7 @@ T26615a.$tc'BitmapIndexed 2# $krep24 --- RHS size: {terms: 98, types: 109, coercions: 0, joins: 3/4} +-- RHS size: {terms: 101, types: 113, coercions: 0, joins: 3/4} T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]] :: forall k a b. Eq k => @@ -561,13 +561,14 @@ T26615a.$wdisjointCollisions joinrec { $wlookupInArrayCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: k -> SmallArray# (Leaf k b) -> Int# -> Int# -> Bool - [LclId[JoinId(4)(Just [!])], - Arity=4, - Str=<1L><L><L><L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => k -> SmallArray# (Leaf k b) -> Int# -> Int# -> Bool + [LclId[JoinId(5)(Just [~, !])], + Arity=5, + Str=<A><1L><L><L><L>, Unf=OtherCon []] - $wlookupInArrayCont_ (k1 :: k) + $wlookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k) + (k1 :: k) (ww3 :: SmallArray# (Leaf k b)) (ww4 :: Int#) (ww5 :: Int#) @@ -578,7 +579,7 @@ T26615a.$wdisjointCollisions { (# ipv2 #) -> case ipv2 of { L kx v -> case == @k $dEq k2 kx of { - False -> jump $wlookupInArrayCont_ k2 ww3 (+# ww4 1#) ww5; + False -> jump $wlookupInArrayCont_ $dEq k2 ww3 (+# ww4 1#) ww5; True -> GHC.Internal.Types.False } } @@ -586,7 +587,7 @@ T26615a.$wdisjointCollisions 1# -> jump $j } }; } in - jump $wlookupInArrayCont_ kA ww2 0# lvl2 + jump $wlookupInArrayCont_ $dEq kA ww2 0# lvl2 } }; 1# -> sc3 @@ -611,7 +612,7 @@ lvl1 = GHC.Internal.Control.Exception.Base.patError @LiftedRep @() lvl Rec { --- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2} +-- RHS size: {terms: 136, types: 130, coercions: 0, joins: 1/2} T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker] :: forall k a b. @@ -641,13 +642,14 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees joinrec { $wlookupInArrayCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: k -> SmallArray# (Leaf k a) -> Int# -> Int# -> Bool - [LclId[JoinId(4)(Just [!])], - Arity=4, - Str=<1L><L><L><L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => k -> SmallArray# (Leaf k a) -> Int# -> Int# -> Bool + [LclId[JoinId(5)(Just [~, !])], + Arity=5, + Str=<A><1L><L><L><L>, Unf=OtherCon []] - $wlookupInArrayCont_ (k1 :: k) + $wlookupInArrayCont_ ($dEq [Occ=Dead] :: Eq k) + (k1 :: k) (ww :: SmallArray# (Leaf k a)) (ww1 :: Int#) (ww2 :: Int#) @@ -657,7 +659,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees case indexSmallArray# @Lifted @(Leaf k a) ww ww1 of { (# ipv #) -> case ipv of { L kx v -> case == @k sc k2 kx of { - False -> jump $wlookupInArrayCont_ k2 ww (+# ww1 1#) ww2; + False -> jump $wlookupInArrayCont_ sc k2 ww (+# ww1 1#) ww2; True -> GHC.Internal.Types.False } } @@ -666,7 +668,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees } }; } in jump $wlookupInArrayCont_ - k0 sc3 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc3) + sc k0 sc3 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc3) } } }; @@ -708,7 +710,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees end Rec } Rec { --- RHS size: {terms: 705, types: 748, coercions: 18, joins: 13/23} +-- RHS size: {terms: 719, types: 748, coercions: 18, joins: 13/23} T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker] :: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool [GblId[StrictWorker([~, ~, !])], @@ -1065,23 +1067,23 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker] @(*) @(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case reallyUnsafePtrEquality# @Lifted @Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx1 `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: SmallArray# (HashMap k a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx3 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: SmallArray# (HashMap k b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> joinrec { @@ -1234,23 +1236,23 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker] case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof @(*) @(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case reallyUnsafePtrEquality# @Lifted @Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: SmallArray# (HashMap k a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx1 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: SmallArray# (HashMap k b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> jump go (GHC.Internal.Types.I# 31#); 1# -> GHC.Internal.Types.False @@ -1310,13 +1312,14 @@ T26615a.$wdisjointSubtrees joinrec { $wlookupInArrayCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: k -> SmallArray# (Leaf k a) -> Int# -> Int# -> Bool - [LclId[JoinId(4)(Just [!])], - Arity=4, - Str=<1L><L><L><L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => k -> SmallArray# (Leaf k a) -> Int# -> Int# -> Bool + [LclId[JoinId(5)(Just [~, !])], + Arity=5, + Str=<A><1L><L><L><L>, Unf=OtherCon []] - $wlookupInArrayCont_ (k1 :: k) + $wlookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k) + (k1 :: k) (ww2 :: SmallArray# (Leaf k a)) (ww3 :: Int#) (ww4 :: Int#) @@ -1327,7 +1330,8 @@ T26615a.$wdisjointSubtrees { (# ipv #) -> case ipv of { L kx v -> case == @k $dEq k2 kx of { - False -> jump $wlookupInArrayCont_ k2 ww2 (+# ww3 1#) ww4; + False -> + jump $wlookupInArrayCont_ $dEq k2 ww2 (+# ww3 1#) ww4; True -> GHC.Internal.Types.False } } @@ -1336,18 +1340,19 @@ T26615a.$wdisjointSubtrees } }; } in jump $wlookupInArrayCont_ - ds4 bx2 0# (sizeofSmallArray# @Lifted @(Leaf k a) bx2) + $dEq ds4 bx2 0# (sizeofSmallArray# @Lifted @(Leaf k a) bx2) } } in joinrec { $wlookupCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: Word# -> k -> Int# -> HashMap k a -> Bool - [LclId[JoinId(4)(Just [~, !, ~, !])], - Arity=4, - Str=<L><1L><L><1L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => Word# -> k -> Int# -> HashMap k a -> Bool + [LclId[JoinId(5)(Just [~, ~, !, ~, !])], + Arity=5, + Str=<A><L><1L><L><1L>, Unf=OtherCon []] - $wlookupCont_ (ww1 :: Word#) + $wlookupCont_ ($dEq1 [Occ=Dead] :: Eq k) + (ww1 :: Word#) (ds4 :: k) (ww2 :: Int#) (ds5 :: HashMap k a) @@ -1371,7 +1376,7 @@ T26615a.$wdisjointSubtrees (word2Int# (popCnt# (and# bx1 (minusWord# m 1##)))) of { (# ipv #) -> - jump $wlookupCont_ ww1 ds6 (+# ww2 5#) ipv + jump $wlookupCont_ $dEq ww1 ds6 (+# ww2 5#) ipv }; 0## -> GHC.Internal.Types.True }; @@ -1383,11 +1388,11 @@ T26615a.$wdisjointSubtrees (word2Int# (and# (uncheckedShiftRL# ww1 ww2) 31##)) of { (# ipv #) -> - jump $wlookupCont_ ww1 ds6 (+# ww2 5#) ipv + jump $wlookupCont_ $dEq ww1 ds6 (+# ww2 5#) ipv } } }; } in - jump $wlookupCont_ bx k0 ww ds + jump $wlookupCont_ $dEq bx k0 ww ds } }; Collision bx bx1 -> @@ -1435,13 +1440,14 @@ T26615a.$wdisjointSubtrees joinrec { $wlookupInArrayCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: k -> SmallArray# (Leaf k b) -> Int# -> Int# -> Bool - [LclId[JoinId(4)(Just [!])], - Arity=4, - Str=<1L><L><L><L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => k -> SmallArray# (Leaf k b) -> Int# -> Int# -> Bool + [LclId[JoinId(5)(Just [~, !])], + Arity=5, + Str=<A><1L><L><L><L>, Unf=OtherCon []] - $wlookupInArrayCont_ (k1 :: k) + $wlookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k) + (k1 :: k) (ww2 :: SmallArray# (Leaf k b)) (ww3 :: Int#) (ww4 :: Int#) @@ -1452,7 +1458,7 @@ T26615a.$wdisjointSubtrees { (# ipv #) -> case ipv of { L kx v -> case == @k $dEq k2 kx of { - False -> jump $wlookupInArrayCont_ k2 ww2 (+# ww3 1#) ww4; + False -> jump $wlookupInArrayCont_ $dEq k2 ww2 (+# ww3 1#) ww4; True -> GHC.Internal.Types.False } } @@ -1461,18 +1467,19 @@ T26615a.$wdisjointSubtrees } }; } in jump $wlookupInArrayCont_ - ds3 bx2 0# (sizeofSmallArray# @Lifted @(Leaf k b) bx2) + $dEq ds3 bx2 0# (sizeofSmallArray# @Lifted @(Leaf k b) bx2) } } in joinrec { $wlookupCont_ [InlPrag=[2], Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] - :: Word# -> k -> Int# -> HashMap k b -> Bool - [LclId[JoinId(4)(Just [~, !, ~, !])], - Arity=4, - Str=<L><1L><L><1L>, + Dmd=SC(S,C(1,C(1,C(1,C(1,L)))))] + :: Eq k => Word# -> k -> Int# -> HashMap k b -> Bool + [LclId[JoinId(5)(Just [~, ~, !, ~, !])], + Arity=5, + Str=<A><L><1L><L><1L>, Unf=OtherCon []] - $wlookupCont_ (ww1 :: Word#) + $wlookupCont_ ($dEq1 [Occ=Dead] :: Eq k) + (ww1 :: Word#) (ds3 :: k) (ww2 :: Int#) (ds4 :: HashMap k b) @@ -1496,7 +1503,7 @@ T26615a.$wdisjointSubtrees (word2Int# (popCnt# (and# bx1 (minusWord# m 1##)))) of { (# ipv #) -> - jump $wlookupCont_ ww1 ds5 (+# ww2 5#) ipv + jump $wlookupCont_ $dEq ww1 ds5 (+# ww2 5#) ipv }; 0## -> GHC.Internal.Types.True }; @@ -1508,11 +1515,11 @@ T26615a.$wdisjointSubtrees (word2Int# (and# (uncheckedShiftRL# ww1 ww2) 31##)) of { (# ipv #) -> - jump $wlookupCont_ ww1 ds5 (+# ww2 5#) ipv + jump $wlookupCont_ $dEq ww1 ds5 (+# ww2 5#) ipv } } }; } in - jump $wlookupCont_ bx k0 ww wild2 + jump $wlookupCont_ $dEq bx k0 ww wild2 }; Leaf bx1 ds3 -> case ds3 of { L kB ds4 -> @@ -1570,23 +1577,23 @@ T26615a.$wdisjointSubtrees case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof @(*) @(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case reallyUnsafePtrEquality# @Lifted @Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx1 `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: SmallArray# (HashMap k a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx3 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: SmallArray# (HashMap k b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> let { @@ -1715,23 +1722,23 @@ T26615a.$wdisjointSubtrees case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof @(*) @(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case reallyUnsafePtrEquality# @Lifted @Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: SmallArray# (HashMap k a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx1 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: SmallArray# (HashMap k b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> let { @@ -1838,7 +1845,7 @@ disjointSubtrees ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 614, types: 682, coercions: 18, joins: 8/14} + = {terms: 622, types: 674, coercions: 18, joins: 8/14} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule1 :: GHC.Internal.Prim.Addr# @@ -1878,20 +1885,22 @@ lvl1 @GHC.Internal.Types.LiftedRep @() lvl Rec { --- RHS size: {terms: 37, types: 30, coercions: 0, joins: 0/0} +-- RHS size: {terms: 39, types: 32, coercions: 0, joins: 0/0} $wpoly_lookupInArrayCont_ :: forall a. + Eq String => String -> GHC.Internal.Prim.SmallArray# (T26615a.Leaf String a) -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> Bool -[GblId[StrictWorker([!])], - Arity=4, - Str=<1L><L><L><L>, +[GblId[StrictWorker([~, !])], + Arity=5, + Str=<A><1L><L><L><L>, Unf=OtherCon []] $wpoly_lookupInArrayCont_ = \ (@a) + ($dEq2 [Occ=Dead] :: Eq String) (k1 :: String) (ww :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf String a)) (ww1 :: GHC.Internal.Prim.Int#) @@ -1907,7 +1916,12 @@ $wpoly_lookupInArrayCont_ case GHC.Internal.Base.eqString k2 kx of { False -> $wpoly_lookupInArrayCont_ - @a k2 ww (GHC.Internal.Prim.+# ww1 1#) ww2; + @a + GHC.Internal.Classes.$fEqList_$s$fEqList1 + k2 + ww + (GHC.Internal.Prim.+# ww1 1#) + ww2; True -> GHC.Internal.Types.False } } @@ -1918,17 +1932,19 @@ $wpoly_lookupInArrayCont_ end Rec } Rec { --- RHS size: {terms: 98, types: 73, coercions: 0, joins: 0/1} +-- RHS size: {terms: 102, types: 75, coercions: 0, joins: 0/1} $wpoly_lookupCont_ :: forall a. + Eq String => GHC.Internal.Prim.Word# -> String -> GHC.Internal.Prim.Int# -> HashMap String a -> Bool -[GblId[StrictWorker([~, !, ~, !])], - Arity=4, - Str=<L><1L><L><1L>, +[GblId[StrictWorker([~, ~, !, ~, !])], + Arity=5, + Str=<A><L><1L><L><1L>, Unf=OtherCon []] $wpoly_lookupCont_ = \ (@a) + ($dEq1 [Occ=Dead] :: Eq String) (ww :: GHC.Internal.Prim.Word#) (ds5 :: String) (ww1 :: GHC.Internal.Prim.Int#) @@ -1953,6 +1969,7 @@ $wpoly_lookupCont_ 1# -> $wpoly_lookupInArrayCont_ @a + GHC.Internal.Classes.$fEqList_$s$fEqList1 ds9 bx2 0# @@ -1979,7 +1996,13 @@ $wpoly_lookupCont_ (GHC.Internal.Prim.and# bx1 (GHC.Internal.Prim.minusWord# m 1##)))) of { (# ipv2 #) -> - $wpoly_lookupCont_ @a ww ds9 (GHC.Internal.Prim.+# ww1 5#) ipv2 + $wpoly_lookupCont_ + @a + GHC.Internal.Classes.$fEqList_$s$fEqList1 + ww + ds9 + (GHC.Internal.Prim.+# ww1 5#) + ipv2 }; 0## -> GHC.Internal.Types.True }; @@ -1993,14 +2016,20 @@ $wpoly_lookupCont_ (GHC.Internal.Prim.uncheckedShiftRL# ww ww1) 31##)) of { (# ipv2 #) -> - $wpoly_lookupCont_ @a ww ds9 (GHC.Internal.Prim.+# ww1 5#) ipv2 + $wpoly_lookupCont_ + @a + GHC.Internal.Classes.$fEqList_$s$fEqList1 + ww + ds9 + (GHC.Internal.Prim.+# ww1 5#) + ipv2 } } } end Rec } Rec { --- RHS size: {terms: 448, types: 523, coercions: 18, joins: 8/13} +-- RHS size: {terms: 450, types: 507, coercions: 18, joins: 8/13} T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker] :: forall a b. GHC.Internal.Prim.Int# @@ -2021,7 +2050,8 @@ T26615.$s$wdisjointSubtrees T26615a.Empty -> GHC.Internal.Types.True; T26615a.Leaf bx ds2 -> case ds2 of { T26615a.L kB ds3 -> - $wpoly_lookupCont_ @a bx kB ww ds + $wpoly_lookupCont_ + @a GHC.Internal.Classes.$fEqList_$s$fEqList1 bx kB ww ds }; T26615a.Collision bx bx1 -> T26615.$s$wdisjointSubtrees @b @a ww wild ds @@ -2031,7 +2061,9 @@ T26615.$s$wdisjointSubtrees T26615a.Leaf bx ds1 -> case ds1 of { T26615a.L kA ds2 -> case _b of wild2 { - __DEFAULT -> $wpoly_lookupCont_ @b bx kA ww wild2; + __DEFAULT -> + $wpoly_lookupCont_ + @b GHC.Internal.Classes.$fEqList_$s$fEqList1 bx kA ww wild2; T26615a.Leaf bx1 ds3 -> case ds3 of { T26615a.L kB ds4 -> case GHC.Internal.Prim.neWord# bx bx1 of { @@ -2085,9 +2117,9 @@ T26615.$s$wdisjointSubtrees [LclId[JoinId(0)(Nothing)]] $j = jump $s$wfoldr_ sc sc1 (GHC.Internal.Prim.+# sc2 1#) sc3 } in joinrec { - $wlookupInArrayCont_ [InlPrag=[2], - Occ=LoopBreaker, - Dmd=SC(S,C(1,C(1,C(1,L))))] + $w$slookupInArrayCont_ [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SC(S,C(1,C(1,C(1,L))))] :: String -> GHC.Internal.Prim.SmallArray# (T26615a.Leaf String b) -> GHC.Internal.Prim.Int# @@ -2097,12 +2129,12 @@ T26615.$s$wdisjointSubtrees Arity=4, Str=<1L><L><L><L>, Unf=OtherCon []] - $wlookupInArrayCont_ (k1 :: String) - (ww1 - :: GHC.Internal.Prim.SmallArray# - (T26615a.Leaf String b)) - (ww2 :: GHC.Internal.Prim.Int#) - (ww3 :: GHC.Internal.Prim.Int#) + $w$slookupInArrayCont_ (k1 :: String) + (ww1 + :: GHC.Internal.Prim.SmallArray# + (T26615a.Leaf String b)) + (ww2 :: GHC.Internal.Prim.Int#) + (ww3 :: GHC.Internal.Prim.Int#) = case k1 of k2 { __DEFAULT -> case GHC.Internal.Prim.>=# ww2 ww3 of { __DEFAULT -> @@ -2116,7 +2148,7 @@ T26615.$s$wdisjointSubtrees case ipv5 of { T26615a.L kx v -> case GHC.Internal.Base.eqString k2 kx of { False -> - jump $wlookupInArrayCont_ + jump $w$slookupInArrayCont_ k2 ww1 (GHC.Internal.Prim.+# ww2 1#) ww3; True -> GHC.Internal.Types.False } @@ -2125,7 +2157,7 @@ T26615.$s$wdisjointSubtrees 1# -> jump $j } }; } in - jump $wlookupInArrayCont_ kA bx3 0# lvl2 + jump $w$slookupInArrayCont_ kA bx3 0# lvl2 } }; 1# -> sc3 @@ -2187,23 +2219,23 @@ T26615.$s$wdisjointSubtrees @(GHC.Internal.Prim.SmallArray# (HashMap String a) -> GHC.Internal.Prim.SmallArray# (HashMap String b) -> GHC.Internal.Prim.Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> GHC.Internal.Prim.Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case GHC.Internal.Prim.reallyUnsafePtrEquality# @GHC.Internal.Types.Lifted @GHC.Internal.Types.Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx1 `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: GHC.Internal.Prim.SmallArray# (HashMap String a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx3 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: GHC.Internal.Prim.SmallArray# (HashMap String b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> joinrec { @@ -2365,23 +2397,23 @@ T26615.$s$wdisjointSubtrees @(GHC.Internal.Prim.SmallArray# (HashMap String a) -> GHC.Internal.Prim.SmallArray# (HashMap String b) -> GHC.Internal.Prim.Int#) - @(GHC.Internal.Types.UnusedType 0 "a" - -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#) + @(GHC.Internal.Types.UnusedType "a_0" + -> GHC.Internal.Types.UnusedType "b_1" -> GHC.Internal.Prim.Int#) of { GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 -> case GHC.Internal.Prim.reallyUnsafePtrEquality# @GHC.Internal.Types.Lifted @GHC.Internal.Types.Lifted - @(GHC.Internal.Types.UnusedType 0 "a") - @(GHC.Internal.Types.UnusedType 1 "b") + @(GHC.Internal.Types.UnusedType "a_0") + @(GHC.Internal.Types.UnusedType "b_1") (bx `cast` (SelCo:Fun(arg) (Sub (Sym v2)) :: GHC.Internal.Prim.SmallArray# (HashMap String a) - ~R# GHC.Internal.Types.UnusedType 0 "a")) + ~R# GHC.Internal.Types.UnusedType "a_0")) (bx1 `cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2))) :: GHC.Internal.Prim.SmallArray# (HashMap String b) - ~R# GHC.Internal.Types.UnusedType 1 "b")) + ~R# GHC.Internal.Types.UnusedType "b_1")) of { __DEFAULT -> joinrec { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d938a44dbd69b6e04411539d51a64e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d938a44dbd69b6e04411539d51a64e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/cpr-docs
by Simon Jakobi (＠sjakobi2) 03 Jul '26

03 Jul '26

Simon Jakobi pushed new branch wip/sjakobi/cpr-docs at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/cpr-docs You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T27466] Honour -dsuppress-coercions in GHC.Core.TyCo.pprCo
by Simon Peyton Jones (＠simonpj) 03 Jul '26

03 Jul '26

Simon Peyton Jones pushed to branch wip/T27466 at Glasgow Haskell Compiler / GHC Commits: 397b8c44 by Simon Peyton Jones at 2026-07-03T03:31:35+01:00 Honour -dsuppress-coercions in GHC.Core.TyCo.pprCo Fixes #27467 - - - - - 1 changed file: - compiler/GHC/Core/Ppr.hs Changes: ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -292,14 +292,14 @@ noParens :: SDoc -> SDoc noParens pp = pp pprOptCo :: Coercion -> SDoc --- Print a coercion with its type +-- Print a coercion with its type (unless suppressed by -dsuppress-coercion-types) -- Honour -dsuppress-coercions -- Placed here because it needs GHC.Core.Coercion.coercionType -pprOptCo co = sep [pprCo co, dcolon <+> co_type] - where - co_type = sdocOption sdocSuppressCoercionTypes $ \case - True -> ellipsis - False -> ppr (coercionType co) +pprOptCo co = sdocOption sdocSuppressCoercionTypes $ \case + True -> pprParendCo co + False -> parens (sep [pprCo co, dcolon <+> pp_co_type]) + where + pp_co_type = ppr (coercionType co) ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc ppr_id_occ add_par id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/397b8c44db6f1e59dfb54e8cf6c2dde… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/397b8c44db6f1e59dfb54e8cf6c2dde… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Test driver: normalise line numbers into libraries
by Marge Bot (＠marge-bot) 03 Jul '26

03 Jul '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00 Test driver: normalise line numbers into libraries When comparing the stdout of tests that print out callstacks, we can't rely on the stability of exact line:column spans pointing into libraries (e.g. ghc-internal), as any change (such as adding a comment) can change them. This commit addresses this by normalising away line:column in callstacks, but only when those point into internal libraries. We don't do this in general, as the exact span might be important to the test (e.g. for a span within the test module itself). Fixes #27387 - - - - - 81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00 EPA: Remove LocatedLW from MatchGroup This is the last usage of LocatedLW / SrcSpanAnnLW - - - - - e83bfacf by Recursion Ninja at 2026-07-02T22:11:03-04:00 Decoupling 'L.H.S' from 'GHC.Hs.Doc' * Migrated 'GHC.Hs.Doc' and 'GHC.Hs.DocString' AST defintions from 'GHC.*' namespace, to new 'Language.Haskell.Syntax.Doc' module in the 'L.H.S' "namespace." * Updated 'HsDocString to be TTG-parameterised as 'HsDocString pass'. * Added 'GHC.Hs.Extension.Pass': splits 'GhcPass'/'Pass' and all 'HsDocString' TTG instances out of 'GHC.Hs.Extension', which re-exports it unchanged (this is backwards compatible and prevents the introduction of a boot file). * Deleted 'GHC.Hs.Doc.hs-boot'; removed all 'L.H.S.*' imports of 'GHC.Hs.Doc'. * Updated 'GHC.Hs.DocString' to be TTG pass-parameterised throughout; moved 'mkHsDocStringChunk'/'unpackHDSC' here (require 'GHC.Utils.Encoding'). * Split 'GHC.Rename.Doc.rnHsDoc' from 'rnHsDocIdentifiersOnly'. * Updated parser, renamer, typechecker, HIE, and exact-print for new types. * Added 'HsDocString' TTG instances for 'DocNameI' to 'Haddock.Types'. * Killed the last module loop between GHC.* and LHS.*. - Only edges from LHS.* to GHC.Data.FastString now! Resolves #26971 - - - - - bfbc9047 by mangoiv at 2026-07-02T22:11:04-04:00 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable - - - - - adc9fa86 by sheaf at 2026-07-02T22:11:05-04:00 Remove outdated comment in GHC.Data.ShortText There was a long comment in GHC.Data.ShortText about a workaround that was necessary when bootstrapping with GHC 9.2 and below. The actual logic has since been dropped, but the comment remained. This commit removes the vestigial comment. - - - - - 78 changed files: - .gitlab/test-metrics.sh - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - + compiler/GHC/Hs/Extension/Pass.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Doc.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Expr.hs-boot - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Type.hs - − compiler/Language/Haskell/Syntax/Type.hs-boot - compiler/ghc.cabal.in - libraries/ghc-boot/GHC/Data/ShortText.hs - testsuite/driver/testlib.py - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.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/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c602ab21dc730858eeb4b2ca6224b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c602ab21dc730858eeb4b2ca6224b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] EPA: Remove LocatedLW from MatchGroup
by Marge Bot (＠marge-bot) 03 Jul '26

03 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00 EPA: Remove LocatedLW from MatchGroup This is the last usage of LocatedLW / SrcSpanAnnLW - - - - - 32 changed files: - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/ThToHs.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.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/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81ee62e0b6bd8eda137d197ced3716b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/81ee62e0b6bd8eda137d197ced3716b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Test driver: normalise line numbers into libraries
by Marge Bot (＠marge-bot) 03 Jul '26

03 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00 Test driver: normalise line numbers into libraries When comparing the stdout of tests that print out callstacks, we can't rely on the stability of exact line:column spans pointing into libraries (e.g. ghc-internal), as any change (such as adding a comment) can change them. This commit addresses this by normalising away line:column in callstacks, but only when those point into internal libraries. We don't do this in general, as the exact span might be important to the test (e.g. for a span within the test module itself). Fixes #27387 - - - - - 1 changed file: - testsuite/driver/testlib.py Changes: ===================================== testsuite/driver/testlib.py ===================================== @@ -2944,6 +2944,12 @@ def normalise_whitespace(s: str) -> str: callSite_re = re.compile(r', called at (.+):[\d]+:[\d]+ in [<>\w\-\.]+:') +# A line:column location pointing inside 'libraries' (e.g. ghc-internal). +inLibrariesLoc_re = re.compile( + r'(libraries[\\/]\S+?)' + r':(?:\d+:\d+(?:-\d+)?|$\d+,\d+$-$\d+,\d+$)' # line:col span +) + def normalise_callstacks(s: str) -> str: opts = getTestOpts() def repl(matches): @@ -2952,6 +2958,12 @@ def normalise_callstacks(s: str) -> str: return ', called at {0}:<line>:<column> in <package-id>:'.format(location) # Ignore line number differences in call stacks (#10834). s = re.sub(callSite_re, repl, s) + # Ignore differences in line numbers pointing into internal libraries, + # as those line numbers are not stable (e.g. adding a comment somewhere + # in ghc-internal) (#27387). + s = re.sub(inLibrariesLoc_re, + lambda m: '{0}:<line>:<column>'.format(normalise_slashes_(m.group(1))), + s) # Ignore the change in how we identify implicit call-stacks s = s.replace('from ImplicitParams', 'from HasCallStack') if not opts.keep_prof_callstacks: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6d53c1681d4afe7f6c637c3a34798f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c6d53c1681d4afe7f6c637c3a34798f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 5 commits: Adjust releaseCapability_ precondition to allow cap->running_task == NULL
by Marge Bot (＠marge-bot) 03 Jul '26

03 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6e381626 by Duncan Coutts at 2026-07-01T22:29:55+01:00 Adjust releaseCapability_ precondition to allow cap->running_task == NULL There are two use cases for releaseCapability_: 1. The current Task (cap->running_task) releases the Capability. The Capability is marked free, and if there is any work to do, an appropriate Task is woken up. 2. There is no current task (cap->task == NULL), and thus the Capability is idle, and we want to wake up an idle Task to animate the Capability. This case uses always_wakeup. Currently, the precondition for releaseCapability_ is cap->running_task != NULL and so the 2nd use cases have to set cap->running_task (which is then immediately overwritten) just to satisfy the precondition. See the use cases in sendMessage and prodCapability. So we can relax the precondition to be: cap->running_task != NULL || always_wakeup so that in the always_wakeup case, we say it is ok for the cap->running_task to be NULL. This lets us simplify sendMessage and prodCapability. In particular it will allow prodCapability to not need a Task parameter. The ulterior motive for all this is that I want to be able to call prodCapability from an OS thread that is not itself a Task, in persuit of issue #27086: disentangle I/O managers from wakeUpRts. The most straightforward way to wake the RTS is using prodCapability, but the context in which we will need to do that are threads that are not Tasks. - - - - - 89404ebc by Duncan Coutts at 2026-07-01T22:29:55+01:00 prodCapability no longer needs to take a Task param Now that releaseCapability_ can accept cap->running_task == NULL then it is no longer necessary for prodCapability to require a Task. - - - - - 4e60c5f6 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Define prodOneCapability There was an existing declaration for this in the header file, but no definition. Similarly, there is a declaration for prodAllCapabilities but no definition, and we don't need it, so remove the declaration. - - - - - 2527026f by Duncan Coutts at 2026-07-01T22:29:56+01:00 Add a wakeUpRtsViaTicker feature to the posix ticker It proxies a call to wakeUpRts, but crucially, this can be called from a signal handler context. It will be used for ctl-c handling. - - - - - aa5a03a5 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Change how wakeUpRts works Previously it would call wakeupIOManager to get a capability to wake up and run. This works but it entangles the I/O managers with unrelated features: ctl-c handling and idle gc (the two features that use wakeUpRts). The reason it used wakeupIOManager is that this action is safe to use from a posix signal handler, since it just posts bytes to a pipe. Otherwise the more direct approach (used e.g. by sendMessage when the target capability is idle) is to use releaseCapability. But that uses condition variables and mutexes, which are not safe to use from within a signal handler. So instead of entangling the (multiple) I/O managers with this, we make wakeUpRts use the direct approach (using prodOneCapability). On win32 the ctl-c console handler can call wakeUpRts directly, since it is called in a proper thread. On posix, to deal with the signal handler problem, we make the signal handler ask the ticker thread to proxy the call to wakeUpRts, since the ticker thread is also a proper thread. This will allow the I/O managers to no longer be concerned with this. This is good because there are many I/O managers (and they're complicated), but there is (on posix) only one ticker implementation. So this is an overall reduction in coupling and complexity. Fixes issue #27086 - - - - - 7 changed files: - rts/Capability.c - rts/Capability.h - rts/Messages.c - rts/Schedule.c - rts/Ticker.h - rts/posix/Ticker.c - rts/sm/GC.c Changes: ===================================== rts/Capability.c ===================================== @@ -525,13 +525,20 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task) /* ---------------------------------------------------------------------------- * releaseCapability * - * The current Task (cap->task) releases the Capability. The Capability is - * marked free, and if there is any work to do, an appropriate Task is woken up. + * This serves two purposes: + * + * 1. The current Task (cap->running_task) releases the Capability. + * The Capability is marked free, and if there is any work to do, an + * appropriate Task is woken up. + * + * 2. There is no current task (cap->task == NULL), and thus the Capability + * is idle, and we want to wake up an idle Task to animate the Capability. + * In this case set always_wakeup. See also prodCapability. * * The caller must hold cap->lock and will still hold it after * releaseCapability returns. * - * N.B. May need to take all_tasks_mutex. + * N.B. May need to take all_tasks_mutex, if it needs to start a new task. * * ------------------------------------------------------------------------- */ @@ -540,12 +547,18 @@ void releaseCapability_ (Capability* cap, bool always_wakeup) { - Task *task; - - task = cap->running_task; - - ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task); - ASSERT_RETURNING_TASKS(cap,task); + { + Task *task = cap->running_task; + + ASSERT(task || always_wakeup); + // To cover purpose 2 above, we allow the cap->running_task to be + // NULL, to handle cases where a thread (that is not itself a Task) + // needs to wake up an idle task for the capability. + if (task) { + ASSERT_PARTIAL_CAPABILITY_INVARIANTS(cap,task); + ASSERT_RETURNING_TASKS(cap,task); + } + } ASSERT_LOCK_HELD(&cap->lock); RELAXED_STORE(&cap->running_task, NULL); @@ -581,8 +594,8 @@ releaseCapability_ (Capability* cap, // assertion is false: in schedule() we force a yield after // ThreadBlocked, but the thread may be back on the run queue // by now. - task = peekRunQueue(cap)->bound->task; - giveCapabilityToTask(cap, task); + Task *btask = peekRunQueue(cap)->bound->task; + giveCapabilityToTask(cap, btask); return; } @@ -1087,16 +1100,25 @@ yieldCapability #if defined(THREADED_RTS) void -prodCapability (Capability *cap, Task *task) +prodCapability (Capability *cap) { ACQUIRE_LOCK(&cap->lock); if (!cap->running_task) { - cap->running_task = task; releaseCapability_(cap,true); } RELEASE_LOCK(&cap->lock); } +/* Ensure at least one capability is not idle. Used to wake up the RTS + * in cases where we anticipate that all capabilities may be idle. In + * particular it is used for the ctl-c handler, and after the idle GC + * timeout to initiate idle GC. */ +void +prodOneCapability (void) +{ + prodCapability(getCapability(0)); +} + #endif /* THREADED_RTS */ /* ---------------------------------------------------------------------------- ===================================== rts/Capability.h ===================================== @@ -348,11 +348,7 @@ bool yieldCapability (Capability** pCap, Task *task, bool gcAllowed); // need to service some global event. // void prodOneCapability (void); -void prodCapability (Capability *cap, Task *task); - -// Similar to prodOneCapability(), but prods all of them. -// -void prodAllCapabilities (void); +void prodCapability (Capability *cap); // Attempt to gain control of a Capability if it is free. // ===================================== rts/Messages.c ===================================== @@ -49,9 +49,11 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) recordClosureMutated(from_cap,(StgClosure*)msg); if (to_cap->running_task == NULL) { - to_cap->running_task = myTask(); - // precond for releaseCapability_() - releaseCapability_(to_cap,false); + /* Precond for releaseCapability_ is: running_task || always_wakeup. + * We have running_task == NULL, hence we must use always_wakeup. This + * is ok since the inbox is now non-empty, so we wake a task anyway. + */ + releaseCapability_(to_cap, true /*always_wakeup*/); } else { interruptCapability(to_cap); } ===================================== rts/Schedule.c ===================================== @@ -2885,8 +2885,8 @@ performBlockingMajorGC(void) } /* --------------------------------------------------------------------------- - Interrupt execution. - Might be called inside a signal handler so it mustn't do anything fancy. + Interrupt execution in response to ctl-c. + On posix, ctl-c is a signal, while on Win32 it is a console event. ------------------------------------------------------------------------ */ void @@ -2896,17 +2896,37 @@ interruptStgRts(void) setSchedState(SCHED_INTERRUPTING); interruptAllCapabilities(); #if defined(THREADED_RTS) + /* It may be that all capabilities are idle. If so, we must wake one up. */ +#if defined(mingw32_HOST_OS) + /* On win32, console handlers are invoked in a proper thread, so we can + * directly call wakeUpRts. Although it is an OS thread, it is not one + * we created or control necessarily, so it may have no associated Task. + */ wakeUpRts(); +#else + /* On posix on the other hand, signal handlers are very limited in what + * they can do. We cannot directly call wakeUpRts below because it is not + * signal safe (it uses cond vars to wake up a task). So instead we proxy + * it: we interrupt the ticker thread and ask the ticker thread to call + * wakeUpRts below. The ticker thread is a proper thread and so can call + * wakeUpRts. We can interrupt the ticker thread from signal handler + * context safely because it only involves writing to a pipe/eventfd. + */ + wakeUpRtsViaTicker(); +#endif #endif } /* ----------------------------------------------------------------------------- Wake up the RTS - This function causes at least one OS thread to wake up and run the - scheduler loop. It is invoked when the RTS might be deadlocked, or - an external event has arrived that may need servicing (eg. a - keyboard interrupt). + This function causes at least one task to wake up and run the scheduler + loop on at least one capability. + + It is invoked: + 1. as part of the idle GC scheme: when the RTS has been idle for long enough + and it is time to go back to the scheduler which will invoke idle GC; or + 2. when a ctl-c occurs (posix sigint signal or win32 console event) In the single-threaded RTS we don't do anything here; we only have one thread anyway, and the event that caused us to want to wake up @@ -2916,10 +2936,11 @@ interruptStgRts(void) #if defined(THREADED_RTS) void wakeUpRts(void) { - // This forces the IO Manager thread to wakeup, which will - // in turn ensure that some OS thread wakes up and runs the - // scheduler loop, which will cause a GC and deadlock check. - wakeupIOManager(); + /* Our current thread may not have a Task, in particular it will not when + * called from interruptStgRts or via wakeUpRtsViaTicker. This is ok, + * prodOneCapability does not require one. + */ + prodOneCapability(); } #endif ===================================== rts/Ticker.h ===================================== @@ -52,4 +52,8 @@ void exitTicker(void); void pauseTicker(void); void unpauseTicker(void); +#if defined(THREADED_RTS) +void wakeUpRtsViaTicker(void); +#endif + #include "EndPrivate.h" ===================================== rts/posix/Ticker.c ===================================== @@ -127,6 +127,13 @@ static Time ticker_interval = DEFAULT_TICK_INTERVAL; // acknowledgement. static bool pause_request; +#if defined(THREADED_RTS) +// Atomic variable used by the ctl-c handler (posix signal handler) to +// communicate that the ticker thread should wake up the rts. This +// communication is one-way, with no acknowledgement. +static bool interrupt_request; +#endif + // Atomic variable used by other threads to communicate that they want the // ticker thread to exit. static bool exit_request; @@ -177,6 +184,13 @@ static void *ticker_thread_func(void *_handle_tick) paused = ACQUIRE_LOAD_ALWAYS(&pause_request); exit = RELAXED_LOAD_ALWAYS(&exit_request); + +#if defined(THREADED_RTS) + if (RELAXED_LOAD_ALWAYS(&interrupt_request)) { + RELEASE_STORE_ALWAYS(&interrupt_request, false); + wakeUpRts(); + } +#endif } else if (errno != EINTR) { // While the RTS attempts to mask signals, some foreign libraries // that rely on signal delivery may unmask them. Consequently we @@ -262,6 +276,14 @@ void pauseTicker(void) sendFdWakeup(notifyfd_w); } +#if defined(THREADED_RTS) +void wakeUpRtsViaTicker(void) +{ + RELAXED_STORE_ALWAYS(&interrupt_request, true); + sendFdWakeup(notifyfd_w); +} +#endif + /* Synchronous. Not idempotent. * The ticker is guaranteed stopped after this. */ ===================================== rts/sm/GC.c ===================================== @@ -1522,7 +1522,7 @@ waitForGcThreads (Capability *cap, bool idle_cap[]) for(i = 0; i < getNumCapabilities(); ++i) { if (i == me || idle_cap[i]) { continue; } if (SEQ_CST_LOAD(&gc_threads[i]->wakeup) != GC_THREAD_STANDING_BY) { - prodCapability(getCapability(i), cap->running_task); + prodCapability(getCapability(i)); interruptCapability(getCapability(i)); } } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8585f8cb561e0ac1a995e1fd45ee52… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8585f8cb561e0ac1a995e1fd45ee52… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 2 commits: EPA: Remove LocatedP from CType
by Alan Zimmerman (＠alanz) 02 Jul '26

02 Jul '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 19cc63f2 by Alan Zimmerman at 2026-07-02T23:31:09+01:00 EPA: Remove LocatedP from CType - - - - - af438e12 by Alan Zimmerman at 2026-07-02T23:31:09+01:00 EPA: Remove LocatedP, last use in WarningTxt - - - - - 12 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Unit/Module/Warnings.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -299,7 +299,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1162,7 +1162,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr }) @@ -1360,7 +1360,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) @@ -1701,7 +1701,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -404,9 +403,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -664,8 +664,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -23,12 +23,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs - ===================================== compiler/GHC/Parser.y ===================================== @@ -1705,15 +1705,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } @@ -2073,11 +2075,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (map stringLiteralToHsDocWst $ snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2106,7 +2110,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2134,7 +2138,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) } : STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -428,7 +428,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -439,7 +438,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . fsLit -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -356,6 +358,7 @@ instance Binary CTypeGhc where return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = noAnn } instance NFData StaticTargetGhc where ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -156,8 +156,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -165,7 +165,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Uniquable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1558,26 +1558,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where getAnnotationEntry _ = NoEntryVal @@ -4407,13 +4407,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4421,7 +4422,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -835,7 +835,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cedb075fcd3d01509d7c3eed20039b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cedb075fcd3d01509d7c3eed20039b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 3 commits: EPA: Remove LocatedP from OverlapMode
by Alan Zimmerman (＠alanz) 02 Jul '26

02 Jul '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 3555aee5 by Alan Zimmerman at 2026-07-02T23:04:24+01:00 EPA: Remove LocatedP from OverlapMode - - - - - b7559a99 by Alan Zimmerman at 2026-07-02T23:04:24+01:00 EPA: Remove LocatedP from CType - - - - - cedb075f by Alan Zimmerman at 2026-07-02T23:04:24+01:00 EPA: Remove LocatedP, last use in WarningTxt - - - - - 18 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Unit/Module/Warnings.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -299,7 +299,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1162,7 +1162,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr }) @@ -1272,20 +1272,25 @@ ppDerivStrategy mb = Nothing -> empty Just (L _ ds) -> ppr ds -ppOverlapPragma :: Maybe (LocatedP (OverlapMode (GhcPass p))) -> SDoc +ppOverlapPragma :: forall p. IsPass p => Maybe (LocatedA (OverlapMode (GhcPass p))) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" - Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" - Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" - Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" - Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" - Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet + Just (L _ (NoOverlap s)) -> maybe_stext (stext s) "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext (stext s) "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext (stext s) "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext (stext s) "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" + Just (L _ (NonCanonical s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet where maybe_stext NoSourceText alt = text alt maybe_stext (SourceText src) _ = ftext src <+> text "#-}" + stext :: XOverlapMode (GhcPass p) -> SourceText + stext s = case (ghcPass @p, s) of + (GhcPs, (s,_)) -> s + (GhcRn, (s,_)) -> s + (GhcTc, s) -> s instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where ppr (ClsInstD { cid_inst = decl }) = ppr decl @@ -1355,7 +1360,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) @@ -1696,7 +1701,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA @@ -1711,7 +1716,7 @@ type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnP +type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -31,6 +31,8 @@ import GHC.Prelude import GHC.Hs.Extension +import GHC.Parser.Annotation ( AnnPragma ) + import Language.Haskell.Syntax.Decls.Overlap import Language.Haskell.Syntax.Extension @@ -70,11 +72,13 @@ instance NFData OverlapFlag where instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) -type instance XOverlapMode (GhcPass _) = SourceText +type instance XOverlapMode GhcPs = (SourceText, AnnPragma) +type instance XOverlapMode GhcRn = (SourceText, AnnPragma) +type instance XOverlapMode GhcTc = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen -instance NFData (OverlapMode (GhcPass p)) where +instance NFData (OverlapMode GhcTc) where rnf = \case NoOverlap s -> rnf s Overlappable s -> rnf s @@ -83,7 +87,7 @@ instance NFData (OverlapMode (GhcPass p)) where Incoherent s -> rnf s NonCanonical s -> rnf s -instance Binary (OverlapMode (GhcPass p)) where +instance Binary (OverlapMode GhcTc) where put_ bh = \case NoOverlap s -> putByte bh 0 >> put_ bh s Overlaps s -> putByte bh 1 >> put_ bh s ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -404,9 +403,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1750,7 +1750,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where NewtypeStrategy _ -> [] ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ] -instance ToHie (LocatedP (OverlapMode GhcRn)) where +instance ToHie (LocatedA (OverlapMode GhcRn)) where toHie (L span _) = locOnly (locA span) instance ToHie (LocatedA (ConDecl GhcRn)) where ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -664,8 +664,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -23,12 +23,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs - ===================================== compiler/GHC/Parser.y ===================================== @@ -1469,15 +1469,15 @@ inst_decl :: { LInstDecl GhcPs } (fmap reverse $7) (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}} -overlap_pragma :: { Maybe (LocatedP (OverlapMode GhcPs)) } - : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } +overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) } + : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } @@ -1705,15 +1705,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } @@ -2073,11 +2075,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (map stringLiteralToHsDocWst $ snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2106,7 +2110,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2134,7 +2138,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) } : STRING { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -428,7 +428,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -439,7 +438,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handles @deriving@ clauses on @data@ declarations. -module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..), tcOverlapMode ) where import GHC.Prelude @@ -776,12 +776,12 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo tcOverlapMode :: OverlapMode GhcRn -> OverlapMode GhcTc tcOverlapMode = \case - NoOverlap s -> NoOverlap s - Overlappable s -> Overlappable s - Overlapping s -> Overlapping s - Overlaps s -> Overlaps s - Incoherent s -> Incoherent s - NonCanonical s -> NonCanonical s + NoOverlap s -> NoOverlap (fst s) + Overlappable s -> Overlappable (fst s) + Overlapping s -> Overlapping (fst s) + Overlaps s -> Overlaps (fst s) + Incoherent s -> Incoherent (fst s) + NonCanonical s -> NonCanonical (fst s) -- Typecheck the type in a standalone deriving declaration. -- ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -559,7 +559,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn -- Dfun location is that of instance *header* ; let warn = fmap unLoc lwarn - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + ; ispec <- newClsInst (fmap (tcOverlapMode . unLoc) overlap_mode) dfun_name tyvars theta clas inst_tys warn ; let inst_binds = InstBindings ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -905,7 +905,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity ************************************************************************ -} -getOverlapFlag :: Maybe (OverlapMode (GhcPass p)) -- User pragma if any +getOverlapFlag :: Maybe (OverlapMode GhcTc) -- User pragma if any -> TcM OverlapFlag -- Construct the OverlapFlag from the global module flags, -- but if the overlap_mode argument is (Just m), @@ -929,9 +929,9 @@ getOverlapFlag overlap_mode_prag overlap_mode | Just m <- overlap_mode_prag = m - | incoherent_ok = Incoherent NoSourceText - | overlap_ok = Overlaps NoSourceText - | otherwise = NoOverlap NoSourceText + | incoherent_ok = Incoherent noAnn + | overlap_ok = Overlaps noAnn + | otherwise = NoOverlap noAnn -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap @@ -957,7 +957,7 @@ tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv -newClsInst :: Maybe (OverlapMode (GhcPass p)) -- User pragma +newClsInst :: Maybe (OverlapMode GhcTc) -- User pragma -> Name -> [TyVar] -> ThetaType -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst newClsInst overlap_mode dfun_name tvs theta clas tys warn ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -337,7 +337,6 @@ cvtDec (ClassD ctxt cl tvs fds decs) } cvtDec (InstanceD o ctxt ty decs) - -- = do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs = do { decs' <- cvt_ci_decs InstanceDecl decs ; let (fams', decls') = partitionWith is_fam_decl decs' ; for_ (nonEmpty fams') $ \ bad_fams -> @@ -356,10 +355,10 @@ cvtDec (InstanceD o ctxt ty decs) where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT") + TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS", noAnn) + TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE", noAnn) + TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING", noAnn) + TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT", noAnn) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . fsLit -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -350,12 +352,15 @@ instance Binary CTypeGhc where put_ bh ct = do put_ bh (cTypeSourceText ct) put_ bh (cTypeOtherText ct) + put_ bh (cTypeAnn ct) get bh = do str1 <- get bh str2 <- get bh + ann <- get bh return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = ann } instance NFData StaticTargetGhc where ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -156,8 +156,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -165,7 +165,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Uniquable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1558,26 +1558,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where getAnnotationEntry _ = NoEntryVal @@ -2248,40 +2248,40 @@ instance ExactPrint (TyFamInstDecl GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (OverlapMode (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (OverlapMode GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a -- NOTE: NoOverlap is only used in the typechecker - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do + exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# NO_OVERLAP" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src)) + return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do + exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src)) + return (Overlappable (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do + exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPING" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src)) + return (Overlapping (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do + exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPS" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src)) + return (Overlaps (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do + exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do + exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) -- --------------------------------------------------------------------- @@ -4407,13 +4407,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4421,7 +4422,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -834,8 +834,8 @@ type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF -type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e35… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e35… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/udfm-placement] Use a placement sort for deterministic UniqDFM iteration
by Simon Jakobi (＠sjakobi2) 02 Jul '26

02 Jul '26

Simon Jakobi pushed to branch wip/sjakobi/udfm-placement at Glasgow Haskell Compiler / GHC Commits: 1c645b9c by Simon Jakobi at 2026-07-02T21:26:00+02:00 Use a placement sort for deterministic UniqDFM iteration eltsUDFM/udfmToList (and with them foldUDFM and UniqDFM's Foldable instance) ordered elements with a list mergesort, allocating ~n*log n cons cells per call. In the profile for the InstanceMatching1 perf test this pipeline accounted for a large share of total allocations (#27459). This commit instead uses a more efficient placement sort in most cases. See Note [Sorting a UDFM]. Also add Note [Cost of deterministic iteration], prompted by #27459. - - - - - 1 changed file: - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -14,6 +14,9 @@ See Note [Unique Determinism] in GHC.Types.Unique for explanation why @Unique@ o is not deterministic. -} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + {-# OPTIONS_GHC -Wall #-} module GHC.Types.Unique.DFM ( @@ -79,6 +82,9 @@ import Data.Functor.Classes (Eq1 (..)) import Data.List (sortBy) import Data.Function (on) import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) +import GHC.Data.SmallArray +import GHC.Exts (State#) +import GHC.ST (ST(..), runST) import Unsafe.Coerce import qualified GHC.Data.Word64Set as W @@ -92,9 +98,10 @@ import qualified GHC.Data.Word64Set as W -- order then `udfmToList` returns them in deterministic order. -- -- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts its result by this serial --- number. So you should only use `UniqDFM` if you need the deterministic --- property. +-- as it is added, and functions like `udfmToList` or `eltsUDFM` order their +-- results by this serial number (see +-- Note [Cost of deterministic iteration]). So you should only use `UniqDFM` +-- if you need the deterministic property. -- -- `foldUDFM` also preserves determinism. -- @@ -112,13 +119,19 @@ import qualified GHC.Data.Word64Set as W -- -- An alternative would be to have -- --- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- data UniqDFM ele = UDFM (Word64Map ele) [ele] -- -- where the list determines the order. This makes deletion tricky as we'd -- only accumulate elements in that list, but makes merging easier as you -- can just merge both structures independently. -- Deletion can probably be done in amortized fashion when the size of the -- list is twice the size of the set. +-- +-- A representation like +-- +-- data UniqDFM ele = UDFM (Word64Map ele) [Unique] +-- +-- may also be worth considering. Compare Dhall.Map in the dhall package. -- | A type of values tagged with insertion time data TaggedVal val = @@ -153,11 +166,15 @@ data UniqDFM key ele = -- time. See Note [Overflow on plusUDFM] deriving (Data, Functor) --- | Deterministic, in O(n log n). +-- | Deterministic. +-- +-- See Note [Cost of deterministic iteration]. instance Foldable (UniqDFM key) where foldr = foldUDFM --- | Deterministic, in O(n log n). +-- | Deterministic. +-- +-- See Note [Cost of deterministic iteration]. instance Traversable (UniqDFM key) where traverse f = fmap listToUDFM_Directly . traverse (\(u,a) -> (u,) <$> f a) @@ -310,13 +327,20 @@ elemUDFM :: Uniquable key => key -> UniqDFM key elt -> Bool elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m -- | Performs a deterministic fold over the UniqDFM. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +-- +-- O(n) in the common case, with an O(n log n) fallback. +-- +-- Don't use this to access the first element or to check for emptiness, +-- as this already incurs most of the cost of returning the full list. +-- See Note [Cost of deterministic iteration]. foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldUDFM #-} -- This INLINE prevents a regression in !10568 foldUDFM k z m = foldr k z (eltsUDFM m) --- | Like 'foldUDFM' but the function also receives a key +-- | Like 'foldUDFM' but the function also receives a key. +-- +-- See Note [Cost of deterministic iteration]. foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldWithKeyUDFM #-} -- This INLINE was copied from foldUDFM @@ -331,14 +355,88 @@ nonDetStrictFoldUDFM k z (UDFM m _i) = foldl' k' z m where k' acc (TaggedVal v _) = k v acc +-- Note [Cost of deterministic iteration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Deterministic iteration orders elements by insertion tag, and any such +-- ordering must inspect every element's tag before it can emit the first +-- element. So even the head of the result costs a full traversal of the map +-- plus -- on the main path -- the allocation of an O(n)-sized array (see +-- Note [Sorting a UDFM]). Laziness in the result list only avoids allocating +-- for elements that are never demanded; it does not make the iteration +-- incremental. #27459 shows this cost biting in consumers that demanded only +-- the head. +-- +-- So: to test for emptiness, use isNullUDFM rather than null on eltsUDFM; +-- for order-oblivious queries, prefer short-circuiting anyUDFM/allUDFM; and +-- if you don't need the deterministic order at all, use the nonDet functions. + +-- | Deterministic, in order of insertion. +-- +-- See Note [Sorting a UDFM] and Note [Cost of deterministic iteration]. eltsUDFM :: UniqDFM key elt -> [elt] -{-# INLINE eltsUDFM #-} --- The INLINE makes it a good producer (from the map) -eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) +eltsUDFM (UDFM m i) + | n <= 1 = map taggedFst (M.elems m) + | usePlacement n i = placementSort i (M.elems m) + | otherwise = map taggedFst (sort_it m) + where n = M.size m sort_it :: M.Word64Map (TaggedVal elt) -> [TaggedVal elt] sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) + +-- Note [Sorting a UDFM] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- Deterministic iteration must order elements by insertion tag. Instead of a +-- comparison sort -- the list mergesort behind sortBy allocates ~n*log n cons +-- cells -- we exploit the invariant that in (UDFM m i) all tags are distinct +-- Ints in [0, i): allocate an array of size i, write each element at +-- @index = tag@, freeze, and read out in index order. That's O(i) work (which +-- subsumes the O(n) fill, since distinct tags force n <= i), no comparisons, +-- and the readout is lazy, so consumers that demand only a prefix pay almost +-- nothing beyond the fill (but the fill itself is unavoidable; see +-- Note [Cost of deterministic iteration]). +-- +-- Holes: slots whose tag never occurs keep the initial sentinel, a TaggedVal +-- with tag -1. Real tags are non-negative, so the readout skips on tag < 0; +-- the sentinel's value field is never touched (it is unsafeCoerced ()). +-- +-- This sorting method loses when i is much larger than n: i never shrinks +-- (overwrites keep bumping it, delete/filter shrink n but not i). We compute +-- n = M.size m (O(n), cheap next to either sort) and fall back to the +-- mergesort when i > 4 * n. Maps built by plain insertion -- the common +-- case -- have i == n. The guard also caps the fast path's O(i) at O(n). + +usePlacement :: Int -> Int -> Bool +usePlacement n i = i <= 4 * n + +-- | Order a list of 'TaggedVal's by tag, by placing each at array index = +-- its tag. +-- +-- The tags must be distinct and in @[0, i)@. +-- See Note [Sorting a UDFM]. +placementSort :: forall r. Int -> [TaggedVal r] -> [r] +placementSort i tvs = runST (ST (\s0 -> + case newSmallArray i hole s0 of + (# s1, marr #) -> case fill marr tvs s1 of + s2 -> case unsafeFreezeSmallArray marr s2 of + (# s3, arr #) -> (# s3, readout arr 0 #))) + where + hole :: TaggedVal r + hole = TaggedVal (unsafeCoerce ()) (-1) + + fill :: SmallMutableArray s (TaggedVal r) -> [TaggedVal r] -> State# s -> State# s + fill _ [] s = s + fill marr (tv : tvs') s = + case writeSmallArray marr (taggedSnd tv) tv s of + s' -> fill marr tvs' s' + + readout :: SmallArray (TaggedVal r) -> Int -> [r] + readout arr j + | j >= i = [] + | t < 0 = readout arr (j + 1) + | otherwise = v : readout arr (j + 1) + where TaggedVal v t = indexSmallArray arr j + filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i @@ -356,11 +454,26 @@ udfmRestrictKeysSet (UDFM val_set i) set = in UDFM (M.restrictKeys val_set key_set) i -- | Converts `UniqDFM` to a list, with elements in deterministic order. --- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +-- +-- O(n) in the common case, with an O(n log n) fallback. +-- +-- Don't use this to access the first element or to check for emptiness, +-- as this already incurs most of the cost of returning the full list. +-- See Note [Cost of deterministic iteration]. udfmToList :: UniqDFM key elt -> [(Unique, elt)] -udfmToList (UDFM m _i) = - [ (mkUniqueGrimily k, taggedFst v) - | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] +udfmToList (UDFM m i) + | n <= 1 = [ (mkUniqueGrimily k, taggedFst v) | (k, v) <- M.toList m ] + + -- Unlike eltsUDFM, this allocates a fresh TaggedVal + pair per element + -- before the sort. If it ever matters, a parallel Word64 array of + -- keys filled in the same pass would avoid the eager boxes. + | usePlacement n i = placementSort i + (M.foldrWithKey (\k tv rest -> + TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv) : rest) [] m) + | otherwise = + [ (mkUniqueGrimily k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + where n = M.size m -- Determines whether two 'UniqDFM's contain the same keys. equalKeysUDFM :: UniqDFM key a -> UniqDFM key b -> Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c645b9c8d5318d36dd37c23c4abb6a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c645b9c8d5318d36dd37c23c4abb6a… You're receiving this email because of your account on gitlab.haskell.org.

1 0