- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/sg/enter-data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed new branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sg/enter-data 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/fendor/26300] Check external dependencies and home units for duplicates
by Hannes Siebenhandl (＠fendor) 03 Aug '26

03 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC Commits: 21fc5fe9 by fendor at 2026-08-03T12:07:35+02:00 Check external dependencies and home units for duplicates - - - - - 16 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - + testsuite/tests/ghci/T26300/Makefile - + testsuite/tests/ghci/T26300/T26300.script - + testsuite/tests/ghci/T26300/T26300.stderr - + testsuite/tests/ghci/T26300/T26300.stdout - + testsuite/tests/ghci/T26300/a/Main.hs - + testsuite/tests/ghci/T26300/all.T - + testsuite/tests/ghci/T26300/b/Bar.hs - + testsuite/tests/ghci/T26300/b/Data/List.hs - + testsuite/tests/ghci/T26300/c/Bar.hs - + testsuite/tests/ghci/T26300/unitA - + testsuite/tests/ghci/T26300/unitB - + testsuite/tests/ghci/T26300/unitC Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -240,7 +240,9 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst -> vcat (map pprMod mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + unambiguousPackage (Just xs) (m, ExternalUnitOrigin (ModOrigin (Just _) _ _ _)) + = Just (moduleUnit m : xs) + unambiguousPackage (Just xs) (m, HomeOrigin{}) = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing GenericMissing pkg_hiddens mod_hiddens unusables files -> @@ -251,9 +253,16 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + + pprOrigin m HomeOrigin = pprHomeOrigin m + pprOrigin m (ExternalUnitOrigin o) = pprExtOrigin m o + + pprHomeOrigin m = + text "package" <+> ppr (moduleUnit m) + + pprExtOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprExtOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprExtOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True then [text "package" <+> ppr (moduleUnit m)] else [] ++ ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Iface.Errors.Types ( , ReadInterfaceError(..) , CantFindInstalled(..) , CantFindInstalledReason(..) + , HomeOrExternalOrigin(..) , FindingModuleOrInterface(..) , BuildingCabalPackage(..) @@ -75,9 +76,13 @@ data CantFindInstalledReason | GenericMissing [UnitInfo] [Unit] [UnusableUnit] [FilePath] - | MultiplePackages [(Module, ModuleOrigin)] + | MultiplePackages [(Module, HomeOrExternalOrigin)] deriving Generic +data HomeOrExternalOrigin + = HomeOrigin + | ExternalUnitOrigin ModuleOrigin + data CantFindInstalled = CantFindInstalled ModuleName CantFindInstalledReason deriving Generic ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -78,10 +78,11 @@ import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Set (Set) -import qualified Data.Set as Set (empty, intersection, difference, null, toList) +import qualified Data.Set as Set (empty, intersection, difference, null, toList, member) import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE +import GHC.Iface.Errors.Types type FileExt = OsString -- Filename extension type BaseName = OsPath -- Basename of file @@ -247,8 +248,12 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + other_fopts = + let + (providers, others) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name + in + providers ++ others -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as @@ -263,11 +268,17 @@ findPluginModuleNoHsc -> ModuleName -> IO FindResult findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name + home_import `orIfNotFound` - findExposedPluginPackageModule fc fopts unit_state mod_name + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPluginPackageModule fc fopts unit_state mod_name + ) where + home_import = + findHomeModule fc fopts home_unit mod_name + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = @@ -291,9 +302,9 @@ findPluginModule hsc_env mod_name = do rankedHomeUnitDeps :: HomeModuleNameProvidersMap -> ModuleName -> Set UnitId - -> [UnitId] + -> ([UnitId], [UnitId]) rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps - = [] + = ([], []) -- The special handling of the situation where the dependency set is empty does -- not change the result, but it avoids triggering evaluation of the module -- graph. This is particularly important in one-shot mode, where the module @@ -309,7 +320,7 @@ rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps -- 3 | import {-# source #-} A -- | ^^^^^^^^^^^^^^^^^^^^^^^ rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps - = Set.toList cached_deps ++ Set.toList uncached_deps + = (Set.toList cached_deps, Set.toList uncached_deps) where cached_providers :: Set UnitId @@ -330,12 +341,19 @@ homeUnitDepsFinderOpts -> HomeModuleNameProvidersMap -> UnitState -- ^ unit state of the requesting home unit -> ModuleName - -> [(UnitId, FinderOpts)] + -> ([(UnitId, FinderOpts)], [(UnitId, FinderOpts)]) homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name = - [ (uid, initFinderOpts (ue_unitFlags uid ue)) - | uid <- rankedHomeUnitDeps home_module_name_providers_map mod_name + let + (providers, otherHomeUnits) = rankedHomeUnitDeps home_module_name_providers_map mod_name (homeUnitDepends unit_state) - ] + in + ( [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- providers + ] + , [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- otherHomeUnits + ] + ) -- | Search for @mod_name@ in the given home unit. findHomeUnitDepModule @@ -364,30 +382,29 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts) -- successful result. findHomeModuleAmongDeps :: FinderCache - -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) - -- Do not try to be smart and change this to `foldr orIfNotFound home_import - -- (map home_pkg_import other_fopts)`, as that would not be the same. - -- `home_import` is first because we need to first look within the current - -- unit before looking at the other units in order. +findHomeModuleAmongDeps fc ue home_module_name_providers_map mb_home_unit mod_name = + findInDirectDeps `orIfNotFound` findInOtherDeps where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + findInDirectDeps = case provider_fopts of + p:ps -> foldr1 combineFindResult (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + + findInOtherDeps = case other_fopts of + p:ps -> foldr1 orIfNotFound (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + (provider_fopts, other_fopts) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name -- | Search the home-unit graph and otherwise the regular exposed package @@ -401,10 +418,17 @@ findHomeOrRegularPackageModule -> ModuleName -> IO FindResult findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name - `orIfNotFound` - findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + case mb_home_unit of + Just home_unit -> + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + ) + Nothing -> + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual where unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue @@ -470,6 +494,40 @@ orIfNotFound this or_this = do _other -> return res2 _other -> return res +combineFindResult :: Monad m => m FindResult -> m FindResult -> m FindResult +combineFindResult this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + NoPackage{} -> pure res + FoundMultiple ms -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ ms ++ [(other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ ms ++ other_ms + NotFound{} -> pure res + Found _mod_location modl -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ [(modl, HomeOrigin), (other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ [(modl, HomeOrigin)] ++ other_ms + NotFound{} -> pure res + -- | Helper function for 'findHomeModule': this function wraps an IO action -- which would look up @mod_name@ in the file system (the home package), -- and first consults the 'hsc_FC' cache to see if the lookup has already @@ -483,8 +541,12 @@ homeSearchCache fc home_unit mod_name do_this = do findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg = - findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + findLookupResult fc fopts $ + case lookupModuleWithSuggestions units mod_name mb_pkg of + lf@(LookupFound _ (u, _)) + | unitId u `Set.member` homeUnitDepends units -> LookupNotFound [] + | otherwise -> lf + other -> other findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult findExposedPluginPackageModule fc fopts units mod_name = @@ -509,7 +571,7 @@ findLookupResult fc fopts r = case r of , fr_unusables = [] , fr_suggestions = []}) LookupMultiple rs -> - return (FoundMultiple rs) + return (FoundMultiple $ map (\ (m, o) -> (m, ExternalUnitOrigin o)) rs) LookupHidden fr_pkgs_hidden mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden @@ -588,6 +650,15 @@ mkHomeHidden uid = , fr_unusables = [] , fr_suggestions = []} +notFound = + NotFound { fr_paths = [] + , fr_pkg = Nothing + , fr_mods_hidden = [] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + + findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult findHomePackageModule fc fopts home_unit mod_name = do let uid = RealUnit (Definite home_unit) ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Unit.Env import GHC.Data.FastString import GHC.Types.Unique.Set +import GHC.Iface.Errors.Types (HomeOrExternalOrigin) -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for @@ -56,7 +57,7 @@ data FindResult -- ^ The module was found | NoPackage Unit -- ^ The requested unit was not found - | FoundMultiple [(Module, ModuleOrigin)] + | FoundMultiple [(Module, HomeOrExternalOrigin)] -- ^ _Error_: both in multiple packages -- | Not found ===================================== testsuite/tests/ghci/T26300/Makefile ===================================== @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: prog-mhu006a +prog-mhu006a: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db \ + -unit @unitA -unit @unitB < prog-mhu006a.script ===================================== testsuite/tests/ghci/T26300/T26300.script ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/T26300.stderr ===================================== @@ -0,0 +1,8 @@ +a/Main.hs:3:1: error: [GHC-45102] + Ambiguous module name ‘Data.List’. + it was found in multiple packages: base-4.23.0.0 b-0.0.1 + +a/Main.hs:4:1: error: [GHC-45102] + Ambiguous module name ‘Bar’. + it was found in multiple packages: c-0.0.1 b-0.0.1 + ===================================== testsuite/tests/ghci/T26300/T26300.stdout ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/a/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +import Data.List +import Bar ===================================== testsuite/tests/ghci/T26300/all.T ===================================== @@ -0,0 +1,6 @@ +test('T26300', + [extra_files(['a/', 'b/', 'c/', 'unitA', 'unitB', 'unitC']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + normalise_slashes, + req_interp], + ghci_multiunit_script, [['unitA', 'unitB', 'unitC'], 'T26300.script']) ===================================== testsuite/tests/ghci/T26300/b/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/b/Data/List.hs ===================================== @@ -0,0 +1 @@ +module Data.List where ===================================== testsuite/tests/ghci/T26300/c/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/unitA ===================================== @@ -0,0 +1,6 @@ +-i +-ia +-this-unit-id a-0.0.1 +-package-id b-0.0.1 +-package-id c-0.0.1 +Main ===================================== testsuite/tests/ghci/T26300/unitB ===================================== @@ -0,0 +1,5 @@ +-i +-ib +-this-unit-id b-0.0.1 +Data.List +Bar ===================================== testsuite/tests/ghci/T26300/unitC ===================================== @@ -0,0 +1,4 @@ +-i +-ic +-this-unit-id c-0.0.1 +Bar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21fc5fe9cf1727e2dc7594ee14495cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21fc5fe9cf1727e2dc7594ee14495cd… 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 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