[Git][ghc/ghc][wip/spj-reinstallable-base2] fix serialization; tuples; [skip ci]

14 May 2026

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.

    

Rodrigo Mesquita (＠alt-romes)

tags

participants (1)