August 2026 - ghc-commits

[Git][ghc/ghc][master] EPA: Remove LocatedP from CType
by Marge Bot (＠marge-bot) 03 Aug '26

03 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d415f38a by Alan Zimmerman at 2026-08-02T22:47:27-04:00 EPA: Remove LocatedP from CType The next step of removing use of LocatedP by moving the AnnPragma for CType into its TTG extension point instead. - - - - - 6 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/ForeignCall.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1583,7 +1583,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Parser.y ===================================== @@ -1707,15 +1707,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . packHText + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -349,6 +351,7 @@ instance Binary CTypeGhc where return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = noAnn } instance NFData StaticTargetGhc where ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -4401,13 +4401,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4415,7 +4416,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -837,7 +837,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d415f38a75cc88921a344220ad2eed0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d415f38a75cc88921a344220ad2eed0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] 2 commits: Apply oneShot Monad trick to STG LintM
by Marge Bot (＠marge-bot) 03 Aug '26

03 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4f2a21f7 by Andreas Klebinger at 2026-08-02T22:46:46-04:00 Apply oneShot Monad trick to STG LintM - - - - - 21e4b89d by Andreas Klebinger at 2026-08-02T22:46:46-04:00 stgLint: Use a single reader env for read only arguments. - - - - - 1 changed file: - compiler/GHC/Stg/Lint.hs Changes: ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -92,6 +92,7 @@ be ill-typed in Core. But it must still be well-kinded! -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module GHC.Stg.Lint ( lintStgTopBindings ) where @@ -123,6 +124,7 @@ import GHC.Unit.Module ( Module ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Monad +import GHC.Exts ( oneShot ) import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) @@ -432,17 +434,40 @@ The Lint monad ************************************************************************ -} -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> DiagOpts -- Diagnostic options - -> StgPprOpts -- Pretty-printing options +data LintReaderEnv = LintReaderEnv + { le_mod :: !Module + , le_flags :: !LintFlags + , le_diag_opts :: !DiagOpts -- Diagnostic options + , le_ppr_opts :: !StgPprOpts -- Pretty-printing options + } + +newtype LintM a = LintM' + { unLintM :: LintReaderEnv -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag SDoc -- Error messages so far -> (a, Bag SDoc) -- Result and error messages (if any) } - deriving (Functor) +instance Functor LintM where + fmap f (LintM m) = + LintM $ \env loc scope errs -> + case m env loc scope errs of + (a, errs') -> (f a, errs') + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE LintM #-} +pattern LintM :: (LintReaderEnv + -> [LintLocInfo] + -> IdSet + -> Bag SDoc + -> (a, Bag SDoc)) + -> LintM a +pattern LintM m <- LintM' m + where + LintM m = LintM' $ oneShot (\env -> oneShot + (\loc -> oneShot + (\scope -> oneShot + (\errs -> m env loc scope errs)))) data LintFlags = LintFlags { lf_unarised :: !Bool , lf_platform :: !Platform @@ -473,14 +498,16 @@ pp_binders bs initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL platform diag_opts this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag + let !flags = LintFlags unarised platform + !env = LintReaderEnv this_mod flags diag_opts opts + (_, errs) = m env [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where - pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) + pure a = LintM $ \_env _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -489,14 +516,14 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' +thenL m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (r, errs') -> unLintM (k r) env loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' +thenL_ m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (_, errs') -> unLintM k env loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -525,7 +552,8 @@ checkPostUnariseId id id_ty = idType id addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) +addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs + -> ((), addErr df errs msg loc) addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr diag_opts errs_so_far msg locs @@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs - -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \env loc scope errs + -> unLintM m env (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs +addInScopeVars ids m = LintM $ \env loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs + in unLintM m env loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) +getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts -getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) +getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs +checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a34a0054b95fcd7a9717b8b41a7b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9a34a0054b95fcd7a9717b8b41a7b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/int-index/rta-patsyn] Discard type arguments in tcPatToExpr (#27440, #27583)
by Vladislav Zavialov (＠int-index) 02 Aug '26

02 Aug '26

Vladislav Zavialov pushed to branch wip/int-index/rta-patsyn at Glasgow Haskell Compiler / GHC Commits: 5bc2ffd0 by Vladislav Zavialov at 2026-08-02T23:02:30+03:00 Discard type arguments in tcPatToExpr (#27440, #27583) The builder expression of an implicitly bidirectional pattern synonym must not mention types written in the RHS: * Invisible type arguments led to a panic (#27440) * Required type arguments failed with out-of-scope variables (#27583) Both are now discarded, following the precedent established by pattern signatures (#9867). Discarding type arguments takes some care: a type pattern cannot be told from a value pattern by syntax alone, as the `type` keyword may be omitted. Consider: data T a b c where MkT :: forall a. forall b c -> a -> T a b c pattern P :: x -> T x y z pattern P x = MkT @a (type b) c x In P's right-hand side, `@a` and `type b` are clearly type arguments, but what about `c` and `x`? We can only tell by matching the patterns against MkT's type. So tcPatToExpr now runs in TcM and matches the arguments against the constructor's TyVarBinders using zipPatsBndrs, which is made public for this purpose. The resulting builder is $bP x = MkT _ _ x. See Note [Discarding types in the builder expression]. Test cases: T27440a T27440b T27440c T27440d T27440e T27583a T27583b T27583c T27583d T27583e T27583f T27583g Assisted-by: Claude Opus 5 - - - - - 23 changed files: - + changelog.d/T27440 - + changelog.d/T27583 - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - + testsuite/tests/patsyn/should_compile/T27440a.hs - + testsuite/tests/patsyn/should_compile/T27440b.hs - + testsuite/tests/patsyn/should_compile/T27440c.hs - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T27440d.hs - + testsuite/tests/patsyn/should_fail/T27440d.stderr - testsuite/tests/patsyn/should_fail/all.T - + testsuite/tests/vdq-rta/should_compile/T27583a.hs - + testsuite/tests/vdq-rta/should_compile/T27583b.hs - + testsuite/tests/vdq-rta/should_compile/T27583c.hs - + testsuite/tests/vdq-rta/should_compile/T27583d.hs - + testsuite/tests/vdq-rta/should_compile/T27583e.hs - + testsuite/tests/vdq-rta/should_compile/T27583g.hs - testsuite/tests/vdq-rta/should_compile/all.T - + testsuite/tests/vdq-rta/should_fail/T27440e.hs - + testsuite/tests/vdq-rta/should_fail/T27440e.stderr - + testsuite/tests/vdq-rta/should_fail/T27583f.hs - + testsuite/tests/vdq-rta/should_fail/T27583f.stderr - testsuite/tests/vdq-rta/should_fail/all.T Changes: ===================================== changelog.d/T27440 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27440 +mrs: !16434 +synopsis: + Fix a panic on ``@ty`` in a pattern synonym RHS +description: + An invisible type argument (``@ty``) in the right-hand side of an implicitly + bidirectional pattern synonym no longer causes a panic. ===================================== changelog.d/T27583 ===================================== @@ -0,0 +1,9 @@ +section: compiler +issues: #27583 +mrs: !16434 +synopsis: + Fix spurious out-of-scope errors from ``type ty`` in a pattern synonym RHS +description: + A required type argument with an explicit namespace specifier (``type ty``) + in the right-hand side of an implicitly bidirectional pattern synonym no + longer reports variables bound by the pattern as out of scope. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -16,6 +16,7 @@ module GHC.Tc.Gen.Pat , tcCheckPat, tcCheckPat_O, tcInferPat , tcMatchPats , addDataConStupidTheta + , zipPatsBndrs ) where @@ -1727,7 +1728,7 @@ split_con_ty_args :: LexicalFixity -- How to wrap value arguments , [(HsTyPat GhcRn, TyVar)] -- Existentials , HsConPatDetails GhcRn ) -- Value arguments split_con_ty_args fixity con_like arg_pats = do - (bndr_ty_arg_prs, value_args) <- zip_pats_bndrs arg_pats (conLikeUserTyVarBinders con_like) + (bndr_ty_arg_prs, value_args) <- zipPatsBndrs arg_pats (conLikeUserTyVarBinders con_like) return $ if null ex_tvs -- Short cut common case then (bndr_ty_arg_prs, [], mk_details fixity value_args) else let (ex_prs, univ_prs) = partition is_existential bndr_ty_arg_prs @@ -1743,24 +1744,75 @@ split_con_ty_args fixity con_like arg_pats = do -- InfixCon becomes PrefixCon if there are fewer than 2 value arguments. -- Test case: T25127_infix -zip_pats_bndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) -zip_pats_bndrs (L loc pat : pats) (Bndr tv vis : tvbs) +-- | Line the arguments of a 'ConPat' up against the 'TyVarBinder's of its +-- 'ConLike', returning the type arguments with the binders they instantiate, +-- and the remaining value arguments. +-- +-- See Note [Zipping ConPat arguments with TyVarBinders] +-- +-- Precondition: 'check_con_pat_arity' has passed for these arguments, so that +-- we never run out of patterns while a required binder remains. +zipPatsBndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) +zipPatsBndrs (L loc pat : pats) (Bndr tv vis : tvbs) | isVisibleForAllTyFlag vis = do { tp <- setSrcSpanA loc $ pat_to_type_pat pat - ; (prs, pats') <- zip_pats_bndrs pats tvbs + ; (prs, pats') <- zipPatsBndrs pats tvbs ; return ((tp, tv) : prs, pats') } | InvisPat pat_spec tp <- pat , Invisible spec <- vis , pat_spec == spec - = do { (prs, pats') <- zip_pats_bndrs pats tvbs + = do { (prs, pats') <- zipPatsBndrs pats tvbs ; return ((tp, tv):prs, pats') } -zip_pats_bndrs pats (Bndr _ vis : tvbs) - -- zip_pats_bndrs [] (Bndr _ Required : tvbs) +zipPatsBndrs pats (Bndr _ vis : tvbs) + -- zipPatsBndrs [] (Bndr _ Required : tvbs) -- is ruled out by the arity check in splitConTyArgs, -- so we can assume (isInvisibleForAllTyFlag vis) = do { massert (isInvisibleForAllTyFlag vis) - ; zip_pats_bndrs pats tvbs } -zip_pats_bndrs pats [] = return ([], pats) + ; zipPatsBndrs pats tvbs } +zipPatsBndrs pats [] = return ([], pats) + +{- Note [Zipping ConPat arguments with TyVarBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The zipPatsBndrs function allows us to line up the arguments of a constructor +pattern `MkT p1 p2 ... pn` with the TyVarBinders of MkT's type. Consider + + MkT :: forall a b. forall c d -> a -> T a b c d + +Then, in a pattern match `MkT @s (type t) p q`, we have the following +correspondence: + + * pattern `@s` with the TyVarBinder `forall a.` + * no pattern with the TyVarBinder `forall b.` + * pattern `type t` with the TyVarBinder `forall c ->` + * pattern `p` with the TyVarBinder `forall d ->` + * pattern `q` is the one remaining value argument + +Note how `p` and `q` are exactly alike, and only the TyVarBinder can tell us +that `p` is a required type argument rather than a value argument. + +So the call (zipPatsBndrs pats tvbs) with the inputs + + pats = [@s, type t, p, q] + tvbs = [Bndr a Spec, Bndr b Spec, Bndr c Req, Bndr d Req] + +produces the following (ty_pats, val_pats) outputs: + + ty_pats = [(s, a), (t, c), (p, d)] + val_pats = [q] -- remaining value arguments + +Note that the ty_pats components are stripped: the type patterns have lost the +`@` or the `type` herald, and the binders have been reduced to their TyVars. + +This is currently used in two ways: + +1. In tcDataConPat/tcPatSynPat (via splitConTyArgs) to pass the type arguments + onto tcConTyArgs and the value arguments onto tcConValArgs. + See Note [Type applications in patterns] for more details. + +2. In tcPatToExpr, to discard the type arguments in the RHS of an implicitly + bidirectional pattern synonym, keeping only the value arguments. + See Note [Discarding types in the builder expression] in GHC.Tc.TyCl.PatSyn. +-} tcConTyArgs :: Subst -> PatEnv -> [(HsTyPat GhcRn, TyVar)] -> TcM a -> TcM a ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -940,11 +940,9 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) | isUnidirectional dir = return [] - | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why - - | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn ps_name + | otherwise -- Bidirectional + = do { match_group <- get_match_group + ; patsyn <- tcLookupPatSyn ps_name ; case patSynBuilder patsyn of { Nothing -> return [] ; -- This case happens if we found a type error in the @@ -985,10 +983,10 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) ; return builder_binds } } } where - mb_match_group + get_match_group = case dir of - ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) + ExplicitBidirectional explicit_mg -> return explicit_mg + ImplicitBidirectional -> mk_mg <$> tcPatToExpr ps_name args lpat Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -1032,44 +1030,53 @@ add_void need_dummy_arg ty | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: [LocatedN Name] -> LPat GhcRn - -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) +tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn -> TcM (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the -- input uses constructors from HsPat and the output uses constructors -- from HsExpr. -- --- Returns (Left r) if the pattern is not invertible, for reason r. +-- Fails with TcRnPatSynInvalidRhs if the pattern is not invertible. -- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr args pat = go pat +tcPatToExpr ps_name args pat = go pat where lhsVars = mkNameSet (map unLoc args) + invalidRhs :: PatSynInvalidRhsReason -> TcM a + invalidRhs why = setSrcSpan (getLocA pat) $ + failWithTc $ TcRnPatSynInvalidRhs ps_name pat args why + -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: LocatedN (WithUserRdr Name) -> [LPat GhcRn] - -> Either PatSynInvalidRhsReason (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats - = do { exprs <- mapM go pats + -> TcM (HsExpr GhcRn) + mkPrefixConExpr lcon@(L loc con_name) pats + = do { con_like <- tcLookupConLike con_name + ; let tvbs = conLikeUserTyVarBinders con_like + ; (_ty_pats, val_pats) <- zipPatsBndrs pats tvbs + -- Type arguments _ty_pats are discarded, just like the SigPat's type. + -- See Note [Discarding types in the builder expression] + ; let ty_exprs = [wildCardTyArg | tvb <- tvbs, isVisibleForAllTyBinder tvb] + -- Placeholders `_` for the discarded required type arguments. + ; val_exprs <- mapM go val_pats ; let con = L (l2l loc) (HsVar noExtField lcon) - ; return (unLoc $ mkHsApps con exprs) - } + ; return (unLoc $ mkHsApps con (ty_exprs ++ val_exprs)) } mkRecordConExpr :: LocatedN (WithUserRdr Name) -> HsRecFields GhcRn (LPat GhcRn) - -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + -> TcM (HsExpr GhcRn) mkRecordConExpr con (HsRecFields x fields dd) = do { exprFields <- mapM go' fields ; return (RecordCon noExtField con (HsRecFields x exprFields dd)) } - go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn)) + go' :: LHsRecField GhcRn (LPat GhcRn) -> TcM (LHsRecField GhcRn (LHsExpr GhcRn)) go' (L l rf) = L l <$> traverse go rf - go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) + go :: LPat GhcRn -> TcM (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + go1 :: Pat GhcRn -> TcM (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of PrefixCon _ ps -> mkPrefixConExpr con ps @@ -1077,13 +1084,13 @@ tcPatToExpr args pat = go pat RecCon _ fields -> mkRecordConExpr con fields go1 (SigPat _ pat _) = go1 (unLoc pat) - -- See Note [Type signatures and the builder expression] + -- See Note [Discarding types in the builder expression] go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars = return $ mkHsVar (L l var) | otherwise - = Left (PatSynUnboundVar var) + = invalidRhs (PatSynUnboundVar var) go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat) go1 (ListPat _ pats) = do { exprs <- mapM go pats @@ -1104,10 +1111,7 @@ tcPatToExpr args pat = go pat | otherwise = return $ HsOverLit noExtField n go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" - go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) - where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn - hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty }) - = HsWC { hswc_ext = wcs, hswc_body = hs_ty } + go1 (EmbTyPat _ _tp) = panic "tcPatToExpr: invalid type pattern" go1 (InvisPat _ _tp) = panic "tcPatToExpr: invalid invisible pattern" go1 (XPat (HsPatExpanded _ pat))= go1 pat @@ -1131,7 +1135,11 @@ tcPatToExpr args pat = go pat go1 p@(NPlusKPat {}) = notInvertible p go1 p@(OrPat {}) = notInvertible p - notInvertible p = Left (PatSynNotInvertible p) + notInvertible p = invalidRhs (PatSynNotInvertible p) + +-- See Note [Discarding types in the builder expression] +wildCardTyArg :: LHsExpr GhcRn +wildCardTyArg = wrapGenSpan (HsHole (HoleVar (wrapGenSpan unnamedHoleRdrName))) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1203,9 +1211,17 @@ one could write a nonsensical function like or g (K (Just True) False) = ... -Note [Type signatures and the builder expression] +Note [Discarding types in the builder expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RHS of an implicitly bidirectional pattern synonym may mention types in +three ways: a pattern signature (p :: ty), an invisible type argument (@ty), +and a required type argument (type ty). Required type arguments may be obscured +by the omission of the `type` keyword. + +A type may /bind/ variables when it occurs in a pattern, and those binders have +no counterpart in the builder's scope, so tcPatToExpr must not carry them over. Consider + pattern L x = Left x :: Either [a] [b] In tc{Infer/Check}PatSynDecl we will check that the pattern has the @@ -1223,6 +1239,45 @@ latter; #9867.) No, the job of the signature is done, so when converting the pattern to an expression (for the builder RHS) we simply discard the signature. +The same reasoning applies to the other two forms, but the way we discard +them differs. Which form an argument takes is not apparent from the pattern +alone: in + + pattern P x = MkT a x + +'a' looks like an ordinary variable pattern, and only the TyVarBinders in +MkT's type say that it stands in a required type argument position. We get +those binders from the typechecked ConLike, via conLikeUserTyVarBinders, so +mkPrefixConExpr must look the constructor up before it can walk the arguments. +It then lines them up against the binders with zipPatsBndrs, as described +in Note [Zipping ConPat arguments with TyVarBinders] in GHC.Tc.Gen.Pat. + +Each argument is then treated accordingly: + +* Invisible type arguments (@ty) are dropped from the argument list + altogether. Given + + pattern Q x = MkT @a x + + the builder is $bQ x = MkT x. Dropping is safe because the argument + instantiates either a universal, which the expected type of the builder + already pins down, or an existential, which cannot take a concrete type + in a pattern anyway. Improper handling of type arguments led to #27440. + +* Required type arguments cannot be dropped, as that would change the syntactic + arity of the application. Instead, we replace them with wildcards `_`, the + equivalent of @_ for invisible type arguments. Given + + pattern R x = MkT (type a) x + pattern P x = MkT a x + + the builders are $bR x = MkT _ x and $bP x = MkT _ x, and the wildcard is + solved from the expected type. Retaining the type would mention a binder that + is not in scope in the builder (#27583). + +In all three cases the pattern has already been checked by the time the +builder is built, so no information is lost by forgetting these types. + Note [Record PatSyn Desugaring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important that prov_theta comes before req_theta as this ordering is used ===================================== testsuite/tests/patsyn/should_compile/T27440a.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, PatternSynonyms, TypeAbstractions #-} +module T27440a where + +import Data.Kind (Type) + +newtype Lit = Lit { litName :: String } + +type LitOfValue :: Bool -> Type +newtype LitOfValue v = LitOfValue { underlyingLit :: Lit } + +pattern FalseLit :: Lit -> LitOfValue False +pattern FalseLit a = LitOfValue @False a ===================================== testsuite/tests/patsyn/should_compile/T27440b.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms, TypeAbstractions #-} +module T27440b where + +data T a = MkT a + +pattern P :: a -> T a +pattern P x = MkT @a x ===================================== testsuite/tests/patsyn/should_compile/T27440c.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, TypeAbstractions #-} +module T27440c where + +data S = forall a. Show a => MkS a + +pattern P :: () => Show a => a -> S +pattern P x = MkS @a x ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -90,3 +90,7 @@ test('T23038', normal, compile_fail, ['']) test('T22328', normal, compile, ['']) test('T26331', normal, compile, ['']) test('T26331a', normal, compile, ['']) + +test('T27440a', normal, compile, ['']) +test('T27440b', normal, compile, ['']) +test('T27440c', normal, compile, ['']) ===================================== testsuite/tests/patsyn/should_fail/T27440d.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, TypeAbstractions #-} +module T27440d where + +data S = forall a. Show a => MkS a + +pattern P :: Show a => a -> S +pattern P x = MkS @a x ===================================== testsuite/tests/patsyn/should_fail/T27440d.stderr ===================================== @@ -0,0 +1,12 @@ +T27440d.hs:7:22: error: [GHC-25897] + • Couldn't match expected type ‘a’ with actual type ‘a1’ + ‘a1’ is a rigid type variable bound by + a pattern with constructor: MkS :: forall a. Show a => a -> S, + in a pattern synonym declaration + at T27440d.hs:7:15-22 + ‘a’ is a rigid type variable bound by + the signature for pattern synonym ‘P’ + at T27440d.hs:6:14-29 + • In the declaration for pattern synonym ‘P’ + • Relevant bindings include x :: a1 (bound at T27440d.hs:7:22) + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -55,3 +55,5 @@ test('patsyn_where_fail1', normal, compile_fail, ['']) test('patsyn_where_fail2', normal, compile_fail, ['']) test('patsyn_where_fail3', normal, compile_fail, ['']) test('patsyn_where_fail4', normal, compile_fail, ['']) + +test('T27440d', normal, compile_fail, ['']) ===================================== testsuite/tests/vdq-rta/should_compile/T27583a.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583a where + +data T a where + MkT :: forall a -> T a + +pattern P :: T a +pattern P = MkT (type a) ===================================== testsuite/tests/vdq-rta/should_compile/T27583b.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583b where + +data T a where + MkT :: forall a -> T a + +pattern P :: T a +pattern P = MkT a ===================================== testsuite/tests/vdq-rta/should_compile/T27583c.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583c where + +data T a where + MkT :: forall a -> T a + +pattern P :: T Int +pattern P = MkT (type Int) ===================================== testsuite/tests/vdq-rta/should_compile/T27583d.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583d where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. The variable/wildcard patterns x, _, (type x), (type _) +-- can't mismatch the signature. Concrete types are in T27583e and T27583f. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT x n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type x) n + +pattern P3 :: Int -> T Int +pattern P3 n = MkT _ n + +pattern P4 :: Int -> T Int +pattern P4 n = MkT (type _) n ===================================== testsuite/tests/vdq-rta/should_compile/T27583e.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583e where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. Here the type written in that position agrees with the +-- signature. T27583f is the same four patterns with a type that does not. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT Int n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type Int) n + +pattern P3 :: Maybe Int -> T (Maybe Int) +pattern P3 n = MkT (Maybe Int) n + +pattern P4 :: Maybe Int -> T (Maybe Int) +pattern P4 n = MkT (type (Maybe Int)) n ===================================== testsuite/tests/vdq-rta/should_compile/T27583g.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms, TypeAbstractions #-} +module T27583g where + +data T a b c where + MkT :: forall a. forall b c -> a -> T a b c + +-- Check all argument variants in a constructor pattern at once: the invisible +-- type argument `@a`, the required type argument `type b` with the herald, the +-- required type argument `c` without the herald, and the value argument `x`. +-- +-- The resulting builder is $bP x = MkT _ _ x. + +pattern P :: x -> T x y z +pattern P x = MkT @a (type b) c x ===================================== testsuite/tests/vdq-rta/should_compile/all.T ===================================== @@ -39,3 +39,10 @@ test('T23738_th', req_th, compile, ['']) test('T24159_viewpat', normal, compile, ['']) test('T24159_type_syntax', normal, compile, ['']) test('T24159_th_type_syntax', req_th, compile, ['']) + +test('T27583a', normal, compile, ['']) +test('T27583b', normal, compile, ['']) +test('T27583c', normal, compile, ['']) +test('T27583d', normal, compile, ['']) +test('T27583e', normal, compile, ['']) +test('T27583g', normal, compile, ['']) ===================================== testsuite/tests/vdq-rta/should_fail/T27440e.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms, TypeAbstractions #-} +module T27440e where + +data T a where + MkT :: forall a -> T a + +pattern P :: a -> T a +pattern P x = MkT @a x ===================================== testsuite/tests/vdq-rta/should_fail/T27440e.stderr ===================================== @@ -0,0 +1,5 @@ +T27440e.hs:8:19: error: [GHC-88754] + • Ill-formed type pattern: @a + • In the pattern: MkT @a x + In the declaration for pattern synonym ‘P’ + ===================================== testsuite/tests/vdq-rta/should_fail/T27583f.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, RequiredTypeArguments, PatternSynonyms #-} +module T27583f where + +data T a where + MkT :: forall a -> a -> T a + +-- A required type argument is checked against the signature, with or without +-- the 'type' herald. Here the type written in that position does not agree +-- with the signature. T27583e is the same four patterns with a type that does. + +pattern P1 :: Int -> T Int +pattern P1 n = MkT Bool n + +pattern P2 :: Int -> T Int +pattern P2 n = MkT (type Bool) n + +pattern P3 :: Maybe Int -> T (Maybe Int) +pattern P3 n = MkT (Maybe Bool) n + +pattern P4 :: Maybe Int -> T (Maybe Int) +pattern P4 n = MkT (type (Maybe Bool)) n ===================================== testsuite/tests/vdq-rta/should_fail/T27583f.stderr ===================================== @@ -0,0 +1,24 @@ +T27583f.hs:12:16: error: [GHC-83865] + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the pattern: MkT Bool n + In the declaration for pattern synonym ‘P1’ + +T27583f.hs:15:16: error: [GHC-83865] + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the pattern: MkT (type Bool) n + In the declaration for pattern synonym ‘P2’ + +T27583f.hs:18:16: error: [GHC-83865] + • Couldn't match type ‘Bool’ with ‘Int’ + Expected: Maybe Int + Actual: Maybe Bool + • In the pattern: MkT (Maybe Bool) n + In the declaration for pattern synonym ‘P3’ + +T27583f.hs:21:16: error: [GHC-83865] + • Couldn't match type ‘Bool’ with ‘Int’ + Expected: Maybe Int + Actual: Maybe Bool + • In the pattern: MkT (type (Maybe Bool)) n + In the declaration for pattern synonym ‘P4’ + ===================================== testsuite/tests/vdq-rta/should_fail/all.T ===================================== @@ -32,3 +32,6 @@ test('T24159_type_syntax_tc_fail', normal, compile_fail, ['']) test('T24159_type_syntax_th_fail', normal, ghci_script, ['T24159_type_syntax_th_fail.script']) test('T25127_fail_th_quote', normal, compile_fail, ['']) test('T25127_fail_arity', normal, compile_fail, ['']) + +test('T27440e', normal, compile_fail, ['']) +test('T27583f', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bc2ffd0505fb2e1ce36b78ddfd4972… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bc2ffd0505fb2e1ce36b78ddfd4972… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix note typo
by Marge Bot (＠marge-bot) 02 Aug '26

02 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c9a34a00 by Viktor Dukhovni at 2026-08-02T04:34:17-04:00 Fix note typo - - - - - 6efd74d5 by Andreas Klebinger at 2026-08-02T16:16:24-04:00 Apply oneShot Monad trick to STG LintM - - - - - 474e654c by Andreas Klebinger at 2026-08-02T16:16:24-04:00 stgLint: Use a single reader env for read only arguments. - - - - - 66c5544e by Alan Zimmerman at 2026-08-02T16:16:25-04:00 EPA: Remove LocatedP from CType The next step of removing use of LocatedP by moving the AnnPragma for CType into its TTG extension point instead. - - - - - 8 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Types/ForeignCall.hs - libraries/ghc-internal/src/GHC/Internal/Ix.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1583,7 +1583,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Parser.y ===================================== @@ -1707,15 +1707,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -92,6 +92,7 @@ be ill-typed in Core. But it must still be well-kinded! -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module GHC.Stg.Lint ( lintStgTopBindings ) where @@ -123,6 +124,7 @@ import GHC.Unit.Module ( Module ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Monad +import GHC.Exts ( oneShot ) import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) @@ -432,17 +434,40 @@ The Lint monad ************************************************************************ -} -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> DiagOpts -- Diagnostic options - -> StgPprOpts -- Pretty-printing options +data LintReaderEnv = LintReaderEnv + { le_mod :: !Module + , le_flags :: !LintFlags + , le_diag_opts :: !DiagOpts -- Diagnostic options + , le_ppr_opts :: !StgPprOpts -- Pretty-printing options + } + +newtype LintM a = LintM' + { unLintM :: LintReaderEnv -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag SDoc -- Error messages so far -> (a, Bag SDoc) -- Result and error messages (if any) } - deriving (Functor) +instance Functor LintM where + fmap f (LintM m) = + LintM $ \env loc scope errs -> + case m env loc scope errs of + (a, errs') -> (f a, errs') + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE LintM #-} +pattern LintM :: (LintReaderEnv + -> [LintLocInfo] + -> IdSet + -> Bag SDoc + -> (a, Bag SDoc)) + -> LintM a +pattern LintM m <- LintM' m + where + LintM m = LintM' $ oneShot (\env -> oneShot + (\loc -> oneShot + (\scope -> oneShot + (\errs -> m env loc scope errs)))) data LintFlags = LintFlags { lf_unarised :: !Bool , lf_platform :: !Platform @@ -473,14 +498,16 @@ pp_binders bs initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL platform diag_opts this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag + let !flags = LintFlags unarised platform + !env = LintReaderEnv this_mod flags diag_opts opts + (_, errs) = m env [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where - pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) + pure a = LintM $ \_env _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -489,14 +516,14 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' +thenL m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (r, errs') -> unLintM (k r) env loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' +thenL_ m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (_, errs') -> unLintM k env loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -525,7 +552,8 @@ checkPostUnariseId id id_ty = idType id addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) +addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs + -> ((), addErr df errs msg loc) addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr diag_opts errs_so_far msg locs @@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs - -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \env loc scope errs + -> unLintM m env (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs +addInScopeVars ids m = LintM $ \env loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs + in unLintM m env loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) +getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts -getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) +getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs +checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . packHText + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -349,6 +351,7 @@ instance Binary CTypeGhc where return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = noAnn } instance NFData StaticTargetGhc where ===================================== libraries/ghc-internal/src/GHC/Internal/Ix.hs ===================================== @@ -142,7 +142,7 @@ For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this. Note [Out-of-bounds error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method for 'index' generates hoplelessIndexError, because +The default method for 'index' generates 'hopelessIndexError', because Ix doesn't have Show as a superclass. For particular base types we can do better, so we override the default method for index. ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -4401,13 +4401,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4415,7 +4416,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -837,7 +837,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/93a68c14430f035b61bade285a60d1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/93a68c14430f035b61bade285a60d1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-taggable-invariant] StgToCmm: evaluate in tail position through stg_enter_data
by Sebastian Graf (＠sgraf812) 02 Aug '26

02 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-taggable-invariant at Glasgow Haskell Compiler / GHC Commits: 7e37b737 by Sebastian Graf at 2026-08-02T19:03:01+02:00 StgToCmm: evaluate in tail position through stg_enter_data stg_enter_data is stg_ap_0_fast specialised to values whose type rules out functions, the only values for which getCallMethod selects EnterIt: the closure is a thunk, a constructor, or an indirection to one, so the FUN/PAP/BCO arms of the generic evaluation are unreachable and an indirection's entry code performs the following. The stub reduces to the tag test and an entry jump, and emitEnter's Return case reduces to a single jump to it. Compiling T13960 allocates 1.6% less than with the open-coded tag test and return. - - - - - 4 changed files: - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -35,7 +35,9 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, cmmLoadGCWord ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,32 +1192,17 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return we test the tag and, if the value is already tagged - -- (hence evaluated), return it directly rather than entering it. This - -- upholds the invariant that the entry code of a taggable normal form is - -- never reached: only an untagged closure is entered. The tag test costs - -- a branch on every tail enter, but a tagged value reaching here is the - -- common case. + -- For a return we evaluate through stg_enter_data, the specialisation + -- of stg_ap_0_fast to values whose type rules out functions + -- (getCallMethod selects EnterIt only for those): it returns a tagged + -- (hence evaluated) value directly and enters an untagged closure, so + -- the entry code of a taggable normal form is never reached and the + -- tail enter costs a single jump in the generated code. Return -> do - { fun_tmp <- assignTemp fun - ; let funR = CmmReg (CmmLocal fun_tmp) - entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ret_addr = entryCode platform - $ cmmLoadGCWord platform (CmmStackSlot Old updfr_off) - ; lenter <- newBlockId - ; lret <- newBlockId - ; tscope <- getTickScope - ; emit $ - mkCbranch (cmmIsTagged platform funR) lret lenter Nothing <*> - outOfLine lenter - ( mkJump profile NativeNodeCall entry [cmmUntag platform funR] updfr_off - , tscope ) <*> - mkLabel lret tscope <*> - mkReturn profile ret_addr [funR] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -54,6 +54,25 @@ import CLOSURE stg_restore_cccs_eval_info; * everything being returned is guaranteed evaluated, so it would be a no-op. */ +/* ----------------------------------------------------------------------------- + Evaluate a value whose type rules out functions. + + A specialisation of stg_ap_0_fast (below) to closures that are a + thunk, a constructor, or an indirection to one: the FUN/PAP/BCO arms + of the generic evaluation are unreachable, and an indirection's own + entry code performs the following, so evaluation reduces to the tag + test and an entry jump. The code generator jumps here to evaluate in + tail position; see emitEnter in GHC.StgToCmm.Expr. + -------------------------------------------------------------------------- */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + STRING(stg_ap_0_ret_str,"stg_ap_0_ret... ") stg_ap_0_fast ( P_ fun ) ===================================== rts/RtsSymbols.c ===================================== @@ -848,6 +848,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -302,6 +302,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e37b73766e6e931cad507cf41847ac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e37b73766e6e931cad507cf41847ac… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27557] 5 commits: GHC Guide: Improve docs on response files
by Simon Peyton Jones (＠simonpj) 02 Aug '26

02 Aug '26

Simon Peyton Jones pushed to branch wip/T27557 at Glasgow Haskell Compiler / GHC Commits: 3ec9e2b9 by Mike Pilgrem at 2026-07-31T08:21:33-04:00 GHC Guide: Improve docs on response files - - - - - e5b2a1f7 by sheaf at 2026-07-31T08:22:23-04:00 Disable Core Lint for TcPlugin_RewritePerf This is a compiler performance test, but the test source hard-coded -dcore-lint, defeating the measurement. ------------------------- Metric Decrease: TcPlugin_RewritePerf ------------------------- - - - - - 85b10c00 by Alan Zimmerman at 2026-07-31T22:09:47+01:00 EPA: Remove LocatedP from OverlapMode We have type LocatedP = GenLocated SrcSpanAnnP type SrcSpanAnnP = EpAnn AnnPragma As the first step in removing this in favour of LocatedA which only captures location, comments and trailing annotations, we remove it from OverlapMode We do this by moving the AnnPragma into the TTG extension point instead. - - - - - c9a34a00 by Viktor Dukhovni at 2026-08-02T04:34:17-04:00 Fix note typo - - - - - 40a8449c by Simon Peyton Jones at 2026-08-02T16:19:25+01:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T7954 Metric Increase: T21839c - - - - - 32 changed files: - + changelog.d/T27557 - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - docs/users_guide/using.rst - libraries/ghc-internal/src/GHC/Internal/Ix.hs - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/tcplugins/TcPlugin_RewritePerf.hs - testsuite/tests/tcplugins/TcPlugin_RewritePerf.stderr - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e6f063be8cd37fe0911a8cc602447… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e6f063be8cd37fe0911a8cc602447… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-11
by Alan Zimmerman (＠alanz) 02 Aug '26

02 Aug '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-11 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-11 You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Fix note typo
by Marge Bot (＠marge-bot) 02 Aug '26

02 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c9a34a00 by Viktor Dukhovni at 2026-08-02T04:34:17-04:00 Fix note typo - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Ix.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Ix.hs ===================================== @@ -142,7 +142,7 @@ For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this. Note [Out-of-bounds error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method for 'index' generates hoplelessIndexError, because +The default method for 'index' generates 'hopelessIndexError', because Ix doesn't have Show as a superclass. For particular base types we can do better, so we override the default method for index. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9a34a0054b95fcd7a9717b8b41a7b6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9a34a0054b95fcd7a9717b8b41a7b6… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] EPA: Remove LocatedP from OverlapMode
by Marge Bot (＠marge-bot) 02 Aug '26

02 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 85b10c00 by Alan Zimmerman at 2026-07-31T22:09:47+01:00 EPA: Remove LocatedP from OverlapMode We have type LocatedP = GenLocated SrcSpanAnnP type SrcSpanAnnP = EpAnn AnnPragma As the first step in removing this in favour of LocatedA which only captures location, comments and trailing annotations, we remove it from OverlapMode We do this by moving the AnnPragma into the TTG extension point instead. - - - - - 10 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1158,20 +1158,25 @@ ppDerivStrategy mb = Nothing -> empty Just (L _ ds) -> ppr ds -ppOverlapPragma :: Maybe (LocatedP (OverlapMode (GhcPass p))) -> SDoc +ppOverlapPragma :: forall p. IsPass p => Maybe (LocatedA (OverlapMode (GhcPass p))) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" - Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" - Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" - Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" - Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" - Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet + Just (L _ (NoOverlap s)) -> maybe_stext (stext s) "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext (stext s) "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext (stext s) "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext (stext s) "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" + Just (L _ (NonCanonical s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet where maybe_stext NoSourceText alt = text alt maybe_stext (SourceText src) _ = ftext src <+> text "#-}" + stext :: XOverlapMode (GhcPass p) -> SourceText + stext s = case (ghcPass @p, s) of + (GhcPs, (s,_)) -> s + (GhcRn, (s,_)) -> s + (GhcTc, s) -> s instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where ppr (ClsInstD { cid_inst = decl }) = ppr decl @@ -1593,7 +1598,7 @@ type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnP +type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -26,6 +26,8 @@ import GHC.Prelude import GHC.Hs.Extension +import GHC.Parser.Annotation ( AnnPragma ) + import Language.Haskell.Syntax.Decls.Overlap import Language.Haskell.Syntax.Extension @@ -65,7 +67,9 @@ instance NFData OverlapFlag where instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) -type instance XOverlapMode (GhcPass _) = SourceText +type instance XOverlapMode GhcPs = (SourceText, AnnPragma) +type instance XOverlapMode GhcRn = (SourceText, AnnPragma) +type instance XOverlapMode GhcTc = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1752,7 +1752,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where NewtypeStrategy _ -> [] ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ] -instance ToHie (LocatedP (OverlapMode GhcRn)) where +instance ToHie (LocatedA (OverlapMode GhcRn)) where toHie (L span _) = locOnly (locA span) instance ToHie (LocatedA (ConDecl GhcRn)) where ===================================== compiler/GHC/Parser.y ===================================== @@ -1471,15 +1471,15 @@ inst_decl :: { LInstDecl GhcPs } (fmap reverse $7) (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}} -overlap_pragma :: { Maybe (LocatedP (OverlapMode GhcPs)) } - : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } - | '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) - (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } +overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) } + : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + | '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1, + AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handles @deriving@ clauses on @data@ declarations. -module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where +module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..), tcOverlapMode ) where import GHC.Prelude @@ -776,12 +776,12 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo tcOverlapMode :: OverlapMode GhcRn -> OverlapMode GhcTc tcOverlapMode = \case - NoOverlap s -> NoOverlap s - Overlappable s -> Overlappable s - Overlapping s -> Overlapping s - Overlaps s -> Overlaps s - Incoherent s -> Incoherent s - NonCanonical s -> NonCanonical s + NoOverlap s -> NoOverlap (fst s) + Overlappable s -> Overlappable (fst s) + Overlapping s -> Overlapping (fst s) + Overlaps s -> Overlaps (fst s) + Incoherent s -> Incoherent (fst s) + NonCanonical s -> NonCanonical (fst s) -- Typecheck the type in a standalone deriving declaration. -- ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -558,7 +558,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty -- Dfun location is that of instance *header* ; let warn = fmap unLoc lwarn - ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name + ; ispec <- newClsInst (fmap (tcOverlapMode . unLoc) overlap_mode) dfun_name tyvars theta clas inst_tys warn ; let inst_binds = InstBindings ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -72,7 +72,6 @@ import GHC.Rename.Utils( mkRnSyntaxExpr ) import GHC.Types.Id.Make( mkDictFunId ) import GHC.Types.Arity ( Arity, VisArity ) import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env import GHC.Types.Id @@ -912,7 +911,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity ************************************************************************ -} -getOverlapFlag :: Maybe (OverlapMode (GhcPass p)) -- User pragma if any +getOverlapFlag :: Maybe (OverlapMode GhcTc) -- User pragma if any -> TcM OverlapFlag -- Construct the OverlapFlag from the global module flags, -- but if the overlap_mode argument is (Just m), @@ -936,9 +935,9 @@ getOverlapFlag overlap_mode_prag overlap_mode | Just m <- overlap_mode_prag = m - | incoherent_ok = Incoherent NoSourceText - | overlap_ok = Overlaps NoSourceText - | otherwise = NoOverlap NoSourceText + | incoherent_ok = Incoherent noAnn + | overlap_ok = Overlaps noAnn + | otherwise = NoOverlap noAnn -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap @@ -964,7 +963,7 @@ tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv -newClsInst :: Maybe (OverlapMode (GhcPass p)) -- User pragma +newClsInst :: Maybe (OverlapMode GhcTc) -- User pragma -> Name -> [TyVar] -> ThetaType -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst newClsInst overlap_mode dfun_name tvs theta clas tys warn ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -356,10 +356,10 @@ cvtDec (InstanceD o ctxt ty decs) where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT") + TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS", noAnn) + TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE", noAnn) + TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING", noAnn) + TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT", noAnn) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2246,40 +2246,40 @@ instance ExactPrint (TyFamInstDecl GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (OverlapMode (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (OverlapMode GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a -- NOTE: NoOverlap is only used in the typechecker - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do + exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# NO_OVERLAP" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src)) + return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do + exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src)) + return (Overlappable (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do + exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPING" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src)) + return (Overlapping (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do + exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# OVERLAPS" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src)) + return (Overlaps (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do + exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do + exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -836,7 +836,7 @@ type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF -type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma +type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA type instance Anno (CType DocNameI) = EpAnn AnnPragma type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85b10c00d19f80eb5c9a47e013d04ae… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85b10c00d19f80eb5c9a47e013d04ae… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Fix note typo
by Marge Bot (＠marge-bot) 01 Aug '26

01 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 93a68c14 by Viktor Dukhovni at 2026-08-01T19:30:51-04:00 Fix note typo - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Ix.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Ix.hs ===================================== @@ -142,7 +142,7 @@ For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this. Note [Out-of-bounds error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The default method for 'index' generates hoplelessIndexError, because +The default method for 'index' generates 'hopelessIndexError', because Ix doesn't have Show as a superclass. For particular base types we can do better, so we override the default method for index. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93a68c14430f035b61bade285a60d12… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/93a68c14430f035b61bade285a60d12… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0