Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 54a71f69 by Simon Peyton Jones at 2026-03-19T17:46:04+00:00 Onward... [skip ci] - - - - - 8 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Types.hs - libraries/base/src/GHC/KnownKeyNames.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -210,6 +210,7 @@ basicKnownKeyTable , (mkTcOcc "Bounded", boundedClassKey) , (mkTcOcc "Enum", enumClassKey) , (mkTcOcc "Monad", monadClassKey) + , (mkTcOcc "Functor", functorClassKey) ] basicKnownKeyNames :: [Name] -- See Note [Known-key names] @@ -218,7 +219,6 @@ basicKnownKeyNames ++ [ -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) -- classes in "Class.standardClassKeys" (quite a few) - functorClassName, realClassName, -- numeric integralClassName, -- numeric fractionalClassName, -- numeric ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -563,7 +563,7 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal -dsLookupKnownKey :: Unique -> DsM TyThing +dsLookupKnownKey :: KnownKeyNameKey -> DsM TyThing dsLookupKnownKey uniq = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames ; mb_rdr_env <- if rebindable_path @@ -575,7 +575,7 @@ dsLookupKnownKey uniq Succeeded thing -> return thing Failed msg -> failIfM (pprDiagnostic msg) } } -dsLookupKnownKeyTyCon :: Unique -> DsM TyCon +dsLookupKnownKeyTyCon :: KnownKeyNameKey -> DsM TyCon dsLookupKnownKeyTyCon uniq = tyThingTyCon <$> dsLookupKnownKey uniq ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Iface.Errors.Ppr , missingInterfaceErrorReason , missingInterfaceErrorDiagnostic , readInterfaceErrorDiagnostic + , defaultIfaceMessageOpts , lookingForHerald , cantFindErrorX ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -4,6 +4,7 @@ -} +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} @@ -63,10 +64,7 @@ import GHC.Iface.Binary import GHC.Iface.Rename import GHC.Iface.Env import GHC.Iface.Errors as Iface_Errors - -import GHC.Rename.Env( addUsedGRE ) -import GHC.Rename.Utils( DeprecationWarnings(..) ) - +import GHC.Iface.Errors.Ppr( defaultIfaceMessageOpts ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad @@ -101,7 +99,7 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv import GHC.Types.Unique.DSet -import GHC.Types.Unique.FM( listToUFM, lookupUFM ) +import GHC.Types.Unique.FM( UniqFM, listToUFM, lookupUFM ) import GHC.Types.SrcLoc import GHC.Types.TyThing import GHC.Types.PkgQual @@ -148,7 +146,7 @@ lookupKnownKeyName :: HasDebugCallStack => Maybe GlobalRdrEnv -> KnownKeyNameKey -> IfM lcl Name lookupKnownKeyName Nothing uniq - = do { known_key_name_map <- loadKnownKeyOccMap + = do { known_key_name_map :: UniqFM KnownKeyNameKey Name <- loadKnownKeyOccMap ; let name = lookupUFM known_key_name_map uniq `orElse` pprPanic "lookupKnownKeyThing 1" (vcat [ text "unique:" <+> ppr uniq @@ -162,21 +160,22 @@ lookupKnownKeyName (Just gbl_rdr_env) uniq -- here is the top-level GlobalRdrEnv -- Look up the known-key OccName in the GlobalRdrEnv -- If we get a unique hit, use it; if not, panic. + | let occ :: OccName + occ = lookupUFM knownKeyUniqMap uniq + `orElse` pprPanic "lookupKnownKeyThing: missing key" + (vcat [ text "unique:" <+> ppr uniq + , text "uniq-map:" <+> ppr knownKeyUniqMap ]) = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of [gre] -> do { let name = greName gre - ; addUsedGRE NoDeprecationWarnings gre - -- addUseGRE: don't complain about unused imports - -- of known-key names when -frebindable-known-key-names +-- ; addUsedGRE NoDeprecationWarnings gre +-- -- addUseGRE: don't complain about unused imports +-- -- of known-key names when -frebindable-known-key-names ; traceIf $ hang (text "lookupKnownKeyThing NoImplicitKnownKeyNames") 2 (ppr name <+> ppr uniq) ; return name } - [] -> pprPanic "lookupKnownKeyOcc: known-key name is not in scope" (ppr occ) - gres -> pprPanic "lookupKnownKeyOcc: known-key name is ambiguously in scope" (ppr gres) + [] -> pprPanic "lookupKnownKeyName: known-key name is not in scope" (ppr occ) + gres -> pprPanic "lookupKnownKeyName: known-key name is ambiguously in scope" (ppr gres) where - occ = lookupUFM knownKeyUniqMap uniq - `orElse` pprPanic "lookupKnownKeyThing 2" - (vcat [ text "unique:" <+> ppr uniq - , text "uniq-map:" <+> ppr knownKeyUniqMap ]) loadKnownKeyOccMap :: IfM lcl KnownKeyNameMap loadKnownKeyOccMap @@ -191,7 +190,10 @@ loadKnownKeyOccMap ; mb_res <- liftIO $ findImportedModule hsc_env kNOWN_KEY_NAMES NoPkgQual ; iface <- case mb_res of Found _ mod -> loadInterfaceWithException doc mod ImportBySystem - _ -> panic "loadKnownKeyOccMap" -- ToDo tidy up + fr -> do { hsc_env <- getHscEnv + ; pprPanic "loadKnownKeyOccMap" $ + missingInterfaceErrorDiagnostic defaultIfaceMessageOpts $ + cannotFindModule hsc_env kNOWN_KEY_NAMES fr } ; let occ_map :: KnownKeyNameMap occ_map = listToUFM [ (getUnique nm, nm) @@ -201,10 +203,26 @@ loadKnownKeyOccMap -- Record the KnownKeyOccMap in the EPS, so we will find it next time ; updateEps_ (\eps -> eps { eps_known_keys = Just occ_map }) +#ifdef DEBUG + ; case checkKnownKeyNamesIface occ_map of + Just msg -> pprPanic "Missing exports in KnownKeyNames" msg + Nothing -> return () +#endif ; return occ_map } } } where doc = text "Need interface for KnonwKeyNames" +checkKnownKeyNamesIface :: KnownKeyNameMap -> Maybe SDoc +-- Check that KnownKeyNames exports all the things defined in `basicKnownKeyTable` +-- and the the uniques and occ-names agree +checkKnownKeyNamesIface known_key_names_occ_map + | null bad_ones = Nothing + | otherwise = Just (ppr bad_ones) + where + bad_ones = filter is_bad basicKnownKeyTable + is_bad (occ, key) = case lookupUFM known_key_names_occ_map key of + Nothing -> True + Just name -> getOccName name /= occ {- ********************************************************************* * * ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -70,8 +70,7 @@ import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Builtin.Types -import GHC.Builtin.Utils( knownKeyOccMap ) -import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Builtin.Names import GHC.Types.Name import GHC.Types.Name.Set @@ -87,7 +86,6 @@ import GHC.Types.Basic ( TupleSort(..), tupleSortBoxity ) import GHC.Types.TyThing ( tyThingGREInfo ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set ===================================== compiler/GHC/Tc/Deriv/Infer.hs ===================================== @@ -346,7 +346,7 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $ -- Generic1 has a single kind variable assert (cls_tys `lengthIs` 1) $ - do { functorClass <- lift $ tcLookupClass functorClassName + do { functorClass <- lift $ tcLookupKnownKeyClass functorClassKey ; pure $ con_arg_constraints $ get_gen1_constraints functorClass } ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -349,6 +349,7 @@ data IfGblEnv -- Some information about where this environment came from; -- useful for debugging. if_doc :: SDoc, + -- The type environment for the module being compiled, -- in case the interface refers back to it via a reference that -- was originally a hi-boot file. ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -11,7 +11,12 @@ -- module GHC.KnownKeyNames - ( Rational -- TODO: add more than rational after smoke test - ) where + ( Rational + , Eq, Ord, Show, Num, Bounded + , Foldable, Traversable + , IsString + , Functor, Monad + ) where -import GHC.Internal.Real +import Prelude +import Data.String( IsString ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54a71f69902797e60c69b57debe0125c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54a71f69902797e60c69b57debe0125c... You're receiving this email because of your account on gitlab.haskell.org.