Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 6f8e976b by Simon Peyton Jones at 2026-03-20T11:00:39+00:00 Wibbles - - - - - 742099ce by Simon Peyton Jones at 2026-03-20T12:46:27+00:00 More improvements ..with help form Matthew, to module graph dependencies - - - - - 22 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Unit/Module/ModSummary.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Enum.hs - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NubOrdSet.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Stats.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-prim/ghc-prim.cabal - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/parser/should_fail/T16270h.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1637,8 +1637,8 @@ integralClassKey = mkPreludeClassUnique 7 monadClassKey = mkPreludeClassUnique 8 dataClassKey = mkPreludeClassUnique 9 functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 +numClassKey = mkPreludeClassUnique 11 -- 2b +ordClassKey = mkPreludeClassUnique 12 -- 2c readClassKey = mkPreludeClassUnique 13 realClassKey = mkPreludeClassUnique 14 realFloatClassKey = mkPreludeClassUnique 15 ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -879,7 +879,7 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location) - -- Also copied from 'getImports' + -- Also copied from 'getImportEdges' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps implicit_prelude = xopt LangExt.ImplicitPrelude dflags ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -1536,10 +1536,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name) <- ExceptT $ do - let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags - popts = initParserOpts pi_local_dflags - sec = initSourceErrorContext pi_local_dflags - mimps <- getImports popts sec imp_prelude pi_hspp_buf pi_hspp_fn src_fn + mimps <- getImportEdges pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -672,12 +672,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do (hspp_buf,mod_name,imps,src_imps) <- do buf <- hGetStringBuffer input_fn -- TODO: handle implicit knownkey names here? - let imp_prelude = xopt LangExt.ImplicitPrelude dflags - popts = initParserOpts dflags - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn)) sec = initSourceErrorContext dflags - eimps <- getImports popts sec imp_prelude buf input_fn (basename <.> suff) + eimps <- getImportEdges dflags buf input_fn (basename <.> suff) case eimps of Left errs -> throwErrors sec (GhcPsMessage <$> errs) Right (src_imps,imps, L _ mod_name) -> return ===================================== compiler/GHC/Parser/Header.hs ===================================== @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- module GHC.Parser.Header - ( getImports + ( getImportEdges , mkPrelImports -- used by the renamer too , getOptionsFromFile , getOptions @@ -24,7 +24,8 @@ import GHC.Prelude import GHC.Data.Bag -import GHC.Driver.DynFlags (DynFlags) +import GHC.Driver.DynFlags +import GHC.Driver.Config.Parser( initParserOpts ) import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! import GHC.Parser.Errors.Types @@ -47,6 +48,8 @@ import GHC.Utils.Monad import GHC.Utils.Error import GHC.Utils.Exception as Exception +import qualified GHC.LanguageExtensions as LangExt + import GHC.Data.StringBuffer import GHC.Data.Maybe import GHC.Data.FastString @@ -63,26 +66,31 @@ import Text.Read (readPrec) ------------------------------------------------------------------------------ --- | Parse the imports of a source file. +-- | Returns the dependency edges of the module graph, by +-- * parsing the module and looking for `import` declarations +-- * adding edges for Prelude and GHC.KnownKeyNames as required -- -- Throws a 'SourceError' if parsing fails. -getImports :: ParserOpts -- ^ Parser options - -> SourceErrorContext - -> Bool -- ^ Implicit Prelude? - -> StringBuffer -- ^ Parse this. - -> FilePath -- ^ Filename the buffer came from. Used for - -- reporting parse error locations. - -> FilePath -- ^ The original source filename (used for locations - -- in the function result) - -> IO (Either - (Messages PsMessage) - ([Located ModuleName], - [(ImportLevel, RawPkgQual, Located ModuleName)], - Located ModuleName)) - -- ^ The source imports and normal imports (with optional package - -- names from -XPackageImports), and the module name. -getImports popts sec implicit_prelude buf filename source_filename = do +getImportEdges + :: DynFlags + -> StringBuffer -- ^ Parse this. + -> FilePath -- ^ Filename the buffer came from. Used for + -- reporting parse error locations. + -> FilePath -- ^ The original source filename (used for locations + -- in the function result) + -> IO (Either + (Messages PsMessage) + ([Located ModuleName], -- {-# SOURCE #-} imports + [(ImportLevel, RawPkgQual, Located ModuleName)], -- Normal imports + Located ModuleName)) -- Name of current module + -- ^ The source imports and normal imports (with optional package + -- names from -XPackageImports), and the module name. +getImportEdges dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 + imp_prelude = xopt LangExt.ImplicitPrelude dflags + rebindable_kn = gopt Opt_RebindableKnownKeyNames dflags + popts = initParserOpts dflags + sec = initSourceErrorContext dflags case unP parseHeader (initParserState popts buf loc) of PFailed pst -> -- assuming we're not logging warnings here as per below @@ -102,16 +110,19 @@ getImports popts sec implicit_prelude buf filename source_filename = do mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps - generated_imports = mkPrelImports (unLoc mod) implicit_prelude imps - convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) + generated_imports = mkPrelImports (unLoc mod) imp_prelude imps + convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i) + + known_key_name_edges -- Add an edge to GHC.KnownKeyNames, unless -frebindable-known-key-names is on + | rebindable_kn = [] + | otherwise = [(NormalLevel, NoRawPkgQual, noLoc kNOWN_KEY_NAMES)] in - return (map convImport_src src_idecls - , map convImport (generated_imports ++ ord_idecls) + return ( map convImport_src src_idecls + , known_key_name_edges ++ + map convImport (generated_imports ++ ord_idecls) , reLoc mod) - - mkPrelImports :: ModuleName -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs] @@ -261,7 +272,7 @@ getOptions opts sec supported buf filename -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through --- CPP, so we can't use the same trick as 'getImports'. +-- CPP, so we can't use the same trick as 'getImportEdges'. getOptions' :: ParserOpts -> SourceErrorContext -> [String] ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -2203,7 +2203,8 @@ warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () warnUnusedImport rdr_env (L loc decl, used, unused, unused_wcs) -- Do not warn for 'import M()' - | Just (Exactly, L _ []) <- ideclImportList decl + | Just (Exactly, _) <- ideclImportList decl + , null unused = return () -- Note [Do not warn about Prelude hiding] ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -1083,11 +1083,14 @@ tcGetDefaultTys ; checkWiredInTyCon doubleTyCon ; numDef <- case lookupDefaultEnv_Directly user_defaults numClassKey of Nothing -> do { integer_ty <- tcMetaTy integerTyConName - ; numClass <- tcLookupKnownKeyClass numClassKey - ; pure $ unitDefaultEnv $ builtinDefaults numClass [integer_ty, doubleTy] - } - -- The Num class is already user-defaulted, no need to construct the builtin default - _ -> pure emptyDefaultEnv + ; numClass <- tcLookupKnownKeyClass numClassKey + ; pure $ unitDefaultEnv $ + builtinDefaults numClass [integer_ty, doubleTy] } + + _ -> -- The Num class is already user-defaulted, so + -- no need to construct the builtin default + pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults -- override them. We put the user-supplied ones last because in `mconcat` -- on `DefaultEnv` the rightmost wins. ===================================== compiler/GHC/Unit/Module/ModSummary.hs ===================================== @@ -86,6 +86,7 @@ data ModSummary -- ^ Source imports of the module ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* + -- Includes 'import Prelude' if -XImplicitPrelude ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. ===================================== libraries/base/src/Control/Applicative.hs ===================================== @@ -69,6 +69,7 @@ import GHC.Internal.Base ( import GHC.Internal.Functor.ZipList (ZipList(..)) import GHC.Internal.Types import GHC.Generics +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- $setup -- >>> import Prelude ===================================== libraries/base/src/Data/Bool.hs ===================================== @@ -24,7 +24,8 @@ module Data.Bool bool ) where -import Prelude (Bool(..), (&&), (||), not, otherwise) +import Prelude ( Bool(..), (&&), (||), not, otherwise ) +import Prelude( Num ) -- For -frebindable-known-key-names (defaulting) -- $setup -- >>> import Prelude ===================================== libraries/base/src/Data/Enum.hs ===================================== @@ -25,7 +25,7 @@ module Data.Enum ) where import GHC.Internal.Enum -import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- | Returns a list of all values of an enum type -- ===================================== libraries/base/src/Data/List.hs ===================================== @@ -193,6 +193,7 @@ import GHC.Internal.Int (Int) import GHC.Internal.Num ((-)) import GHC.List (build) import qualified Data.List.NubOrdSet as NubOrdSet +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) inits1, tails1 :: [a] -> [NonEmpty a] ===================================== libraries/base/src/Data/List/NubOrdSet.hs ===================================== @@ -14,6 +14,7 @@ module Data.List.NubOrdSet ( import Data.Bool (Bool(..)) import GHC.Internal.Data.Function ((.)) import GHC.Internal.Data.Ord (Ordering(..)) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- | Implemented as a red-black tree, a la Okasaki. data NubOrdSet a ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -7,12 +7,11 @@ -- Stability : internal -- Portability : non-portable (GHC Extensions) -- --- TODO: Note on KnownKeyNames by export --- module GHC.KnownKeyNames ( Rational - , Eq, Ord, Show, Num, Bounded + , Eq, Ord, Show, Num + , Enum, Bounded , Foldable, Traversable , IsString , Functor, Monad ===================================== libraries/base/src/GHC/RTS/Flags.hs ===================================== @@ -62,6 +62,7 @@ import qualified GHC.Internal.RTS.Flags as Internal import GHC.Internal.IO.SubSystem (IoSubSystem(..)) import Data.Word (Word32,Word64,Word) +import Prelude( Num ) -- For -frebindable-known-key-names (used when defaulting) -- | 'RtsTime' is defined as a @StgWord64@ in @stg/Types.h@ -- ===================================== libraries/base/src/GHC/Stats.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Stats import Prelude (Bool,IO,Read,Show,(<$>)) +import Prelude (Num) -- For -frebindable-known-key-names (defaulting) import qualified GHC.Internal.Stats as Internal import GHC.Generics (Generic) ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -34,6 +34,7 @@ import Data.Maybe (Maybe (Nothing)) import Data.String (String) import Data.Eq ((/=)) import System.IO (IO, hPutStrLn, stderr) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- --------------------------------------------------------------------------- -- exitWith ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -61,6 +61,7 @@ import GHC.IO.Exception ) import Foreign.Ptr (Ptr) import Foreign.C.Types (CInt) +import GHC.Internal.Num( Num ) -- For -frebindable-known-key-names (defaulting) -- * Obtaining POSIX file descriptors and Windows handles ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String.hs ===================================== @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines IsString + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Data.String ===================================== libraries/ghc-prim/ghc-prim.cabal ===================================== @@ -26,6 +26,10 @@ Library build-depends: ghc-internal + ghc-options: -frebindable-known-key-names + -- Do not create dependencies on GHC.KnownKeyNames! + -- It doesn't exist yet. + other-modules: -- dummy module to make Hadrian/GHC build a valid library... Dummy ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -61,7 +61,7 @@ main = do , "import B" ] , [ "module B !parse_error where" - -- ^ this used to cause getImports to throw an exception instead + -- ^ this used to cause getImportEdges to throw an exception instead -- of having downsweep return an error for just this module , "import C" ] @@ -95,7 +95,7 @@ main = do ] , [ "module B where" , "!parse_error" - -- ^ this is silently ignored, getImports assumes the import + -- ^ this is silently ignored, getImportEdges assumes the import -- list is just empty. This smells like a parser bug to me but -- I'm still documenting this behaviour here. , "import C" ===================================== testsuite/tests/parser/should_fail/T16270h.hs ===================================== @@ -1,5 +1,5 @@ -- We can't test module header parsing errors using the same file as other --- parsing errors (in ../T16270.hs) because HeaderInfo.getImports fails fast +-- parsing errors (in ../T16270.hs) because HeaderInfo.getImportEdges fails fast -- on parsing imports: -- -- if errorsFound dflags ms View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e86bd93aadad57b40a75663eb474b5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e86bd93aadad57b40a75663eb474b5... You're receiving this email because of your account on gitlab.haskell.org.