Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 186353a8 by Rodrigo Mesquita at 2026-05-14T16:36:36+01:00 fix serialization; tuples; [skip ci] - - - - - 5 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Iface/Binary.hs - libraries/ghc-internal/src/GHC/Internal/Records.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -26,11 +26,15 @@ module GHC.Builtin ( knownKeyTable, knownKeyOccMap, knownKeyUniqMap, knownKeyOccName, knownKeyOccName_maybe, + -- * Known names + isWiredInKnownKeyName, + lookupWiredInKnownKeyName, + lookupKnownNameInfo, + -- * Random other things maybeCharLikeCon, maybeIntLikeCon, allNameStrings, allNameStringList, itName, mkUnboundName, isUnboundName, - lookupKnownNameInfo, -- * Class categories isNumericClass, isStandardClass, @@ -42,6 +46,7 @@ module GHC.Builtin ( import GHC.Prelude +import GHC.Builtin.Uniques import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids import GHC.Builtin.WiredIn.Types @@ -72,6 +77,10 @@ import GHC.Data.List.SetOps import GHC.Data.FastString import qualified GHC.Data.List.Infinite as Inf +import Control.Applicative ((<|>)) +import Data.Maybe + + {- ********************************************************************* * * @@ -570,11 +579,17 @@ wiredInNames Nothing -> [] -- | Check the known-key names list of consistency. --- (a) Distinct uniques +-- (a) Unique is in-range +-- (b) Distinct uniques knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names - | null badNamesPairs = Nothing - | otherwise = Just badNamesDoc + | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names + = Just $ text " Out-of-range known-key uniques: " <> + brackets (pprWithCommas (ppr . nameOccName) ns) + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesDoc where namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) emptyUFM all_names @@ -591,6 +606,25 @@ knownKeyNamesOkay all_names text ": " <> brackets (pprWithCommas (ppr . nameOccName) ns) +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- wired-in thing. +lookupWiredInKnownKeyName :: Unique -> Maybe Name +lookupWiredInKnownKeyName u = + knownUniqueTupleName u <|> lookupUFM_Directly wiredInNamesMap u + +-- | Is a 'Name' a wired-in known-key name? +isWiredInKnownKeyName :: Name -> Bool +isWiredInKnownKeyName n = + isJust (knownUniqueTupleName $ nameUnique n) || elemUFM n wiredInNamesMap + +-- | Maps 'Unique's to known-key names. +-- +-- The type is @UniqFM Name Name@ to denote that the 'Unique's used +-- in the domain are 'Unique's associated with 'Name's (as opposed +-- to some other namespace of 'Unique's). +wiredInNamesMap :: UniqFM Name Name +wiredInNamesMap = listToIdentityUFM wiredInNames + -- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by -- GHCi's ':info' command. lookupKnownNameInfo :: Name -> SDoc ===================================== compiler/GHC/Builtin/Uniques.hs ===================================== @@ -8,8 +8,8 @@ -- module GHC.Builtin.Uniques - ( -- * Looking up known-key names - knownUniqueName + ( -- * Looking up known-key tuples + knownUniqueTupleName -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums @@ -73,9 +73,9 @@ import GHC.Utils.Panic import Data.Maybe import GHC.Utils.Word64 (word64ToInt) --- | Get the 'Name' associated with a known-key 'Unique'. -knownUniqueName :: Unique -> Maybe Name -knownUniqueName u = +-- | Get the 'Name' of a tuple associated with a known-key 'Unique' with a tuple tag. +knownUniqueTupleName :: Unique -> Maybe Name +knownUniqueTupleName u = case tag of SumTag -> Just $ getUnboxedSumName n BoxedTupleTyConTag -> Just $ getTupleTyConName Boxed n ===================================== compiler/GHC/Builtin/Uniques.hs-boot ===================================== @@ -2,12 +2,8 @@ module GHC.Builtin.Uniques where import GHC.Prelude import GHC.Types.Unique -import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic --- Needed by GHC.Builtin.Types -knownUniqueName :: Unique -> Maybe Name - mkSumTyConUnique :: Arity -> Unique mkSumDataConUnique :: ConTagZ -> Arity -> Unique ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -32,13 +32,14 @@ module GHC.Iface.Binary ( import GHC.Prelude -import GHC.Builtin ( knownKeyOccMap ) +import GHC.Builtin ( knownKeyOccMap, isWiredInKnownKeyName, lookupWiredInKnownKeyName ) import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Unique.FM +import GHC.Types.Unique import GHC.Types.SrcLoc import GHC.Types.Name.Cache @@ -57,6 +58,7 @@ import Control.Monad import Data.Array import Data.Array.IO import Data.Array.Unsafe +import Data.Char import Data.IORef import Data.Map.Strict (Map) import Data.Word @@ -701,11 +703,43 @@ getSymbolTable bh name_cache ; writeArray mut_arr (fromIntegral i) name ; return new_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 + A normal name. x is an index into the symbol table + 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy + A wired-in name. x is the Unique's Char, y is the int part. We assume that + all wired-in known-key uniques fit in this space. This is asserted by + GHC.Builtin.knownKeyNamesOkay. + +During serialization we check for tuples or wired-in things with 'isWiredInKnownKeyName'. +During deserialization we use 'lookupWiredInKnownKeyName' to get from the +unique back to its tuple or corresponding Name. + +Tuples are a special case of wired-in names that we can construct from the +unique alone (see 'knownUniqueTupleName'). Tuples aren't included in the +wired-in names map: see Note [Infinite families of known-key names]. +-} + + +-- See Note [Symbol table representation of names] putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO () putName BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name + | isWiredInKnownKeyName name + , let (c, u) = unpkUniqueGrimly (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- assert (u < 2^(22 :: Int)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + + | otherwise = do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of Just (off,_) -> put_ bh (fromIntegral off :: Word32) @@ -717,8 +751,23 @@ putName BinSymbolTable{ $! addToUFM symtab_map name (off,name) put_ bh (fromIntegral off :: Word32) +-- See Note [Symbol table representation of names] getSymtabName :: SymbolTable Name -> ReadBinHandle -> IO Name getSymtabName symtab bh = do i :: Word32 <- get bh - return $! symtab ! fromIntegral i + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x80000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + u = mkUniqueGrimilyWithTag tag ix + in + return $! case lookupWiredInKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr u $$ char tag $$ ppr ix) + Just n -> n + + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) ===================================== libraries/ghc-internal/src/GHC/Internal/Records.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Internal.Records import GHC.Internal.Base import GHC.Internal.Err( error ) -import GHC.Internal.Stack.Types +import GHC.Internal.Stack.Types as Rebindable -- | Constraint representing the fact that the field @x@ belongs to -- the record type @r@ and has field type @a@. This will be solved View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186353a82aa0fc1145b887d4b63610ed... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/186353a82aa0fc1145b887d4b63610ed... You're receiving this email because of your account on gitlab.haskell.org.