GitLab

Rodrigo Mesquita pushed to branch wip/romes/27401-2 at Glasgow Haskell Compiler / GHC

Commits:

23db8741
by Rodrigo Mesquita at 2026-06-19T16:31:10+01:00
```
Apply Simons idea
```

2 changed files:

compiler/GHC/Iface/Binary.hs
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs

Changes:

@@ -61,8 +61,7 @@ import Data.Typeable (Typeable)
  import qualified GHC.Data.Strict as Strict
  import Data.Function ((&))
  import GHC.Types.Name.Env
 -import GHC.Types.Unique.DFM
+-
 +import Data.Maybe
  -- ---------------------------------------------------------------------------
  -- Reading and writing binary interface files
@@ -619,25 +618,30 @@ initNameReaderTable cache = do
+       }
  data BinSymbolTable = BinSymbolTable {
 -        bin_symtab_next :: !FastMutInt, -- The next index to use
 -        bin_symtab_map  :: !(IORef (ModuleEnv (DNameEnv (Int,Name))))
 -                                -- indexed by Name
 +        bin_symtab_next :: !FastMutInt,
 +                        -- ^ The next index to use
 +        bin_symtab_map  :: !(IORef (NameEnv Int)),
 +                        -- ^ Deduplication indexed by Name
 +        bin_symtab_tbl  :: !(IORef (ModuleEnv [(Int,Name)]))
 +                        -- ^ Group table data by module for serialization
+   }
  initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
  initNameWriterTable = do
    symtab_next <- newFastMutInt 0
 -  symtab_map <- newIORef emptyModuleEnv
 +  symtab_tbl <- newIORef emptyModuleEnv
 +  symtab_map <- newIORef emptyNameEnv
    let bin_symtab =
          BinSymbolTable
            { bin_symtab_next = symtab_next
 -          , bin_symtab_map = symtab_map
 +          , bin_symtab_map  = symtab_map
 +          , bin_symtab_tbl  = symtab_tbl
+           }
    let put_symtab bh = do
          name_count <- readFastMutInt symtab_next
 -        symtab_map <- readIORef symtab_map
 -        putSymbolTable bh name_count symtab_map
 +        symtab_tbl <- readIORef symtab_tbl
 +        putSymbolTable bh name_count symtab_tbl
          pure name_count
    return
@@ -660,14 +664,14 @@ The symbol table payload will look like:
        $table_ix
        $occ
  -}
 -putSymbolTable :: WriteBinHandle -> Int -> ModuleEnv (DNameEnv (Int, Name)) -> IO ()
 +putSymbolTable :: WriteBinHandle -> Int -> ModuleEnv [(Int, Name)] -> IO ()
  putSymbolTable bh name_count symtab = do
      put_ bh name_count
      put_ bh (sizeModuleEnv symtab)
 -    forM_ (moduleEnvToList symtab) $ \(mod,namesEnv) -> do
 +    forM_ (moduleEnvToList symtab) $ \(mod,names) -> do
        put_ bh mod
 -      put_ bh (sizeUDFM namesEnv)
 -      forM_ (eltsDNameEnv namesEnv) $ \(table_ix, name) -> do
 +      put_ bh (length names) -- todo: don't use length?
 +      forM_ names $ \(table_ix, name) -> do
          let occ = assertPpr (isExternalName name) (ppr name) (nameOccName name)
          put_ bh table_ix
          put_ bh occ
@@ -680,11 +684,9 @@ getSymbolTable bh name_cache = do
      updateNameCache' name_cache $ \cache0 -> do
        mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
        mods_sz <- get bh :: IO Int
 -      let
 -        go_mod_name cache1 _mods_ix = do
 -          mod <- get bh :: IO Module
 -          mod_nms_sz <- get bh :: IO Int
 -          foldGet' (fromIntegral mod_nms_sz) bh cache1 $ \_mod_nms_ix (table_ix, occ) cache2 -> do
 +      cache <-
 +        foldGet' (fromIntegral mods_sz) bh cache0 $ \_mod_ix (mod,mod_nms_sz) cache1 -> do
 +          foldGet' (fromIntegral (mod_nms_sz::Int)) bh cache1 $ \_mod_nms_ix (table_ix, occ) cache2 -> do
              case lookupOrigNameCache cache2 mod occ of
                Just name -> do
                  writeArray mut_arr table_ix name
@@ -693,9 +695,8 @@ getSymbolTable bh name_cache = do
                  uniq <- takeUniqFromNameCache name_cache
                  let name   = mkExternalName uniq mod occ noSrcSpan
                      cache3 = extendOrigNameCache cache2 mod occ name
 -                writeArray mut_arr table_ix name
 +                writeArray mut_arr table_ix name -- todo: are these being forced? experiment and measure
                  return cache3
 -      cache <- foldM go_mod_name cache0 [0..mods_sz-1]
        arr <- unsafeFreeze mut_arr
        return (cache, arr)
@@ -721,6 +722,7 @@ getSymbolTable bh name_cache = do
  putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
  putName BinSymbolTable{
                 bin_symtab_map = symtab_map_ref,
 +               bin_symtab_tbl = symtab_tbl_ref,
                 bin_symtab_next = symtab_next }
          bh name
    | isKnownKeyName name
@@ -732,21 +734,20 @@ putName BinSymbolTable{
    | otherwise
    = do symtab_map <- readIORef symtab_map_ref
 -       let mod = nameModule name
 -       case lookupModuleEnv symtab_map mod of
 -         Just nm_env ->
 -          case lookupDNameEnv nm_env name of
 -            Just (off,_) -> put_ bh (fromIntegral off :: Word32)
 -            Nothing -> do
 -              off <- freshIndex
 -              writeIORef symtab_map_ref
 -                $! extendModuleEnv symtab_map mod (extendDNameEnv nm_env name (off,name))
 -              put_ bh (fromIntegral off :: Word32)
 +       case lookupNameEnv symtab_map name of
 +         Just off -> put_ bh (fromIntegral off :: Word32)
           Nothing -> do
 -            off <- freshIndex
 -            writeIORef symtab_map_ref
 -              $! extendModuleEnv symtab_map mod (extendDNameEnv emptyDNameEnv name (off,name))
 -            put_ bh (fromIntegral off :: Word32)
 +          off <- freshIndex
 +          let mod = nameModule name
 +          symtab_tbl <- readIORef symtab_tbl_ref
 +          let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod)
++
 +          writeIORef symtab_tbl_ref $!
 +            extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
++
 +          writeIORef symtab_map_ref
 +              $! extendNameEnv symtab_map name off
 +          put_ bh (fromIntegral off :: Word32)
    where
      freshIndex :: IO Int
      freshIndex = do

utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs

@@ -40,6 +40,7 @@ import Data.Coerce (coerce)
  import Data.Function ((&))
  import Data.IORef
  import Data.Map (Map)
 +import Data.Maybe (fromMaybe)
  import Data.Version
  import Data.Word
  import GHC hiding (NoLink)
@@ -172,11 +173,13 @@ writeInterfaceFile filename iface = do
    -- Make some intial state
    symtab_next <- newFastMutInt 0
 -  symtab_map <- newIORef emptyModuleEnv
 +  symtab_tbl <- newIORef emptyModuleEnv
 +  symtab_map <- newIORef emptyNameEnv
    let bin_symtab =
          BinSymbolTable
            { bin_symtab_next = symtab_next
            , bin_symtab_map = symtab_map
 +          , bin_symtab_tbl = symtab_tbl
+           }
    dict_next_ref <- newFastMutInt 0
    dict_map_ref <- newIORef emptyUFM
@@ -212,8 +215,8 @@ writeInterfaceFile filename iface = do
    -- write the symbol table itself
    symtab_next' <- readFastMutInt symtab_next
 -  symtab_map' <- readIORef symtab_map
 -  putSymbolTable bh symtab_next' symtab_map'
 +  symtab_tbl' <- readIORef symtab_tbl
 +  putSymbolTable bh symtab_next' symtab_tbl'
    -- write the dictionary pointer at the fornt of the file
    dict_p <- tellBinWriter bh
@@ -265,26 +268,26 @@ putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
  putName
    BinSymbolTable
      { bin_symtab_map = symtab_map_ref
 +    , bin_symtab_tbl = symtab_tbl_ref
      , bin_symtab_next = symtab_next
+     }
    bh
    name =
      do
        symtab_map <- readIORef symtab_map_ref
 -      let mod' = nameModule name
 -      case lookupModuleEnv symtab_map mod' of
 -        Just nm_env ->
 -          case lookupDNameEnv nm_env name of
 -            Just (off, _) -> put_ bh (fromIntegral off :: Word32)
 -            Nothing -> do
 -              off <- freshIndex
 -              writeIORef symtab_map_ref $!
 -                extendModuleEnv symtab_map mod' (extendDNameEnv nm_env name (off, name))
 -              put_ bh (fromIntegral off :: Word32)
 +      case lookupNameEnv symtab_map name of
 +        Just off -> put_ bh (fromIntegral off :: Word32)
          Nothing -> do
            off <- freshIndex
 +          let mod' = nameModule name
 +          symtab_tbl <- readIORef symtab_tbl_ref
 +          let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod')
++
 +          writeIORef symtab_tbl_ref $!
 +            extendModuleEnv symtab_tbl mod' ((off, name) : mod_nms)
++
            writeIORef symtab_map_ref $!
 -            extendModuleEnv symtab_map mod' (extendDNameEnv emptyDNameEnv name (off, name))
 +            extendNameEnv symtab_map name off
            put_ bh (fromIntegral off :: Word32)
    where
      freshIndex :: IO Int
@@ -295,8 +298,10 @@ putName
  data BinSymbolTable = BinSymbolTable
    { bin_symtab_next :: !FastMutInt -- The next index to use
 -  , bin_symtab_map :: !(IORef (ModuleEnv (DNameEnv (Int, Name))))
 -  -- indexed by Name
 +  , bin_symtab_map :: !(IORef (NameEnv Int))
 +  -- ^ Deduplication indexed by Name
 +  , bin_symtab_tbl :: !(IORef (ModuleEnv [(Int, Name)]))
 +  -- ^ Group table data by module for serialization
+   }
  putFastString :: BinDictionary -> WriteBinHandle -> FastString -> IO ()