Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 6258c4e6 by Simon Peyton Jones at 2026-03-16T00:00:00+00:00 More or less working - - - - - 7 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Iface/Env.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Types/Name.hs - libraries/base/src/Prelude.hs - libraries/ghc-internal/src/GHC/Internal/Real.hs-boot Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -654,7 +654,7 @@ mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n)) pRELUDE_NAME, mAIN_NAME, kNOWN_KEY_NAMES :: ModuleName pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") mAIN_NAME = mkModuleNameFS (fsLit "Main") -kNOWN_KEY_NAMES = mkModuleNameFS (fsLit "KnownKeyNames") +kNOWN_KEY_NAMES = mkModuleNameFS (fsLit "GHC.KnownKeyNames") mkGhcInternalModule :: FastString -> Module ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1383,6 +1383,7 @@ languageExtensions Nothing = languageExtensions (Just defaultLanguage) languageExtensions (Just Haskell98) = [LangExt.ImplicitPrelude, + LangExt.ImplicitKnownKeyNames, -- See Note [When is StarIsType enabled] LangExt.StarIsType, LangExt.CUSKs, @@ -1405,6 +1406,7 @@ languageExtensions (Just Haskell98) languageExtensions (Just Haskell2010) = [LangExt.ImplicitPrelude, + LangExt.ImplicitKnownKeyNames, -- See Note [When is StarIsType enabled] LangExt.StarIsType, LangExt.CUSKs, @@ -1424,6 +1426,7 @@ languageExtensions (Just Haskell2010) languageExtensions (Just GHC2021) = [LangExt.ImplicitPrelude, + LangExt.ImplicitKnownKeyNames, -- See Note [When is StarIsType enabled] LangExt.StarIsType, LangExt.MonomorphismRestriction, ===================================== compiler/GHC/Iface/Env.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc( HasDebugCallStack ) -import GHC.Utils.Panic( callStackDoc ) +import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Logger @@ -76,7 +76,7 @@ newGlobalBinder mod occ mb_uniq loc = do { hsc_env <- getTopEnv ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ mb_uniq loc ; traceIf (text "newGlobalBinder" <+> - vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name, callStackDoc]) + vcat [ ppr mod <+> ppr occ <+> ppr loc <+> ppr mb_uniq, ppr name, callStackDoc]) ; return name } newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name @@ -113,11 +113,13 @@ allocateGlobalBinder nc mod occ mb_uniq loc Just name | isWiredInName name -> pure (cache0, name) | otherwise - -> warnPprTrace wrong_unique "allocateGlobalBinder" (ppr mb_uniq $$ ppr name) $ + -> assertPpr (not wrong_unique) + (hang (text "allocateGlobalBinder:bad known-key unique") + 2 (ppr mb_uniq $$ ppr name)) $ pure (new_cache, name') where uniq = nameUnique name - name' = mkExternalName uniq mod occ loc + name' = setNameLoc name loc -- name' is like name, but with the right SrcSpan new_cache = extendOrigNameCache cache0 mod occ name' wrong_unique = case mb_uniq of @@ -126,13 +128,12 @@ allocateGlobalBinder nc mod occ mb_uniq loc -- Miss in the cache! -- Build a completely new Name, and put it in the cache - _ -> do - uniq <- case mb_uniq of - Just uniq -> return uniq - Nothing -> takeUniqFromNameCache nc - let name = mkExternalName uniq mod occ loc - let new_cache = extendOrigNameCache cache0 mod occ name - pure (new_cache, name) + _ -> do { name <- case mb_uniq of + Just uniq -> return (mkKnownKeyName uniq mod occ loc) + Nothing -> do { uniq <- takeUniqFromNameCache nc + ; return (mkExternalName uniq mod occ loc) } + ; let new_cache = extendOrigNameCache cache0 mod occ name + ; pure (new_cache, name) } ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = return exports ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -139,14 +139,19 @@ lookupKnownKeyThing :: HasDebugCallStack lookupKnownKeyThing Nothing uniq = do { known_key_name_map <- loadKnownKeyOccMap ; let name = lookupUFM known_key_name_map uniq - `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq) + `orElse` pprPanic "lookupKnownKeyThing" (ppr uniq $$ ppr known_key_name_map) + ; traceIf $ hang (text "lookupKnownKeyThing ImplicitKnownKeyNames") + 2 (ppr name <+> ppr uniq) ; lookupGlobalName name } lookupKnownKeyThing (Just gbl_rdr_env) uniq -- Look up the known-key OccName in the current top-level GlobalRdrEnv -- If we get a unique hit, use it; if not, panic. = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of - [gre] -> lookupGlobalName (greName gre) + [gre] -> do { let name = greName gre + ; traceIf $ hang (text "lookupKnownKeyThing NoImplicitKnownKeyNames") + 2 (ppr name <+> ppr uniq) + ; lookupGlobalName name } gres -> pprPanic "lookupKnownKeyOcc" (ppr occ $$ ppr gres) where occ = lookupUFM knownKeyUniqMap uniq @@ -321,8 +326,7 @@ importDecl name { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of Just thing -> return $ Succeeded thing - Nothing -> pprTrace "importDecl" (ppr name $$ callStackDoc) $ - return $ Failed $ + Nothing -> return $ Failed $ Can'tFindNameInInterface name (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps) }}} @@ -637,6 +641,8 @@ loadInterface doc_str mod from -- Crucial assertion that checks if you are trying to load a HPT module into the EPS. -- If you start loading HPT modules into the EPS then you get strange errors about -- overlapping instances. + ; traceIf (hang (text "Loaded new interface" <+> ppr mod) + 2 (ppr (mi_exports iface))) ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -753,8 +753,8 @@ pprName_userQual user_qual name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ sdocOption sdocListTuplePuns $ \listTuplePuns -> handlePuns listTuplePuns (namePun_maybe name) $ case sort of - WiredIn mod _ bi -> pprExternal debug sty uniq mod user_qual occ (text "(w)") bi - External mod -> pprExternal debug sty uniq mod user_qual occ empty UserSyntax + WiredIn mod _ bi -> pprExternal debug sty uniq mod user_qual occ (text "(w)") bi + External mod -> pprExternal debug sty uniq mod user_qual occ (text "(x)") UserSyntax KnownKey mod -> pprExternal debug sty uniq mod user_qual occ (text "(k)") UserSyntax System -> pprSystem debug sty uniq occ Internal -> pprInternal debug sty uniq occ ===================================== libraries/base/src/Prelude.hs ===================================== @@ -183,3 +183,4 @@ import GHC.Internal.Num import GHC.Internal.Real import GHC.Internal.Float import GHC.Internal.Show + ===================================== libraries/ghc-internal/src/GHC/Internal/Real.hs-boot ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefinesKnownKeyNames #-} module GHC.Internal.Real (Integral (..)) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6258c4e6c60d893276cd045e86ca73e6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6258c4e6c60d893276cd045e86ca73e6... You're receiving this email because of your account on gitlab.haskell.org.