Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 510ae59d by Simon Peyton Jones at 2026-04-08T11:55:00+01:00 More fixes - - - - - 5 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Iface/Binary.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Utils/Env.hs - libraries/base/src/GHC/KnownKeyNames.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -291,6 +291,15 @@ Wrinkles So we compile GHC.Internal.Data.Foldable with -fexclude-known-key-define=toList +(KKN3) You don't need need to export the wired-in entities from GHC.KnownKeyNames + because we (should) never look up a wired-in name via its key. That is, + `GHC.Iface.Load.lookupKnownKeyName` should never be called on the key of + a wired-in name. + + Alternative: export all wired-in entities from GHC.KnownKeyNames. But that + would simply bloat the interface for no good reason. + + Note [Recipe for adding a known-occ name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To make `wombat` into a known-occ name, you must ensure that: @@ -452,6 +461,8 @@ wiredInNames Nothing -> [] -- | Check the known-key names list of consistency. +-- (a) Unique is in-range (ToDo: get rid of this) +-- (b) Distinct uniques knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -652,7 +652,10 @@ initNameWriterTable = do ) -putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO () +putSymbolTable :: WriteBinHandle + -> Int -- Size of the table + -> UniqFM Name (Int,Name) -- For each Name, its index in the table + -> IO () putSymbolTable bh name_count symtab = do { put_ bh name_count ; let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) @@ -702,7 +705,6 @@ getSymbolTable bh name_cache -- Note [Symbol table representation of names] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- -- An occurrence of a name in an interface file is serialized as a single 32-bit -- word. The format of this word is: -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -168,28 +168,39 @@ lookupKnownKeyThing key mb_gbl_rdr_env lookupKnownKeyName :: HasDebugCallStack => KnownKey -> KnownKeyNameSource -> IfM lcl (MaybeErr IfaceMessage Name) -lookupKnownKeyName uniq KKNS_FromModule +lookupKnownKeyName key KKNS_FromModule = do { (kk_map, _) <- loadKnownKeyOccMaps - ; case lookupUFM kk_map uniq of + ; case lookupUFM kk_map key of Just name -> return (Succeeded name) - Nothing -> return (Failed (MissingKnownKey1 uniq)) } - -lookupKnownKeyName uniq (KKNS_InScope gbl_rdr_env) + Nothing + | wired_in_nm : _ <- filter (`hasKey` key) wiredInNames + -> -- We should never call lookupKnownKeyName on the key of a wired-in + -- entity; see (KKN3) in Note [Overview of known-key entities] + -- We hackily panic here rather than use a civilised error + -- message so that we get a helpful stack backtrace + pprPanic "lookupKownKeyName" $ + hang (text "You tried to look up wired-in" + <+> quotes (ppr wired_in_nm) <+> text "in the known-key table") + 2 (text "Better to use the wired-in name directly") + | otherwise + -> return (Failed (MissingKnownKey1 key)) } + +lookupKnownKeyName key (KKNS_InScope gbl_rdr_env) -- Just gbl_rdr_env: we have -frebindable-known-key-names on, and -- here is the top-level GlobalRdrEnv -- Look up the /un-qualified/ known-key OccName in the GlobalRdrEnv -- If we get a unique hit, use it; if not, panic. - | Just (occ :: OccName) <- lookupUFM knownKeyUniqMap uniq + | Just (occ :: OccName) <- lookupUFM knownKeyUniqMap key = case lookupGRE gbl_rdr_env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) of [gre] -> do { let name = greName gre ; traceIf $ hang (text "lookupKnownKeyName1 NoImplicitKnownKeyNames") - 2 (ppr name <+> ppr uniq) + 2 (ppr name <+> ppr key) ; return (Succeeded name) } gres -> return (Failed (KnownKeyScopeError occ gres)) | otherwise - = pprTrace "lookup failed" (pprKnownKey uniq $$ callStackDoc) $ - return (Failed (MissingKnownKey2 uniq)) + = pprTrace "lookup failed" (pprKnownKey key $$ callStackDoc) $ + return (Failed (MissingKnownKey2 key)) lookupKnownOccThing :: HasDebugCallStack => KnownOcc -> KnownKeyNameSource ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -1118,12 +1118,11 @@ tcGetDefaultTys -- Not one of the built-in units -- @default Num (Integer, Double)@, plus extensions { extDef <- if extended_defaults - then do { list_tc <- tcLookupKnownKeyTyCon listTyConKey - ; foldableClass <- tcLookupKnownKeyClass foldableClassKey + then do { foldableClass <- tcLookupKnownKeyClass foldableClassKey ; showClass <- tcLookupKnownKeyClass showClassKey ; eqClass <- tcLookupKnownKeyClass eqClassKey ; pure $ defaultEnv - [ builtinDefaults foldableClass [mkTyConTy list_tc] + [ builtinDefaults foldableClass [mkTyConTy listTyCon] , builtinDefaults showClass [unitTy, integerTy, doubleTy] , builtinDefaults eqClass [unitTy, integerTy, doubleTy] ] ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -59,9 +59,8 @@ module GHC.KnownKeyNames , dataToTag# -- Numbers - , Num + , Num, Integral, Real, Fractional , (+), (-), (*), negate, fromInteger - , Integral, Real , fromRational , mkRationalBase2, mkRationalBase10 , divInt#, modInt# @@ -70,7 +69,7 @@ module GHC.KnownKeyNames , IsString , fromString - -- Records and lists + -- Records , HasField , fromLabel, getField @@ -129,8 +128,8 @@ module GHC.KnownKeyNames , pragSpecED, pragSpecInlED , pragSpecInstD, pragRuleD, pragCompleteD, pragAnnD, pragSCCFunD , pragSCCFunNamedD, dataInstD, newtypeInstD, tySynInstD, openTypeFamilyD - , closedTypeFamilyD, dataFamilyD, infixLWithSpecD, infixRWithSpecD, roleAnnotD - , patSynD, patSynSigD, implicitParamBindD + , closedTypeFamilyD, dataFamilyD, infixLWithSpecD, infixRWithSpecD, infixNWithSpecD + , roleAnnotD, patSynD, patSynSigD, implicitParamBindD , Lit, charL, stringL, integerL, intPrimL, wordPrimL, floatPrimL , doublePrimL, rationalL, stringPrimL, charPrimL , Pat, litP, varP, tupP, unboxedTupP, unboxedSumP, conP, infixP, tildeP View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/510ae59d208a74d23d09c960fddb073b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/510ae59d208a74d23d09c960fddb073b... You're receiving this email because of your account on gitlab.haskell.org.