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: ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -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 () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23db8741032098b26ff7d6be63add4d7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23db8741032098b26ff7d6be63add4d7... You're receiving this email because of your account on gitlab.haskell.org.