- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign...
by Apoorv Ingle (＠ani) 08 Mar '26

08 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: f9ab1b23 by Apoorv Ingle at 2026-03-08T16:05:19-05:00 remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign from ErrMsgCtxt.FunTysCtxt - - - - - 12 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -83,7 +83,6 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Language.Haskell.Syntax (HsExpr (RecordUpd, HsGetField, HsProjection)) import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) @@ -2778,10 +2777,6 @@ isHasFieldOrigin = \case RecordUpdOrigin {} -> True RecordFieldProjectionOrigin {} -> True GetFieldOrigin {} -> True - ExpansionOrigin (ExprCtxt e) - | HsGetField{} <- e -> True - | RecordUpd{} <- e -> True - | HsProjection{} <- e -> True _ -> False ----------------------- ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7795,7 +7795,7 @@ pprErrCtxtMsg = \case <+> text "is applied to too many arguments" | otherwise - -> empty + -> text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -907,10 +907,10 @@ tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigm ; return (mkScaled mult_ty arg_nu) } - mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> CtOrigin + mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyOrigin mk_herald tc_fun arg = case fun_orig of - ExpansionOrigin (StmtErrCtxt{}) -> ExpectedTySyntax DoStmtOrigin arg + DoStmtOrigin -> ExpectedTySyntax DoStmtOrigin arg _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg -- Is the argument supposed to instantiate a forall? ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1067,7 +1067,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = ExpectedFunTySyntaxOp 1 orig op + herald = ExpectedFunTySyntaxOp orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1096,7 +1096,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op + herald = ExpectedFunTySyntaxOp orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) @@ -1848,4 +1848,3 @@ checkMissingFields con_like rbinds arg_tys field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -465,7 +465,7 @@ tcInferAppHead_maybe fun = case fun of -- visible type applications in the argument. -- c.f. T19167 (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$> - tcExprSigma False (ExpansionOrigin o) e + tcExprSigma False (errCtxtCtOrigin o) e ) _ -> return Nothing ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -114,7 +114,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments arity <- checkArgCounts matches - ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches + ; let herald = ExpectedFunTyMatches (NameThing fun_name) matches ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -703,7 +703,7 @@ tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside = -- 'view_expr' must be a function; expose its argument/result types -- using 'matchActualFunTy'. - ; let herald = ExpectedFunTyViewPat 1 $ unLoc view_expr + ; let herald = ExpectedFunTyViewPat $ unLoc view_expr ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr) (1, view_expr_rho) view_expr_rho ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1288,7 +1288,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (ExpansionOrigin (ExprCtxt (HsGetField {}))) = True + isGetFieldOrigin GetFieldOrigin{} = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, ExpectedFunTyOrigin ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon, ExpType ) import GHC.Types.Basic ( TyConFlavour ) @@ -283,7 +283,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !CtOrigin !Type !Int !Int + | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int -- | In the result of a function call. | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int -- | In the declaration of a type constructor. ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -9,9 +9,8 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeOriginCtOrigin, + srcCodeOriginCtOrigin, errCtxtCtOrigin, invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin, - updatePositionCtOrigin, pprCtOrigin, pprCtOriginBriefly, isGivenOrigin, defaultReprEqOrigins, isWantedSuperclassOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), @@ -37,7 +36,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - pprExpectedFunTyHerald, + ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -511,72 +510,6 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice - | ExpansionOrigin ErrCtxtMsg -- This is due to an expansion of the original thing given by the ErrCtxtMsg - - | ExpectedTySyntax !CtOrigin (HsExpr GhcRn) - - -- | A rebindable syntax operator is expected to have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - | forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTySyntaxOp Int - !CtOrigin !(HsExpr (GhcPass p)) - -- ^ rebindable syntax operator - - -- | A view pattern must have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder - | ExpectedFunTyViewPat Int - !(HsExpr GhcRn) - -- ^ function used in the view pattern - - -- | Need to be able to extract an argument type from a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyApp - | forall (p :: Pass) - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg - !TypedThing - -- ^ function - !(HsExpr (GhcPass p)) - -- ^ argument - - -- | Ensure that a function defined by equations indeed has a function type - -- with the appropriate number of arguments. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern - | ExpectedFunTyMatches Int - !TypedThing - -- ^ name of the function - !(MatchGroup GhcRn (LHsExpr GhcRn)) - -- ^ equations - - -- | Ensure that a lambda abstraction has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyLambda, RepPolyMatch - | ExpectedFunTyLam HsLamVariant - !(HsExpr GhcRn) - -- ^ the entire lambda-case expression - - -- | A partial application of the constructor of a representation-polymorphic - -- unlifted newtype in which the argument type does not have a fixed - -- runtime representation. - -- - -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. - | FRRRepPolyUnliftedNewtype !DataCon - - -updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin -updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e -updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e -updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e -updatePositionCtOrigin _ c = c - data NonLinearPatternReason = LazyPatternReason @@ -678,18 +611,18 @@ exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" -exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" -exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] -exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] -exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e) +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" +exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" +exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] +exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] +exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin (ExplicitList {}) = ListOrigin +exprCtOrigin (HsIf {}) = IfThenElseOrigin +exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p) +exprCtOrigin (RecordUpd _ _ flds) = RecordUpdOrigin flds +exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f)) exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) @@ -734,31 +667,6 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk -pprCtOrigin (ExpansionOrigin o) - = ctoHerald <+> what - where - what :: SDoc - what = case o of - StmtErrCtxt{} -> - text "a do statement" - DoStmtErrCtxt{} -> - text "a do statement" - StmtErrCtxtPat _ _ p -> - text "a do statement" $$ - text "with the failable pattern" <+> quotes (ppr p) - ExprCtxt (HsGetField _ _ (L _ f)) -> - hsep [text "selecting the field", quotes (ppr f)] - ExprCtxt (HsOverLabel _ l) -> - hsep [text "the overloaded label" , quotes (char '#' <> ppr l)] - ExprCtxt (RecordUpd{}) -> text "a record update" - ExprCtxt (ExplicitList{}) -> text "an overloaded list" - ExprCtxt (HsIf{}) -> text "an if-then-else expression" - ExprCtxt (HsProjection _ p) -> text "the record selector" <+> - quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) - ExprCtxt e -> text "the expression" <+> (ppr e) - RecordUpdCtxt{} -> text "a record update" - _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin" - pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -865,46 +773,9 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) -pprCtOrigin (ExpectedTySyntax orig arg) - = vcat [ text "The expression" <+> quotes (ppr arg) - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTySyntaxOp i orig op) = - vcat [ sep [ the_arg_of i - , text "the rebindable syntax operator" - , quotes (ppr op) ] - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTyViewPat i expr) = - vcat [ the_arg_of i <+> text "the view pattern" - , nest 2 (ppr expr) ] -pprCtOrigin (ExpectedFunTyArg fun arg) = - sep [ text "The argument" - , quotes (ppr arg) - , text "of" - , quotes (ppr fun) ] -pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts })) - | null alts - = the_arg_of i <+> quotes (ppr fun) - | otherwise - = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts - <+> text "for" <+> quotes (ppr fun) -pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant -pprCtOrigin (FRRRepPolyUnliftedNewtype dc) = - vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." - , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] - pprCtOrigin simple_origin = ctoHerald <+> pprCtOriginBriefly simple_origin -the_arg_of :: Int -> SDoc -the_arg_of i = text "The" <+> speakNth i <+> text "argument of" - -binder_of :: SDoc -> SDoc -binder_of what = text "The binder of the" <+> what <+> text "expression" - - - -- | Print CtOrigin briefly, with a one-liner pprCtOriginBriefly :: CtOrigin -> SDoc pprCtOriginBriefly = ppr_br -- ppr_br is a local function with a short name! @@ -976,22 +847,6 @@ ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" ppr_br (ImpedanceMatching {}) = text "combining required constraints" ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] -ppr_br (ExpansionOrigin (ExprCtxt (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] -ppr_br (ExpansionOrigin (ExprCtxt (RecordUpd{}))) = text "a record update" -ppr_br (ExpansionOrigin (ExprCtxt (ExplicitList{}))) = text "an overloaded list" -ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression" -ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e -ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement" -ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement" -ppr_br (ExpansionOrigin{}) = text "shouldn't happen ExpansionOrigin ppr_br" -ppr_br (ExpectedTySyntax o _) = ppr_br o -ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" -ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" -ppr_br (ExpectedFunTyArg{}) = text "a funtion head" -ppr_br (ExpectedFunTyMatches{}) = text "a match statement" -ppr_br (ExpectedFunTyLam{}) = text "a lambda expression" -ppr_br (FRRRepPolyUnliftedNewtype{}) = text "a unlifted newtype" - pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") @@ -1224,7 +1079,7 @@ data FixedRuntimeRepContext -- -- See 'ExpectedFunTyOrigin' for more details. | FRRExpectedFunTy - !CtOrigin + !ExpectedFunTyOrigin !Int -- ^ argument position (1-indexed) @@ -1311,7 +1166,7 @@ pprFixedRuntimeRepContext FRRBindStmtGuard pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) - = pprCtOrigin funTyOrig + = pprExpectedFunTyHerald funTyOrig pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun) = hsep [ text "The", what, text "type of the" , ppr (Argument pos) @@ -1537,15 +1392,136 @@ instance Outputable FRRArrowContext where ppr = pprFRRArrowContext -pprExpectedFunTyHerald :: CtOrigin -> SDoc +{- ********************************************************************* +* * + FixedRuntimeRep: ExpectedFunTy origin +* * +********************************************************************* -} + +-- | In what context are we calling 'matchExpectedFunTys' +-- or 'matchActualFunTy'? +-- +-- Used for two things: +-- +-- 1. Reporting error messages which explain that a function has been +-- given an unexpected number of arguments. +-- Uses 'pprExpectedFunTyHerald'. +-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. +-- +-- 2. Reporting representation-polymorphism errors when a function argument +-- doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- Uses 'pprExpectedFunTyOrigin'. +-- See 'FixedRuntimeRepContext' for the situations in which +-- representation-polymorphism checks are performed. +data ExpectedFunTyOrigin + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + = forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | + | ExpectedTySyntax !CtOrigin !(HsExpr GhcRn) + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + + -- | A partial application of the constructor of a representation-polymorphic + -- unlifted newtype in which the argument type does not have a fixed + -- runtime representation. + -- + -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRRepPolyUnliftedNewtype !DataCon + +pprExpectedFunTyOrigin :: ExpectedFunTyOrigin + -> Int -- ^ argument position (starting at 1) + -> SDoc +pprExpectedFunTyOrigin funTy_origin i = + case funTy_origin of + ExpectedFunTySyntaxOp orig op -> + vcat [ sep [ the_arg_of + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] + ExpectedTySyntax orig arg -> + vcat [ text "the expression" <+> quotes (ppr arg) + , nest 2 (ppr orig) ] + ExpectedFunTyViewPat expr -> + vcat [ the_arg_of <+> text "the view pattern" + , nest 2 (ppr expr) ] + ExpectedFunTyArg fun arg -> + sep [ text "The argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] + ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) + | null alts + -> the_arg_of <+> quotes (ppr fun) + | otherwise + -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) + ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant + FRRRepPolyUnliftedNewtype dc -> + vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." + , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] + where + the_arg_of :: SDoc + the_arg_of = text "The" <+> speakNth i <+> text "argument of" + + binder_of :: SDoc -> SDoc + binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" +pprExpectedFunTyHerald (ExpectedTySyntax orig _) + = pprCtOriginBriefly orig pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" pprExpectedFunTyHerald (ExpectedFunTyArg fun _) = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to" ] -pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts })) +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" @@ -1554,7 +1530,6 @@ pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) , text "has" ] pprExpectedFunTyHerald (FRRRepPolyUnliftedNewtype dc) = text "The unlifted newtype" <+> quotes (ppr dc) <+> text "expects" -pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -5,6 +5,7 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data CtOrigin +data ExpectedFunTyOrigin data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -139,7 +139,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: CtOrigin + :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -178,7 +178,7 @@ matchActualFunTy herald mb_thing err_info fun_ty go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty + do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald 1) arg_ty ; let fun_co = mkFunCo Nominal af (mkReflCo Nominal w) arg_co @@ -249,7 +249,7 @@ Ugh! -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -793,7 +793,7 @@ Example: -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - CtOrigin -- See Note [Herald for matchExpectedFunTys] + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -875,7 +875,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc - ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty + ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr ; (res_wrap, result) <- check (n_req - 1) (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys) @@ -947,19 +947,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) +new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy - ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy - ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: CtOrigin +mkFunTysMsg :: ExpectedFunTyOrigin -> (VisArity, TcType) -> ErrCtxtMsg -- See Note [Reporting application arity errors] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9ab1b23f2e2611bfd0a2a5d6c5fd77… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9ab1b23f2e2611bfd0a2a5d6c5fd77… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ghc_par] Fix an issue with dependency analysis with boot files
by Andreas Klebinger (＠AndreasK) 08 Mar '26

08 Mar '26

Andreas Klebinger pushed to branch wip/andreask/ghc_par at Glasgow Haskell Compiler / GHC Commits: ec5be442 by Andreas Klebinger at 2026-03-08T17:53:50+00:00 Fix an issue with dependency analysis with boot files - - - - - 1 changed file: - compiler/GHC/Core/Opt/Split.hs Changes: ===================================== compiler/GHC/Core/Opt/Split.hs ===================================== @@ -10,16 +10,18 @@ import GHC.Prelude hiding ( head, init, last ) import GHC.Core import GHC.Core.FVs import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit) +import GHC.Core.Stats (coreBindsSize) import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq) import GHC.Data.Maybe (orElse) import GHC.Types.Unique.Set -import GHC.Types.Name (isExternalName, nameModule) -import GHC.Types.Id (realIdUnfolding) +import GHC.Types.Name (Name, isExternalName, nameModule) +import GHC.Types.Id (isDFunId, realIdUnfolding) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Var +import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Utils.Panic @@ -100,25 +102,40 @@ bindSplitFreeVars :: VarSet -> CoreBind -> VarSet bindSplitFreeVars local_top_bndrs bind = close_over_imported_unfoldings (bindMentionedVars bind `unionVarSet` bindBndrInfoVars bind) where + local_name_env :: NameEnv Var + local_name_env = mkNameEnv [ (varName v, v) | v <- nonDetEltsUniqSet local_top_bndrs ] + close_over_imported_unfoldings fvs = go emptyVarSet fvs go !seen !fvs = case pick_new_import (fvs `minusVarSet` seen) of Nothing -> fvs Just v -> - let unfolding_fvs = unfoldingRefs v + let unfolding_fvs = localizeLocalRefs (unfoldingRefs v) local_unfolding_fvs = unfolding_fvs `intersectVarSet` local_top_bndrs in go (extendVarSet seen v) (fvs `unionVarSet` local_unfolding_fvs `unionVarSet` unfolding_fvs) pick_new_import vars = find pickable (nonDetEltsUniqSet vars) - pickable v = isId v && not (v `elemVarSet` local_top_bndrs) + pickable v = isId v && isDFunId v && not (v `elemVarSet` local_top_bndrs) unfoldingRefs v = - case maybeUnfoldingTemplate (realIdUnfolding v) of - Just rhs -> exprSomeFreeVars (const True) rhs - Nothing -> emptyVarSet + case realIdUnfolding v of + BootUnfolding -> emptyVarSet + unf -> + case maybeUnfoldingTemplate unf of + Just rhs -> exprSomeFreeVars (const True) rhs + Nothing -> emptyVarSet + + localizeLocalRefs :: VarSet -> VarSet + localizeLocalRefs vars = mkVarSet (map localizeVar (nonDetEltsUniqSet vars)) + + localizeVar :: Var -> Var + localizeVar v = + case lookupNameEnv local_name_env (varName v) of + Just local_v -> local_v + Nothing -> v bindMentionedVars :: CoreBind -> VarSet bindMentionedVars (NonRec _ rhs) = exprSomeFreeVars (const True) rhs @@ -219,8 +236,10 @@ pprVarWithModule v splitCompUnit :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule]) splitCompUnit this_module imp_rules unit = let comp_units = map mk_comp_unit components_with_rules - in checkNameClashes comp_units `seq` - (comp_units, rules_for_imps ++ rules_without_component) + result = (comp_units, rules_for_imps ++ rules_without_component) + in -- pprTrace "CoreSplitTrace" (pprSplitTrace comp_units) $ + checkNameClashes comp_units `seq` + result where CoreCompUnit occ_binds unit_rules = occurAnalyseCompUnit this_module (const True) (const True) imp_rules unit @@ -269,3 +288,24 @@ checkNameClashes comp_units go seen (b:bs) | b `elemVarSet` seen = b : go seen bs | otherwise = go (extendVarSet seen b) bs + +pprSplitTrace :: [CoreCompUnit] -> SDoc +pprSplitTrace comp_units = + text (show (length comp_units)) + <+> text "Unit; CoreSizes:" + <+> pprIntList sizes + <> semi + <+> text "RelativeSize:" + <+> pprPercentList rel_sizes + where + sizes = map (coreBindsSize . coreCompUnitBinds) comp_units + total_size = sum sizes + rel_sizes + | total_size == 0 = replicate (length sizes) 0 + | otherwise = map (\sz -> (100 * sz) `div` total_size) sizes + +pprIntList :: [Int] -> SDoc +pprIntList xs = brackets (hcat (punctuate comma (map int xs))) + +pprPercentList :: [Int] -> SDoc +pprPercentList xs = brackets (hcat (punctuate comma [ int x <> char '%' | x <- xs ])) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec5be4425b0ee8c19f4a817d36236bd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec5be4425b0ee8c19f4a817d36236bd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T1216
by Simon Jakobi (＠sjakobi2) 08 Mar '26

08 Mar '26

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

1 0

[Git][ghc/ghc][wip/sjakobi/regression-tests-3] Add regression test for #10381
by Simon Jakobi (＠sjakobi2) 08 Mar '26

08 Mar '26

Simon Jakobi pushed to branch wip/sjakobi/regression-tests-3 at Glasgow Haskell Compiler / GHC Commits: 8490e918 by Simon Jakobi at 2026-03-08T17:44:55+01:00 Add regression test for #10381 Closes #10381. - - - - - 2 changed files: - + testsuite/tests/rebindable/T10381.hs - testsuite/tests/rebindable/all.T Changes: ===================================== testsuite/tests/rebindable/T10381.hs ===================================== @@ -0,0 +1,43 @@ +{-# LANGUAGE RebindableSyntax, RankNTypes #-} + +module T10381 where + +import Prelude ( String, undefined ) + +newtype Cont r a = Cont { runCont :: (forall i. a i -> r) -> r } + +(>>=) :: Cont r a -> (forall i. a i -> Cont r b) -> Cont r b +ma >>= fmb + = Cont (\k -> runCont ma (\a -> runCont (fmb a) k)) + +fail :: String -> Cont r a +fail = undefined + +return :: a i -> Cont r a +return x = Cont (\k -> k x) + +foo :: Cont r [] +foo = do + bar <- foo + return bar + +{- Previously, GHC used to reject this program with: + + Couldn't match type ‘i0’ with ‘i’ + because type variable ‘i’ would escape its scope + This (rigid, skolem) type variable is bound by + a type expected by the context: [i] -> Cont r [] + at Bug.hs:21:3-12 + Expected type: Cont r [] -> ([i0] -> Cont r []) -> Cont r [] + Actual type: Cont r [] + -> (forall i. [i] -> Cont r []) -> Cont r [] + In a stmt of a 'do' block: bar <- foo + In the expression: + do { bar <- foo; + return bar } + In an equation for ‘foo’: + foo + = do { bar <- foo; + return bar } +-} + ===================================== testsuite/tests/rebindable/all.T ===================================== @@ -35,6 +35,7 @@ test('T4851', normal, compile, ['']) test('T5908', normal, compile, ['']) test('T10112', normal, compile, ['']) +test('T10381', normal, compile, ['']) test('T11216', normal, compile, ['']) test('T11216A', normal, compile, ['']) test('T12080', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8490e91890ba3d4f5627edf6e4dbebe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8490e91890ba3d4f5627edf6e4dbebe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 5 commits: getTestExePath: Cleanup
by Sven Tennie (＠supersven) 08 Mar '26

08 Mar '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 2e1c0782 by Sven Tennie at 2026-03-08T11:18:20+00:00 getTestExePath: Cleanup - - - - - 78f81994 by Sven Tennie at 2026-03-08T11:35:56+00:00 Delete obsolete comment - - - - - 2c480368 by Sven Tennie at 2026-03-08T11:41:47+00:00 Rules.Test.testEnv: Improve diff - - - - - d12e83fa by Sven Tennie at 2026-03-08T11:48:01+00:00 includeCcArgs: Align with master - - - - - 83e7dc2e by Sven Tennie at 2026-03-08T12:01:16+00:00 Move comment about mandatory static and cross - - - - - 6 changed files: - hadrian/src/Oracles/Flavour.hs - hadrian/src/Oracles/TestSettings.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/DeriveConstants.hs - hadrian/src/Settings/Program.hs Changes: ===================================== hadrian/src/Oracles/Flavour.hs ===================================== @@ -28,6 +28,8 @@ oracles = do void $ addOracle $ \(DynGhcPrograms stage) -> do cross <- crossStage stage from_flavour <- flip dynamicGhcPrograms stage =<< flavour + -- Have to build static if it's a cross stage as we won't distribute the + -- libraries built for the host. return (from_flavour && not cross) void $ addOracle $ \(GhcProfiled stage) -> ghcProfiled <$> flavour <*> pure (succStage stage) ===================================== hadrian/src/Oracles/TestSettings.hs ===================================== @@ -142,10 +142,9 @@ getTestCross testGhc = Just stg -> crossStage stg Nothing -> getBooleanSetting TestCrossCompiling - --- Given the testGhc string, either a stage0..stage1..stage2 etc or a path to --- a compiler. Compute the absolute path to the relevant executable provided by --- the package in the second argument. +-- | Given the @testGhc@ `String` (either `stage1`, `stage2`, `stage3` or a +-- path to a compiler). Compute the absolute path to the relevant executable +-- provided by the package @pkg@ in the second argument. getTestExePath :: String -> Package -> Action FilePath getTestExePath testGhc pkg = do case stageOfTestCompiler testGhc of @@ -154,10 +153,8 @@ getTestExePath testGhc pkg = do bindir <- getBinaryDirectory testGhc compiler_path <- getCompilerPath testGhc cross <- getBooleanSetting TestCrossCompiling - let cross_prefix = if cross then dropWhileEnd ((/=) '-') (takeFileName compiler_path) else "" - -- get relative path for the given program in the given stage + let cross_prefix = if cross then dropWhileEnd ('-' /=) (takeFileName compiler_path) else "" let make_absolute rel_path = do abs_path <- liftIO (makeAbsolute rel_path) fixAbsolutePathOnWindows abs_path make_absolute (bindir </> (cross_prefix ++ programBasename pkg) <.> exe) - -- get relative path for the given program in the given stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -526,7 +526,6 @@ generateConfigHs = do stage <- getStage let chooseSetting x y = case stage of { Stage0 {} -> x; _ -> y } let queryTarget f = f <$> expr (targetStage stage) - -- Not right for stage3 buildPlatform <- chooseSetting (queryBuild targetPlatformTriple) (queryHost targetPlatformTriple) hostPlatform <- queryTarget targetPlatformTriple trackGenerateHs ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -197,18 +197,16 @@ testRules = do testEnv :: Stage -> Action [(String, String)] testEnv stg = do - testGhc <- testCompiler <$> userSetting defaultTestArgs - cross <- getTestCross testGhc - prog_ghc_pkg <- getTestExePath testGhc ghcPkg - prog_hsc2hs <- getTestExePath testGhc hsc2hs - prog_hp2ps <- getTestExePath testGhc hp2ps - prog_haddock <- getTestExePath testGhc haddock - prog_hpc <- getTestExePath testGhc hpc - prog_runghc <- getTestExePath testGhc runGhc makePath <- builderPath $ Make "" + prog_ghc_pkg <- getTestExePath testGhc ghcPkg + prog_hsc2hs <- getTestExePath testGhc hsc2hs + prog_hp2ps <- getTestExePath testGhc hp2ps + prog_haddock <- getTestExePath testGhc haddock + prog_hpc <- getTestExePath testGhc hpc + prog_runghc <- getTestExePath testGhc runGhc root <- buildRoot args <- userSetting defaultTestArgs ===================================== hadrian/src/Settings/Builders/DeriveConstants.hs ===================================== @@ -48,4 +48,4 @@ includeCcArgs = do , arg "-Irts/include" , arg $ "-I" ++ rtsPath </> "include" , notM (targetSupportsSMP stage) ? arg "-DNOSMP" - , arg "-fcommon" ] + ] ===================================== hadrian/src/Settings/Program.hs ===================================== @@ -19,11 +19,10 @@ programContext :: Stage -> Package -> Action Context programContext stage pkg = do profiled <- askGhcProfiled stage dynGhcProgs <- askDynGhcPrograms stage - -- Have to build static if it's a cross stage as we won't distribute the libraries built for the host. return $ Context stage pkg (wayFor profiled dynGhcProgs) Final where wayFor prof dyn - | prof && dyn = profilingDynamic + | prof && dyn = profilingDynamic | pkg == ghc && prof && notStage0 stage = profiling | dyn && notStage0 stage = dynamic | otherwise = vanilla View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ccee36aebfd046affa9d124aa87c8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ccee36aebfd046affa9d124aa87c8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ghc_par] 9 commits: Refactored splitting.
by Andreas Klebinger (＠AndreasK) 08 Mar '26

08 Mar '26

Andreas Klebinger pushed to branch wip/andreask/ghc_par at Glasgow Haskell Compiler / GHC Commits: cde2e390 by Andreas Klebinger at 2026-03-07T13:39:29+00:00 Refactored splitting. Broke it into parts to make it easier to understand. - - - - - 82d089c0 by Andreas Klebinger at 2026-03-07T16:48:25+00:00 Make sure CoreMerge reattaches unstable unfoldings - - - - - 8de36fbf by Andreas Klebinger at 2026-03-07T21:14:07+00:00 testsuite: Ignore compilation unit header in output comparison - - - - - 775a5b9f by Andreas Klebinger at 2026-03-07T21:50:09+00:00 Some useless checks - - - - - dd3df12c by Andreas Klebinger at 2026-03-07T22:57:33+00:00 Possible fixes to simplifier/specConstr from the bot - - - - - 5527b495 by Andreas Klebinger at 2026-03-08T09:29:51+00:00 merge/split around late cse - - - - - 15a3537c by Andreas Klebinger at 2026-03-08T09:35:41+00:00 Make CSE work independently over compilation units - - - - - e02db7ea by Andreas Klebinger at 2026-03-08T10:00:25+00:00 Keep rules attributed to units in the simplifier - - - - - 08faa984 by Andreas Klebinger at 2026-03-08T13:42:08+00:00 Some vibe based fixes - - - - - 12 changed files: - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - + compiler/GHC/Core/Opt/Split.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/ghc.cabal.in - testsuite/driver/testlib.py Changes: ===================================== compiler/GHC/Core/Opt/CSE.hs ===================================== @@ -380,18 +380,18 @@ body/rest of the module. -} cseProgram :: CoreProgram -> CoreProgram -cseProgram comp_units - = snd (mapAccumL cse_comp_unit init_env comp_units) +cseProgram = map cseCoreCompUnit + +cseCoreCompUnit :: CoreCompUnit -> CoreCompUnit +cseCoreCompUnit (CoreCompUnit unit_binds unit_rules) + = CoreCompUnit binds' unit_rules where - init_env = emptyCSEnv $ - mkInScopeSetList (bindersOfBinds (concatMap coreCompUnitBinds comp_units)) - -- Put all top-level binders into scope; it is possible to have - -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal - -- Missing this caused #25468 - - cse_comp_unit env (CoreCompUnit binds unit_rules) - = let (env', binds') = mapAccumL (cseBind TopLevel) env binds - in (env', CoreCompUnit binds' unit_rules) + init_env = emptyCSEnv $ + mkInScopeSetList (bindersOfBinds unit_binds) + -- Put all top-level binders in this compilation unit into + -- scope; it is possible to have forward references. + -- See Note [Glomming] in GHC.Core.Opt.OccurAnal. + (_env', binds') = mapAccumL (cseBind TopLevel) init_env unit_binds cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e) ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -16,7 +16,7 @@ module GHC.Core.Opt.Monad ( -- ** Reading from the monad getModule, - initRuleEnv, getExternalRuleBase, + initRuleEnv, getHomeRuleBase, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, getInteractiveContext, getUniqTag, ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -28,7 +28,6 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseCompUnit, - occurSplitPgm, occurAnalyseExpr, occurAnalyseExpr_Prep, zapLambdaBndrs ) where @@ -57,7 +56,6 @@ import GHC.Types.Id.Info import GHC.Types.InlinePragma ( ActivationGhc, isAlwaysActive ) import GHC.Types.Basic import GHC.Types.Tickish -import GHC.Types.Name (isExternalName, nameModule) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Var @@ -70,14 +68,12 @@ import GHC.Utils.Misc import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet import Data.List (mapAccumL) {- ************************************************************************ * * - occurAnalysePgm, occurAnalyseExpr, occurSplitPgm + occurAnalysePgm, occurAnalyseExpr * * ************************************************************************ @@ -99,140 +95,6 @@ occurAnalyseExpr_Prep expr = expr' where WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr --- After optimizations a rule might no longer reference binders from this module. --- In these cases we return them here and then add them to mg_rules. -occurSplitPgm :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule]) -occurSplitPgm mod imp_rules (CoreCompUnit unit_binds unit_rules) - = - -- pprTrace "occurSplitPgm" - -- ( vcat [ - -- text "imp", - -- ppr imp_rules, - -- text "unit", - -- ppr (unit_rules, unit_binds) - -- ] - -- ) - (zipWith mk_comp_unit comp_pairs [0..], rules_for_imps) - where - CoreCompUnit occ_binds _ = - occurAnalyseCompUnit mod (const True) (const True) imp_rules - (CoreCompUnit unit_binds unit_rules) - - pairs = flattenBinds occ_binds - bndrs = map fst pairs - bndr_set = mkVarSet bndrs - - imp_rule_edges :: ImpRuleEdges - imp_rule_edges = mkImpRuleEdges imp_rules - - -- If a unit rule mentions multiple local binders, they must end up in - -- the same component; otherwise the rule cannot be attached to any one - -- split unit without creating cross-unit references. - rule_fv_edges :: IdEnv VarSet - rule_fv_edges - = foldr (plusVarEnv_C unionVarSet) emptyVarEnv - [ mapVarEnv (const local_rule_fvs) (getUniqSet local_rule_fvs) - | rule <- unit_rules - , let local_rule_fvs = ruleFreeVars rule `intersectVarSet` bndr_set - ] - - dir_nodes :: [Node Unique (Id, CoreExpr)] - dir_nodes = map mk_dir_node pairs - - mk_dir_node (bndr, rhs) - = DigraphNode { node_payload = (bndr, rhs) - , node_key = varUnique bndr - , node_dependencies = nonDetKeysUniqSet deps - } - where - deps = traced_fvs `intersectVarSet` bndr_set - - traced_fvs = -- pprTrace "occurSplitPgm: binder fvs before unit assignment" - -- (ppr bndr $$ text "fvs:" <+> ppr dep_fvs) - dep_fvs - - dep_fvs = exprFreeIds rhs - `unionVarSet` bndrRuleAndUnfoldingIds bndr - `unionVarSet` localRuleDeps bndr - `unionVarSet` impRuleDeps bndr - - impRuleDeps b = foldr unionVarSet emptyVarSet [ vs | (_, vs) <- lookupImpRules imp_rule_edges b ] - - localRuleDeps b = lookupVarEnv rule_fv_edges b `orElse` emptyVarSet - - incoming_edges :: UniqFM Unique [Unique] - incoming_edges = foldr add_incoming emptyUFM dir_nodes - where - add_incoming DigraphNode { node_key = src, node_dependencies = dests } incoming - = foldr (\dest acc -> addToUFM_C (++) acc dest [src]) incoming dests - -- TODO: AI Garbage? - - -- We probably really should just do this on a undirected graph instead. - undir_nodes :: [Node Unique (Id, CoreExpr)] - undir_nodes = - [ node { node_dependencies = node_dependencies node ++ lookupWithDefaultUFM incoming_edges [] (node_key node) } - | node <- dir_nodes - ] - - comp_pairs :: [[(Id, CoreExpr)]] - comp_pairs = map scc_payloads (stronglyConnCompFromEdgedVerticesUniq undir_nodes) - - component_bndrs :: [[Id]] - component_bndrs = map (map fst) comp_pairs - - mk_comp_unit prs i = CoreCompUnit (mk_comp_binds prs) (component_rules i) - - mk_comp_binds [pr] = [NonRec (fst pr) (snd pr)] - mk_comp_binds prs = [Rec prs] - - (component_rule_map, rules_for_imps) = foldr assign_rule (IntMap.empty, []) unit_rules - - assign_rule rule (rule_map, imp_rules_acc) - = case rule_comp_index rule of - Just i -> (IntMap.insertWith (++) i [rule] rule_map, imp_rules_acc) - Nothing -> (rule_map, rule : imp_rules_acc) - - component_rules i = IntMap.findWithDefault [] i component_rule_map - - rule_comp_index rule - = case rule_component_indices of - [i] -> Just i - [] -> Nothing - is -> pprPanic "occurSplitPgm" - (text "Rule free vars span multiple components" - $$ text "rule:" <+> ppr rule - $$ text "components:" <+> ppr is - $$ text "rule_fvs:" <+> pprVarsWithModule (nonDetEltsUniqSet rule_fvs) - $$ vcat [ text "component" <+> int i <> colon <+> ppr hits - | (i, hits) <- component_hits ]) - where - rule_component_indices :: [Int] - rule_component_indices = IntSet.toList $ IntSet.fromList - [ i - | (ids, i) <- zip component_bndrs [0..] - , not (isEmptyVarSet (local_rule_fvs `intersectVarSet` mkVarSet ids)) - ] - - rule_fvs = ruleFreeVars rule - local_rule_fvs = rule_fvs `intersectVarSet` bndr_set - component_hits = - [ (i, local_rule_fvs `intersectVarSet` mkVarSet ids) - | (ids, i) <- zip component_bndrs [0..] - , not (isEmptyVarSet (local_rule_fvs `intersectVarSet` mkVarSet ids)) - ] - - scc_payloads (AcyclicSCC p) = [p] - scc_payloads (CyclicSCC ps) = ps - - pprVarsWithModule :: [Var] -> SDoc - pprVarsWithModule vars = braces (fsep (punctuate comma (map pprVarWithModule vars))) - - pprVarWithModule :: Var -> SDoc - pprVarWithModule v - | isExternalName n = ppr v <+> parens (ppr (nameModule n)) - | otherwise = ppr v - where - n = varName v - occurAnalyseCompUnit :: Module -> (Id -> Bool) ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Driver.DynFlags import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Driver.Config (initSimpleOpts) -import GHC.Driver.Config.Core.Lint ( endPass ) +import GHC.Driver.Config.Core.Lint ( endPass, initLintConfig ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) @@ -22,12 +22,12 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core -import GHC.Core.SimpleOpt (simpleOptPgm) +import GHC.Core.SimpleOpt (simpleOptPgm, defaultSimpleOpts, so_inline, so_uf_opts) import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreProgram, pprRules ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) -import GHC.Core.Lint ( lintAnnots ) +import GHC.Core.Lint ( lintAnnots, lintCoreProgram', displayLintResults ) import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) import GHC.Core.Opt.Simplify.Monad @@ -43,7 +43,7 @@ import GHC.Core.Opt.DmdAnal import GHC.Core.Opt.CprAnal ( cprAnalProgram ) import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) -import GHC.Core.Opt.OccurAnal ( occurSplitPgm ) +import GHC.Core.Opt.Split ( splitCompUnit, checkNameClashes ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) @@ -320,7 +320,11 @@ getCoreToDo dflags hpt_rule_base extra_vars -- in wheel-sieve1), and I'm guessing that SpecConstr can too -- And CSE is a very cheap pass. So it seems worth doing here. runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses - [ CoreCSE, simplify "post-final-cse" ], + [ runWhen split_core CoreMerge + , CoreCSE + , runWhen split_core CoreSplit + , simplify "post-final-cse" + ], --------- End of -O2 passes -------------- @@ -457,6 +461,7 @@ doCorePass pass guts = do dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv + let extra_vars = interactiveInScope (hsc_IC hsc_env) let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } @@ -478,14 +483,16 @@ doCorePass pass guts = do updateBindsAndRulesM (desugarOpt dflags logger (mg_module guts)) CoreSplit -> {-# SCC "CoreSplit" #-} - do { let split_res = map (occurSplitPgm (mg_module guts) (mg_rules guts)) (mg_binds guts) + do { let split_res = map (splitCompUnit (mg_module guts) (mg_rules guts)) (mg_binds guts) binds' = concatMap fst split_res rules' = mg_rules guts ++ concatMap snd split_res ; return guts { mg_binds = binds', mg_rules = rules' } } CoreMerge -> {-# SCC "CoreMerge" #-} do { let binds_before = mg_binds guts + _ = checkNameClashes binds_before binds_after = flattenCoreProgram binds_before + _ = checkNameClashes binds_after ; liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_split_core "Core before merge" @@ -497,7 +504,33 @@ doCorePass pass guts = do "Core after merge" FormatCore (pprCoreProgram binds_after) - ; return $ guts { mg_binds = binds_after } } + ; liftIO $ do + let warns_and_errs = lintCoreProgram' + (initLintConfig dflags extra_vars) + binds_after + (mg_rules guts) + True + displayLintResults logger + (text "CoreMerge after flattenCoreProgram") + (pprCoreProgram binds_after) + warns_and_errs + ; let minimal_things = defaultSimpleOpts + { so_inline = False + , so_uf_opts = unfoldingOpts dflags } + (binds_w_unfolds, rules_for_imps, occ_anald_binds) = simpleOptPgm + minimal_things + (mg_module guts) + binds_after + (mg_rules guts) + _ = checkNameClashes binds_w_unfolds + ; liftIO $ + Logger.putDumpFileMaybe logger Opt_D_dump_split_core + "Core after re-attaching unfolds" + FormatCore + (pprCoreProgram occ_anald_binds) + + ; return $ guts { mg_binds = binds_w_unfolds + , mg_rules = rules_for_imps } } CoreDoSimplify opts -> {-# SCC "Simplify" #-} liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Core +import GHC.Core.FVs (ruleFreeVars) import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) @@ -38,10 +39,10 @@ import GHC.Unit.Module.ModGuts import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish import GHC.Types.Unique.FM +import GHC.Types.Var.Set import Control.Monad import Data.Foldable ( for_ ) @@ -240,7 +241,7 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- number of iterations we actually completed return ( "Simplifier bailed out", iteration_no - 1 , totalise counts_so_far - , dyn_no_binds { dsd_binds = [CoreCompUnit bind_list unit_rules], dsd_rules = local_rules } ) + , dyn_no_binds { dsd_binds = binds, dsd_rules = local_rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. @@ -271,38 +272,19 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- (b) local rules (substituted), including unit rules from `binds` -- Forcing base_rule_env to avoid unnecessary allocations. -- Not doing so results in +25.6% allocations of LargeRecord. - ; !base_rule_env = updLocalRules hpt_rule_env (local_rules ++ unit_rules) - - ; read_eps_rules :: IO PackageRuleBase - ; read_eps_rules = eps_rule_base <$> ueEPS unit_env - - ; read_rule_env :: IO RuleEnv - ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) ; simpl_env = mkSimplEnv mode fam_envs } ; - -- Simplify the program - ((binds1, rules1, unit_rules1), counts1) <- - initSmpl logger read_rule_env top_env_cfg sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_bind_list - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplImpRules env1 local_rules - ; unit_rules1 <- simplImpRules env1 unit_rules - - ; return (getTopFloatBinds floats, rules1, unit_rules1) } ; + -- Simplify each compilation unit independently + ((binds1, rules1), counts1) <- + simpl_comp_units simpl_env local_rules tagged_binds sz ; -- Stop if nothing happened; don't dump output -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats if isZeroSimplCount counts1 then return ( "Simplifier reached fixed point", iteration_no , totalise (counts1 : counts_so_far) -- Include "free" ticks - , dyn_no_binds { dsd_binds = [CoreCompUnit binds1 unit_rules1], dsd_rules = rules1 } ) + , dyn_no_binds { dsd_binds = binds1, dsd_rules = rules1 } ) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -312,26 +294,77 @@ simplifyPgm' logger unit_env name_ppr_ctx opts -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + let { binds2 = {-# SCC "ZapInd" #-} + [ CoreCompUnit (shortOutIndirections unit_binds) unit_rules' + | CoreCompUnit unit_binds unit_rules' <- binds1 ] } ; -- Dump the result of this iteration dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 - [CoreCompUnit binds2 unit_rules1] rules1 ; + binds2 rules1 ; for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> - lintPassResult logger pass_result_cfg [CoreCompUnit binds2 unit_rules1] rules1 ; + lintPassResult logger pass_result_cfg binds2 rules1 ; -- Loop - do_iteration (iteration_no + 1) (counts1:counts_so_far) [CoreCompUnit binds2 unit_rules1] rules1 + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } where bind_list = concatMap coreCompUnitBinds binds - unit_rules = concatMap cu_rules binds -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + -- Keep top-level in-scope sets per-unit until CoreMerge. + simpl_comp_units + :: SimplEnv + -> [CoreRule] + -> CoreProgram + -> Int + -> IO ((CoreProgram, [CoreRule]), SimplCount) + simpl_comp_units simpl_env rules0 units0 sz = go rules0 [] zero_counts units0 + where + zero_counts = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + + go !rules acc !counts [] = return ((reverse acc, rules), counts) + go !rules acc !counts (CoreCompUnit unit_binds unit_rules' : rest) = do + let unit_bndrs = mkVarSet (bindersOfBinds unit_binds) + (visible_rules, hidden_rules) = partitionVisibleImpRules unit_bndrs rules + !base_rule_env = updLocalRules hpt_rule_env (visible_rules ++ unit_rules') + read_eps_rules = eps_rule_base <$> ueEPS unit_env + read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules + + ((unit1, visible_rules1), counts1) <- + initSmpl logger read_rule_env top_env_cfg sz $ do + (floats, env1) <- {-# SCC "SimplTopBindsUnit" #-} + simplTopBinds simpl_env unit_binds + + -- Apply substitutions from this unit to imported-head rules and + -- the unit's own rules. Keep each unit's local rules separate. + visible_rules1 <- simplImpRules env1 visible_rules + unit_rules1 <- simplImpRules env1 unit_rules' + + let unit_binds1 = getTopFloatBinds floats + pure (CoreCompUnit unit_binds1 unit_rules1, visible_rules1) + + let rules1 = visible_rules1 ++ hidden_rules + go rules1 (unit1 : acc) (counts `plusSimplCount` counts1) rest + + partitionVisibleImpRules :: VarSet -> [CoreRule] -> ([CoreRule], [CoreRule]) + partitionVisibleImpRules unit_bndrs = foldr go_rule ([], []) + where + go_rule rule (visible, hidden) + | rule_mentions_unit = (rule : visible, hidden) + | rule_has_local_fvs = (visible, rule : hidden) + | otherwise = (rule : visible, hidden) + where + local_fvs = ruleFreeVars rule `intersectVarSet` all_local_bndrs + rule_has_local_fvs = not (isEmptyVarSet local_fvs) + rule_mentions_unit = not (isEmptyVarSet (local_fvs `intersectVarSet` unit_bndrs)) + + all_local_bndrs :: VarSet + all_local_bndrs = mkVarSet (bindersOfBinds (concatMap coreCompUnitBinds (dsd_binds dyn))) + dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -794,9 +794,12 @@ specConstrProgram guts scTopCompUnits :: ScEnv -> CoreProgram -> UniqSM (ScUsage, CoreProgram, [SpecFailWarning]) scTopCompUnits _env [] = return (nullUsage, [], []) scTopCompUnits env (CoreCompUnit unit_binds unit_rules:units) = do - (unit_usg, unit_binds', unit_warnings) <- scTopBinds env unit_binds - (units_usg, units', units_warnings) <- scTopCompUnits env units - return (unit_usg `combineUsage` units_usg, CoreCompUnit unit_binds' unit_rules : units', unit_warnings ++ units_warnings) + let unit_env = initScCompUnitEnv env unit_binds + (_unit_usg, unit_binds', unit_warnings) <- scTopBinds unit_env unit_binds + (_units_usg, units', units_warnings) <- scTopCompUnits env units + -- Before CoreMerge, different compilation units may legitimately reuse the + -- same top-level Id/Unique, so we must not combine ScUsage across units. + return (nullUsage, CoreCompUnit unit_binds' unit_rules : units', unit_warnings ++ units_warnings) scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]) scTopBinds _env [] = return (nullUsage, [], []) @@ -1009,18 +1012,19 @@ initScEnv guts ; this_mod <- getModule ; return (SCE { sc_opts = initScOpts dflags this_mod, sc_force = False, - sc_subst = init_subst, + sc_subst = mkEmptySubst emptyInScopeSet, sc_how_bound = emptyVarEnv, sc_vals = emptyVarEnv, sc_annotations = anns }) } + +initScCompUnitEnv :: ScEnv -> [InBind] -> ScEnv +initScCompUnitEnv env unit_binds + = env { sc_subst = mkEmptySubst in_scope } where - init_subst = mkEmptySubst $ foldl' addCompUnitBndrs emptyInScopeSet (mg_binds guts) - -- Acccount for top-level bindings that are not in dependency order; - -- see Note [Glomming] in GHC.Core.Opt.OccurAnal - -- Easiest thing is to bring all the top level binders into scope at once, - -- as if at once, as if all the top-level decls were mutually recursive. - addCompUnitBndrs scope (CoreCompUnit unit_binds _) = - scope `extendInScopeSetBndrs` unit_binds + in_scope = emptyInScopeSet `extendInScopeSetBndrs` unit_binds + -- Account for top-level bindings that are not in dependency order; + -- see Note [Glomming] in GHC.Core.Opt.OccurAnal. + -- Crucially, only add binders from the current compilation unit. data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -1443,7 +1447,8 @@ scBind top_lvl env (NonRec bndr rhs) do_body -- but found some regressions (see !8135). So I backed off. = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs - -- At top level, we've already put all binders into scope; see initScEnv + -- At top level, we've already put the current compilation unit's + -- binders into scope; see initScCompUnitEnv. -- Hence no need to call `extendBndr`. But we still want to -- extend the `ValueEnv` to record the value of this binder. ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs') @@ -1491,7 +1496,8 @@ scBind top_lvl env (Rec prs) do_body (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs) | otherwise = extendRecBndrs env bndrs - -- At top level, we've already put all binders into scope; see initScEnv + -- At top level, we've already put the current compilation unit's + -- binders into scope; see initScCompUnitEnv. rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Unit.Module( Module ) +import GHC.Unit.Module.Deps ( Dependencies ) import GHC.Unit.Module.ModGuts import GHC.Core.Unfold @@ -641,10 +642,9 @@ Hence, the invariant is this: -- | Specialise calls to type-class overloaded functions occurring in a program. specProgram :: ModGuts -> CoreM ModGuts specProgram guts = do - rule_env <- initRuleEnv guts let static = StaticSpecInput { ssi_module = mg_module guts - , ssi_rule_env = rule_env + , ssi_deps = mg_deps guts } dyn = DynamicSpecData { dsd_binds = mg_binds guts @@ -655,7 +655,7 @@ specProgram guts = do data StaticSpecInput = StaticSpecInput { ssi_module :: !Module - , ssi_rule_env :: !RuleEnv + , ssi_deps :: !Dependencies } data DynamicSpecData = DynamicSpecData @@ -680,20 +680,26 @@ specProgram' static dyn -- | Specialise calls to type-class overloaded functions occurring in a program. specCompUnit :: StaticSpecInput -> DynFlags -> CoreCompUnit -> CoreM CoreCompUnit specCompUnit static dflags (CoreCompUnit unit_binds unit_rules) - = do { (unit_binds', uds) <- runSpecM (go unit_binds) + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; let rule_env = mkRuleEnv (ssi_module static) (ssi_deps static) [] [unit] + eps_rules hpt_rules + top_env = SE { se_subst = Core.mkEmptySubst in_scope + , se_module = ssi_module static + , se_rules = rule_env + , se_dflags = dflags } + ; (unit_binds', uds) <- runSpecM (go top_env unit_binds) ; (spec_rules, spec_binds) <- specImports top_env uds ; return (CoreCompUnit (spec_binds ++ unit_binds') (spec_rules ++ unit_rules)) } where - top_env = SE { se_subst = Core.mkEmptySubst in_scope - , se_module = ssi_module static - , se_rules = ssi_rule_env static - , se_dflags = dflags } + unit = CoreCompUnit unit_binds unit_rules in_scope = mkInScopeSetBndrs unit_binds - go [] = return ([], emptyUDs) - go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ -> - go binds - return (bind' ++ binds', uds') + go _ [] = return ([], emptyUDs) + go env (bind:binds) + = do (bind', binds', uds') <- specBind TopLevel env bind $ \_ -> + go env binds + return (bind' ++ binds', uds') {- Note [Wrap bindings returned by specImports] ===================================== compiler/GHC/Core/Opt/Split.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE ViewPatterns #-} + +module GHC.Core.Opt.Split + ( splitCompUnit + , checkNameClashes + ) where + +import GHC.Prelude hiding ( head, init, last ) + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit) + +import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq) +import GHC.Data.Maybe (orElse) + +import GHC.Types.Unique.Set +import GHC.Types.Name (isExternalName, nameModule) +import GHC.Types.Id (realIdUnfolding) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module (Module) + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import Data.List (find) + +{- Note [Splitting core programs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +splitCompUnit splits a single compilation unit into multiple. +To do so we: + +Initially we run OccAnal on the compilation unit. I don't think it's strictly neccessary +but it zaps fragile unfoldings which speeds up and gets rid of glomming. +We will try getting rid of this later. + +We split imported rules into those which only concern imported rules and those mentioning +local binders (called unit_rules). + +Rules mentioning local binders introduce edges between any local binders they mention. + +Next we build the graph nodes from binders: +* Fully nodes have one key, the first Id the binder defines. Their node data is the binder itself. +* Pseudo nodes for every id the binder defines (tail $ bindersOf bind) with no data. + +Now we introduce edges: + * For binders from the first id to all other defined ids and those it mentions as fv + let key = (head bindersOf bind) + let edges = map (\x -> (key, x)) bindersOf bind ++ map (\x -> (key, x)) (bindFreeVars bind) + * For rules if they mention local binders introduce edges between any local binders they mention. + +* All edges computed so far are directional. So we take all edges and also add their reversed version. + +* After this we split the graph into independent components. + +* As the last step we assign each unit rule to a unit from which it mentions variables +-} + +data DepGraphNode + = BindNode + { depNodeKey :: !Var + , depNodeBind :: CoreBind + } + | PseudoNode + { depNodeKey :: !Var } + +type Edge = (Var, Var) + +-- | Is the given variable defined in the given module. +varFromModule :: Module -> Var -> Bool +varFromModule _ var = isLocalId var + +maybeRuleEdges :: Module -> CoreRule -> Maybe [Edge] +maybeRuleEdges this_module rule = + case local_fvs of + [] -> Nothing + [_] -> Just [] + _ -> Just (zip local_fvs (drop 1 local_fvs)) + where + local_fvs = filter (varFromModule this_module) (nonDetEltsUniqSet (ruleFreeVars rule)) + +bindNode :: VarSet -> CoreBind -> ([DepGraphNode], [Edge]) +bindNode local_top_bndrs bind = + case bindersOf bind of + [] -> ([], []) + key:rest -> + let split_fvs = bindSplitFreeVars local_top_bndrs bind + intern_edges = map (\v -> (key, v)) rest + ext_edges = map (\v -> (key, v)) (nonDetEltsUniqSet split_fvs) + node = BindNode key bind + pseudo_nodes = map PseudoNode rest + in (node : pseudo_nodes, intern_edges ++ ext_edges) + +bindSplitFreeVars :: VarSet -> CoreBind -> VarSet +bindSplitFreeVars local_top_bndrs bind = + close_over_imported_unfoldings (bindMentionedVars bind `unionVarSet` bindBndrInfoVars bind) + where + close_over_imported_unfoldings fvs = go emptyVarSet fvs + + go !seen !fvs = + case pick_new_import (fvs `minusVarSet` seen) of + Nothing -> fvs + Just v -> + let unfolding_fvs = unfoldingRefs v + local_unfolding_fvs = unfolding_fvs `intersectVarSet` local_top_bndrs + in go (extendVarSet seen v) (fvs `unionVarSet` local_unfolding_fvs `unionVarSet` unfolding_fvs) + + pick_new_import vars = + find pickable (nonDetEltsUniqSet vars) + + pickable v = isId v && not (v `elemVarSet` local_top_bndrs) + + unfoldingRefs v = + case maybeUnfoldingTemplate (realIdUnfolding v) of + Just rhs -> exprSomeFreeVars (const True) rhs + Nothing -> emptyVarSet + +bindMentionedVars :: CoreBind -> VarSet +bindMentionedVars (NonRec _ rhs) = exprSomeFreeVars (const True) rhs +bindMentionedVars (Rec prs) = exprsSomeFreeVars (const True) (map snd prs) + +bindBndrInfoVars :: CoreBind -> VarSet +bindBndrInfoVars bind = + mkVarSet $ + concatMap (dVarSetElems . bndrRuleAndUnfoldingVarsDSet) (bindersOf bind) + +type Edges = IdEnv [Var] + +-- Split core binders takes directed edges treating them as undirected by adding the reverse edge internally. +splitCoreBinders :: [DepGraphNode] -> [Edge] -> [(VarSet, [CoreBind])] +splitCoreBinders nodes edges = + [ (mkVarSet (concatMap bindersOf binds), binds) + | comp_nodes <- map scc_payloads (stronglyConnCompFromEdgedVerticesUniq (map mk_graph_node nodes)) + , let binds = [ b | BindNode { depNodeBind = b } <- comp_nodes ] + ] + where + key_set = mkVarSet (map depNodeKey nodes) + undirected_edges = foldr add_edge emptyVarEnv (edges ++ map reverse_edge edges) + + add_edge :: Edge -> Edges -> Edges + add_edge (src, dst) env = extendVarEnv_C (++) env src [dst] + + reverse_edge :: Edge -> Edge + reverse_edge (src, dst) = (dst, src) + + mk_graph_node node + = DigraphNode + { node_payload = node + , node_key = varUnique key + , node_dependencies = + [ varUnique dst + | dst <- lookupVarEnv undirected_edges key `orElse` [] + , elemVarSet dst key_set + ] + } + where + key = depNodeKey node + + scc_payloads (AcyclicSCC p) = [p] + scc_payloads (CyclicSCC ps) = ps + +assignLocalRules + :: [CoreRule] + -> [(VarSet, [CoreBind])] + -> ([(VarSet, [CoreBind], [CoreRule])], [CoreRule]) +assignLocalRules unit_rules binder_components = + (components_with_rules, rules_without_component) + where + (component_rule_map, rules_without_component) + = foldr assign_rule (IntMap.empty, []) unit_rules + + assign_rule rule (rule_map, no_comp_rules) + = case rule_comp_indices rule of + [i] -> (IntMap.insertWith (++) i [rule] rule_map, no_comp_rules) + [] -> (rule_map, rule : no_comp_rules) + is -> pprPanic "splitCompUnit" + ( text "Rule free vars span multiple components" + $$ text "rule:" <+> ppr rule + $$ text "components:" <+> ppr is + $$ text "rule_fvs:" <+> pprVarsWithModule (nonDetEltsUniqSet (ruleFreeVars rule)) + $$ vcat [ text "component" <+> int i <> colon <+> ppr hits + | (i, hits) <- comp_hits rule ] ) + + rule_comp_indices rule + = IntSet.toList $ IntSet.fromList + [ i + | ((bndrs, _), i) <- zip binder_components [0..] + , not (isEmptyVarSet (ruleFreeVars rule `intersectVarSet` bndrs)) + ] + + comp_hits rule = + [ (i, ruleFreeVars rule `intersectVarSet` bndrs) + | ((bndrs, _), i) <- zip binder_components [0..] + , not (isEmptyVarSet (ruleFreeVars rule `intersectVarSet` bndrs)) + ] + + components_with_rules = + [ (bndrs, binds, IntMap.findWithDefault [] i component_rule_map) + | ((bndrs, binds), i) <- zip binder_components [0..] + ] + +pprVarsWithModule :: [Var] -> SDoc +pprVarsWithModule vars = braces (fsep (punctuate comma (map pprVarWithModule vars))) + +pprVarWithModule :: Var -> SDoc +pprVarWithModule v + | isExternalName n = ppr v <+> parens (ppr (nameModule n)) + | otherwise = ppr v + where + n = varName v + +-- After optimizations a rule might no longer reference binders from this module. +-- In these cases we return them here and then add them to mg_rules. +splitCompUnit :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule]) +splitCompUnit this_module imp_rules unit + = let comp_units = map mk_comp_unit components_with_rules + in checkNameClashes comp_units `seq` + (comp_units, rules_for_imps ++ rules_without_component) + where + CoreCompUnit occ_binds unit_rules = + occurAnalyseCompUnit this_module (const True) (const True) imp_rules unit + + top_level_bndrs = bindersOfBinds occ_binds + checked_bndrs = + assertPpr (all isLocalVar top_level_bndrs) + ( text "splitCompUnit: non-local top-level binder(s)" + $$ ppr top_level_bndrs ) + top_level_bndrs + + local_top_bndrs = mkVarSet checked_bndrs + + (bind_nodes, bind_edges) + = checked_bndrs `seq` + foldr (\b (ns, es) -> let (ns', es') = bindNode local_top_bndrs b in (ns' ++ ns, es' ++ es)) + ([], []) + occ_binds + + rule_edge_pairs = [ (r, maybeRuleEdges this_module r) | r <- unit_rules ] + rule_edges = concat [ es | (_, Just es) <- rule_edge_pairs ] + rules_for_imps = [ r | (r, Nothing) <- rule_edge_pairs ] + unit_rules_local = [ r | (r, Just _) <- rule_edge_pairs ] + + all_edges = bind_edges ++ rule_edges + binder_components = splitCoreBinders bind_nodes all_edges + (components_with_rules, rules_without_component) = + assignLocalRules unit_rules_local binder_components + + mk_comp_unit (_, binds, rules) = CoreCompUnit binds rules + +checkNameClashes :: [CoreCompUnit] -> () +checkNameClashes comp_units + | null dup_bndrs = () + | otherwise + = pprPanic "checkNameClashes" + ( text "Duplicate top-level binders across split compilation units" + $$ ppr dup_bndrs ) + where + all_bndrs = concatMap (bindersOfBinds . coreCompUnitBinds) comp_units + + dup_bndrs :: [Var] + dup_bndrs = go emptyVarSet all_bndrs + + go _ [] = [] + go seen (b:bs) + | b `elemVarSet` seen = b : go seen bs + | otherwise = go (extendVarSet seen b) bs ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -205,7 +205,8 @@ simpleOptPgm opts this_mod binds rules = do_unit (env, comp_units') (CoreCompUnit unit_binds unit_rules) = let (env', unit_binds') = foldl' do_one (env, []) unit_binds - in (env', CoreCompUnit (reverse unit_binds') unit_rules : comp_units') + unit_rules' = map (substRule (soe_subst env') id) unit_rules + in (env', CoreCompUnit (reverse unit_binds') unit_rules' : comp_units') do_one (env, binds') bind = case simple_opt_bind env bind TopLevel of ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Core.Subst ( -- ** Substituting into expressions and related types deShadowBinds, deShadowCompUnits, - substRuleInfo, substRulesForImportedIds, + substRule, substRuleInfo, substRulesForImportedIds, substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, ===================================== compiler/ghc.cabal.in ===================================== @@ -393,6 +393,7 @@ Library GHC.Core.Opt.Simplify.Utils GHC.Core.Opt.SpecConstr GHC.Core.Opt.Specialise + GHC.Core.Opt.Split GHC.Core.Opt.StaticArgs GHC.Core.Opt.Stats GHC.Core.Opt.WorkWrap ===================================== testsuite/driver/testlib.py ===================================== @@ -2842,7 +2842,21 @@ def _normalised_outputs(expected_file: Path, return expected, actual def _sorted_lines(s: str) -> str: - return '\n'.join(sorted(s.splitlines())) + return '\n'.join(sorted(_drop_split_comp_unit_headers(s.splitlines()))) + +def _drop_split_comp_unit_headers(lines: List[str]) -> List[str]: + kept: List[str] = [] + i = 0 + while i < len(lines): + # Ignore an empty line immediately followed by the split-core unit header. + if i + 1 < len(lines) \ + and lines[i] == '' \ + and lines[i + 1].startswith('=== Start of new compilation unit'): + i += 2 + continue + kept.append(lines[i]) + i += 1 + return kept def _is_reordered_output_mismatch(expected_file: Path, actual_file: Path, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/452dc62605ce22373b537529ae385d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/452dc62605ce22373b537529ae385d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/regression-tests-3] 25 commits: Correct `hIsReadable` and `hIsWritable` for duplex handles
by Simon Jakobi (＠sjakobi2) 08 Mar '26

08 Mar '26

Simon Jakobi pushed to branch wip/sjakobi/regression-tests-3 at Glasgow Haskell Compiler / GHC Commits: 598db847 by Wolfgang Jeltsch at 2026-03-06T06:25:25-05:00 Correct `hIsReadable` and `hIsWritable` for duplex handles This contribution implements CLC proposal #371. It changes `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. - - - - - b90201e5 by Wolfgang Jeltsch at 2026-03-06T06:25:25-05:00 Document `SemiClosedHandle` - - - - - c9df72b5 by Wolfgang Jeltsch at 2026-03-06T06:25:25-05:00 Tell users what “semi-closed” means for duplex handles - - - - - a8aa1868 by Ilias Tsitsimpis at 2026-03-06T06:26:29-05:00 Fix determinism of linker arguments The switch from Data.Map to UniqMap in 3b5be05ac29 introduced non-determinism in the order of packages passed to the linker. This resulted in non-reproducible builds where the DT_NEEDED entries in dynamic libraries were ordered differently across builds. Fix the regression by explicitly sorting the package list derived from UniqMap. Fixes #26838 - - - - - 9b64ad3a by Matthew Pickering at 2026-03-06T06:27:16-05:00 determinism: Use a deterministic renaming when writing bytecode files Now when writing the bytecode file, a counter and substitution are used to provide deterministic keys to local variables (rather than relying on uniques). This change ensures that `.gbc` are produced deterministically. Fixes #26499 - - - - - d29800e0 by Teo Camarasu at 2026-03-06T06:28:46-05:00 ghc-internal: delete Version hs-boot loop Version has a Read instance which needs Unicode but part of the Unicode interface is the unicode version. This is easy to resolve. We simply don't re-export the version from the Unicode module. Resolves #26940 - - - - - ad25af90 by Sylvain Henry at 2026-03-06T06:30:33-05:00 Linker: implement support for COMMON symbols (#6107) Add some support for COMMON symbols. We don't support common symbols having different sizes where the larger one is allocated after the smaller one. The linker will fail with an appropriate error message if it happens. - - - - - 3b59f158 by Cheng Shao at 2026-03-06T06:31:16-05:00 compiler: fix redundant import of GHC.Hs.Lit This patch removes a redundant import of `GHC.Hs.Lit` which causes a ghc build failure with validate flavours when bootstrapping from 9.14. Fixes #26972. - - - - - 148d36f3 by Cheng Shao at 2026-03-06T06:32:01-05:00 compiler: avoid unneeded traversals in GHC.Unit.State Following !15591, this patch avoids unneeded traversals in `reportCycles`/`reportUnusable` when log verbosity is below given threshold. Also applies `logVerbAtLeast` when appropriate. Co-authored-by: Codex <codex(a)openai.com> - - - - - 7e31367c by Cheng Shao at 2026-03-06T06:32:46-05:00 ghc-internal: fix redundant import in GHC.Internal.Event.Windows.ManagedThreadPool This patch fixes redundant import in `GHC.Internal.Event.Windows.ManagedThreadPool` that causes a compilation error when building windows target with validate flavours and bootstrapping from 9.14. Fixes #26976. - - - - - fc8b8e27 by sheaf at 2026-03-06T06:33:28-05:00 System.Info.fullCompilerVersion: add 'since' annot Fixes #26973 - - - - - c8238375 by Sylvain Henry at 2026-03-06T06:34:23-05:00 Hadrian: deprecate --bignum and automatically enable +native_bignum for JS Deprecate --bignum=... to select the bignum backend. It's only used to select the native backend, and this can be done with the +native_bignum flavour transformer. Additionally, we automatically enable +native_bignum for the JS target because the GMP backend isn't supported. - - - - - a3ac7074 by Sylvain Henry at 2026-03-06T06:35:17-05:00 JS: fix putEnum/fromEnum (#24593) Don't go through Word16 when serializing Enums. - - - - - 0b36e96c by Andreas Klebinger at 2026-03-06T06:35:58-05:00 Docs: Document -fworker-wrapper-cbv default setting. Fixes #26841 - - - - - eca445e7 by mangoiv at 2026-03-07T05:02:36-05:00 drop deb9/10 from CI, add deb13 debian 9 and 10 are end of life, hence we drop them from our CI, but we do add debian 13. Jobs that were previously run on 9 and 10 run on 13, too, jobs that were run on 10, are run on 11 now. Jobs that were previously run on debian 12 are run on debian 13 now. This MR also updates hadrian's bootstrap plans for that reason. Metric Decrease: T9872d - - - - - 12f8b829 by Luite Stegeman at 2026-03-07T05:03:33-05:00 Fix GHC.Internal.Prim haddock Haddock used to parse Haskell source to generate documentation, but switched to using interface files instead. This broke documentation of the GHC.Internal.Prim module, since it's a wired-in interface that didn't provide a document structure. This patch adds the missing document structure and updates genprimopcode to make the section headers and descriptions available. fixes #26954 - - - - - f87e5e57 by Luite Stegeman at 2026-03-07T05:03:33-05:00 Remove obsolete --make-haskell-source from genprimopcode Now that haddock uses the wired-in interface for GHC.Internal.Prim, the generated Haskell source file is no longer needed. Remove the --make-haskell-source code generator from genprimopcode and replace the generated GHC/Internal/Prim.hs with a minimal static source file. - - - - - 4a7ddc7b by Sylvain Henry at 2026-03-07T05:04:59-05:00 JS: fix linking of exposed but non-preload units (#24886) Units exposed in the unit database but not explicitly passed on the command-line were not considered by the JS linker. This isn't an issue for cabal which passes every unit explicitly but it is an issue when using GHC directly (cf T24886 test). - - - - - 689aafcd by mangoiv at 2026-03-07T05:05:52-05:00 testsuite: double foundation timeout multiplier The runtime timeout in the foundation test was regularly hit by code generated by the wasm backend - we increase the timout since the high runtime is expected on the wasm backend for this rather complex test. Resolves #26938 - - - - - eaa1efd1 by Simon Jakobi at 2026-03-08T16:22:24+01:00 Add regression test for #12002 Closes #12002. - - - - - 6892f1b8 by Simon Jakobi at 2026-03-08T16:22:24+01:00 Add regression test for #12046 Closes #12046. - - - - - f6b6d503 by Simon Jakobi at 2026-03-08T16:22:24+01:00 Add regression test for #13180 Closes #13180. - - - - - e0cb53b2 by Simon Jakobi at 2026-03-08T16:22:24+01:00 Add regression test for #11141 Closes #11141. - - - - - 18cad266 by Simon Jakobi at 2026-03-08T16:22:52+01:00 Add regression test for #11505 Closes #11505. - - - - - 9c6f11b6 by Simon Jakobi at 2026-03-08T16:23:10+01:00 Add regression perf test for #13820 Closes #13820. - - - - - 87 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Error.hs - docs/users_guide/using-optimisation.rst - hadrian/README.md - hadrian/bootstrap/generate_bootstrap_plans - hadrian/bootstrap/plan-9_10_1.json - hadrian/bootstrap/plan-9_10_2.json - + hadrian/bootstrap/plan-9_10_3.json - hadrian/bootstrap/plan-bootstrap-9_10_1.json - hadrian/bootstrap/plan-bootstrap-9_10_2.json - + hadrian/bootstrap/plan-bootstrap-9_10_3.json - hadrian/src/CommandLine.hs - hadrian/src/Main.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/GenPrimopCode.hs - libraries/base/changelog.md - libraries/base/src/GHC/Unicode.hs - libraries/base/src/System/Info.hs - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Version.hs-boot - libraries/ghc-internal/src/GHC/Internal/Event/Windows/ManagedThreadPool.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs - + libraries/ghc-internal/src/GHC/Internal/Prim.hs - libraries/ghc-internal/src/GHC/Internal/Unicode.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Version.hs - libraries/ghc-internal/tools/ucd2haskell/exe/UCD2Haskell/ModuleGenerators.hs - rts/Linker.c - rts/LinkerInternals.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c - testsuite/driver/perf_notes.py - testsuite/tests/ghci/should_run/all.T - + testsuite/tests/javascript/T24886.hs - + testsuite/tests/javascript/T24886.stderr - + testsuite/tests/javascript/T24886.stdout - testsuite/tests/javascript/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/overloadedrecflds/should_compile/all.T - testsuite/tests/overloadedrecflds/should_run/all.T - + testsuite/tests/parser/should_compile/T12002.hs - + testsuite/tests/parser/should_compile/T12002.stderr - testsuite/tests/parser/should_compile/all.T - + testsuite/tests/perf/compiler/T13820.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/pmcheck/should_compile/T11303.hs - testsuite/tests/quasiquotation/qq005/test.T - testsuite/tests/quasiquotation/qq006/test.T - testsuite/tests/rts/linker/Makefile - + testsuite/tests/rts/linker/T6107.hs - + testsuite/tests/rts/linker/T6107.stdout - + testsuite/tests/rts/linker/T6107_sym1.s - + testsuite/tests/rts/linker/T6107_sym2.s - testsuite/tests/rts/linker/all.T - testsuite/tests/saks/should_compile/all.T - testsuite/tests/showIface/all.T - testsuite/tests/th/all.T - + testsuite/tests/typecheck/T13180/T13180.hs - + testsuite/tests/typecheck/T13180/T13180.hs-boot - + testsuite/tests/typecheck/T13180/T13180.stderr - + testsuite/tests/typecheck/T13180/T13180A.hs - + testsuite/tests/typecheck/T13180/all.T - + testsuite/tests/typecheck/should_compile/T11141.hs - + testsuite/tests/typecheck/should_compile/T11141.stderr - + testsuite/tests/typecheck/should_compile/T11505Bar.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs-boot - + testsuite/tests/typecheck/should_compile/T12046.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/vdq-rta/should_compile/all.T - utils/genprimopcode/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57692b7286fa323fb5ad7845cbb8ce… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57692b7286fa323fb5ad7845cbb8ce… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T16122] Add regression test for #16122
by Simon Jakobi (＠sjakobi2) 08 Mar '26

08 Mar '26

Simon Jakobi pushed to branch wip/sjakobi/T16122 at Glasgow Haskell Compiler / GHC Commits: 0159e431 by Simon Jakobi at 2026-03-08T15:25:37+01:00 Add regression test for #16122 - - - - - 3 changed files: - + testsuite/tests/simplCore/should_compile/T16122.hs - + testsuite/tests/simplCore/should_compile/T16122.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== testsuite/tests/simplCore/should_compile/T16122.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeApplications #-} +-- Test that the Core for f isn't "worse" than g's. +-- The optimized Core for f used to involve dictionary-passing. See #16122. +module T16122 (f, g) where + +import Data.Int (Int64) + +f :: Double -> Int64 +f = round + +g :: Double -> Int64 +g = fromIntegral @Int @Int64 . round ===================================== testsuite/tests/simplCore/should_compile/T16122.stderr ===================================== @@ -0,0 +1,26 @@ +f = \ x -> + I64# + (case x of { D# ds1 -> + case {__ffi_static_ccall_unsafe ghc-internal:rintDouble :: Double# + -> State# RealWorld + -> (# State# RealWorld, Double# #)} + ds1 realWorld# + of + { (# _, ds3 #) -> + intToInt64# (double2Int# ds3) + } + }) + +g = \ x -> + I64# + (case x of { D# ds1 -> + case {__ffi_static_ccall_unsafe ghc-internal:rintDouble :: Double# + -> State# RealWorld + -> (# State# RealWorld, Double# #)} + ds1 realWorld# + of + { (# _, ds3 #) -> + intToInt64# (double2Int# ds3) + } + }) + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -295,6 +295,10 @@ test('T15631', normal, makefile_test, ['T15631']) test('T15673', normal, compile, ['-O']) +test('T16122', [when(wordsize(32), skip)], + multimod_compile_filter, + ['T16122', '-O -ddump-simpl -dsuppress-all -dsuppress-uniques -dno-typeable-binds', + "sed -n '/^f = /,/^$/p;/^g = /,/^$/p'"]) test('T16288', normal, multimod_compile, ['T16288B', '-O -dcore-lint -v0']) test('T16348', normal, compile, ['-O']) test('T16918', normal, compile, ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0159e43152e2b43529c3b56ad7cdaac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0159e43152e2b43529c3b56ad7cdaac… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ci-validate-aarch64-only-deb13
by Cheng Shao (＠TerrorJack) 08 Mar '26

08 Mar '26

Cheng Shao pushed new branch wip/ci-validate-aarch64-only-deb13 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ci-validate-aarch64-only-deb13 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: compiler: add myCapabilityExpr to GHC.Cmm.Utils
by Marge Bot (＠marge-bot) 08 Mar '26

08 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b2c7d84a by Cheng Shao at 2026-03-08T09:15:38-04:00 compiler: add myCapabilityExpr to GHC.Cmm.Utils This commit adds `myCapabilityExpr` to `GHC.Cmm.Utils` which is computed from `BaseReg`. It's convenient for codegen logic where one needs to pass the current Capability's pointer. - - - - - 54feacf8 by Cheng Shao at 2026-03-08T09:15:38-04:00 compiler: lower tryPutMVar# into a ccall directly This patch addresses an old TODO of `stg_tryPutMVarzh` by removing it completely and making the compiler lower `tryPutMVar#` into a ccall to `performTryPutMVar` directly, without landing into an intermediate C or Cmm function. `performTryPutMVar` is promoted to a public RTS function with default visibility, and the compiler lowering logic takes into account the C ABI of `performTryPutMVar` and converts from C Bool to primop's `Int#` result properly. - - - - - b9170164 by Simon Hengel at 2026-03-08T09:15:40-04:00 Don't use #line in haddocks This confuses the parser. Haddock output is unaffected by this change. (read: this still produces the same documentation) - - - - - a7dbb151 by Wolfgang Jeltsch at 2026-03-08T09:15:41-04:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Tighten the dependencies of `GHCi.Helpers` * Move some code that needs `System.IO` to `template-haskell` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `System.IO.OS` implementation into `base` Metric Decrease: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip - - - - - 45fd5f33 by Duncan Coutts at 2026-03-08T09:15:52-04:00 Apply NOINLINE pragmas to generated Typeable bindings For context, see the existing Note [Grand plan for Typeable] and the Note [NOINLINE on generated Typeable bindings] added in the subsequent commit. This is about reducing the number of exported top level names and unfoldings, which reduces interface file sizes and reduces the number of global/dynamic linker symbols. Also accept the changed test output and metric decreases. Tests that record the phase output for type checking or for simplifier end up with different output: the generated bindings now have an Inline [~] annotation, and many top level names are now local rather than module-prefixed for export. Also accept the numerous metric decreases in compile_time/bytes allocated, and a few in compile_time/max_bytes_used. There's also one instance of a decrease in runtime/max_bytes_used but it's a ghci-way test and so presumably the reason is that it loads smaller .hi files and/or links fewer symbols. ------------------------- Metric Decrease: CoOpt_Singletons MultiLayerModulesTH_OneShot MultilineStringsPerf T10421 T10547 T12150 T12227 T12234 T12425 T13035 T13056 T13253 T13253-spj T15703 T16875 T17836b T17977b T18140 T18223 T18282 T18304 T18698a T18698b T18730 T18923 T20049 T21839c T24471 T24582 T24984 T3064 T4029 T5030 T5642 T5837 T6048 T9020 T9198 T9961 TcPlugin_RewritePerf WWRec hard_hole_fits mhu-perf ------------------------- - - - - - f69620da by Duncan Coutts at 2026-03-08T09:15:53-04:00 Add documentation Note [NOINLINE on generated Typeable bindings] and refer to it from the code and existing documentation. - - - - - 3de7def6 by Duncan Coutts at 2026-03-08T09:15:53-04:00 Switch existing note to "named wrinkle" style, (GPT1)..(GPT7) GPT = Grand plan for Typeable - - - - - 1014e174 by Sylvain Henry at 2026-03-08T09:16:00-04:00 T18832: fix Windows CI failure by dropping removeDirectoryRecursive On Windows, open file handles prevent deletion. After killThread, the closer thread may not have called hClose yet, causing removeDirectoryRecursive to fail with "permission denied". The test harness cleans up the run directory anyway, so the call is redundant. - - - - - a35e3fcd by Cheng Shao at 2026-03-08T09:16:01-04:00 compiler: fix redundant import in GHC.StgToJS.Object This patch fixes a redundant import in GHC.StgToJS.Object that causes a build failure when compiling head from 9.14 with validate flavours. Fixes #26991. - - - - - a2567c46 by Cheng Shao at 2026-03-08T09:16:02-04:00 wasm: fix `Illegal foreign declaration` failure when ghci loads modules with JSFFI exports This patch fixes a wasm ghci error when loading modules with JSFFI exports; the `backendValidityOfCExport` check in `tcCheckFEType` should only makes sense and should be performed when not checking the JavaScript calling convention; otherwise, when the calling convention is JavaScript, the codegen logic should be trusted to backends that actually make use of it. Fixes #26998. - - - - - 57 changed files: - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/Tc/Gen/Foreign.hs - compiler/GHC/Tc/Instance/Typeable.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/base/tests/IO/T18832.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/Threads.c - rts/Threads.h - rts/include/rts/Threads.h - rts/include/stg/MiscClosures.h - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/dmdanal/should_compile/T16029.stdout - testsuite/tests/ffi/should_compile/all.T - + testsuite/tests/ghci-wasm/T26998.hs - testsuite/tests/ghci-wasm/all.T - testsuite/tests/numeric/should_compile/T14170.stdout - testsuite/tests/numeric/should_compile/T14465.stdout - testsuite/tests/numeric/should_compile/T7116.stdout - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles13.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr - testsuite/tests/simplCore/should_compile/T3717.stderr - testsuite/tests/simplCore/should_compile/T3772.stdout - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/T4930.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/T8274.stdout - testsuite/tests/simplCore/should_compile/T9400.stderr - testsuite/tests/simplCore/should_compile/noinline01.stderr - testsuite/tests/simplCore/should_compile/par01.stderr - testsuite/tests/th/TH_Roles2.stderr - testsuite/tests/typecheck/should_compile/T13032.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/881f34f32a9fc2eda67eb839084fa4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/881f34f32a9fc2eda67eb839084fa4… You're receiving this email because of your account on gitlab.haskell.org.

1 0