Rodrigo Mesquita pushed to branch wip/romes/27401-2 at Glasgow Haskell Compiler / GHC Commits: 4deefb6d by Rodrigo Mesquita at 2026-06-23T16:17:09+01:00 join ioreferences and use SizedSeq and don't duplicate the code in Haddock - - - - - edd56117 by Rodrigo Mesquita at 2026-06-23T16:19:31+01:00 SizedSeq requires reverse anyway - - - - - 1f2bb14b by Rodrigo Mesquita at 2026-06-23T16:49:08+01:00 accept test - - - - - 834d2101 by Rodrigo Mesquita at 2026-06-23T16:57:10+01:00 investigate ------------------------- Metric Decrease: InstanceMatching LinkableUsage01 ------------------------- - - - - - 10 changed files: - compiler/GHC/Iface/Binary.hs - testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout - testsuite/tests/rename/should_compile/T1792_imports.stdout - testsuite/tests/rename/should_compile/T18264.stdout - testsuite/tests/rename/should_compile/T4239.stdout - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs Changes: ===================================== compiler/GHC/Iface/Binary.hs ===================================== @@ -620,27 +620,24 @@ initNameReaderTable cache = do data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- ^ The next index to use - bin_symtab_map :: !(IORef (NameEnv Int)), + bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int,Name)])) -- ^ Deduplication indexed by Name - bin_symtab_tbl :: !(IORef (ModuleEnv [(Int,Name)])) - -- ^ Group table data by module for serialization + -- ; Group table data by module for serialization } initNameWriterTable :: IO (WriterTable, BinaryWriter Name) initNameWriterTable = do symtab_next <- newFastMutInt 0 - symtab_tbl <- newIORef emptyModuleEnv - symtab_map <- newIORef emptyNameEnv + symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv) let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next , bin_symtab_map = symtab_map - , bin_symtab_tbl = symtab_tbl } let put_symtab bh = do name_count <- readFastMutInt symtab_next - symtab_tbl <- readIORef symtab_tbl + (_, symtab_tbl) <- readIORef symtab_map putSymbolTable bh name_count symtab_tbl pure name_count @@ -670,7 +667,7 @@ putSymbolTable bh name_count symtab = do put_ bh (sizeModuleEnv symtab) forM_ (moduleEnvToList symtab) $ \(mod,names) -> do put_ bh mod - put_ bh (length names) -- todo: don't use length? + put_ bh (length names) forM_ names $ \(table_ix, name) -> do let occ = assertPpr (isExternalName name) (ppr name) (nameOccName name) put_ bh table_ix @@ -695,7 +692,7 @@ 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 -- todo: are these being forced? experiment and measure + writeArray mut_arr table_ix name return cache3 arr <- unsafeFreeze mut_arr return (cache, arr) @@ -722,7 +719,6 @@ 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 @@ -733,20 +729,18 @@ putName BinSymbolTable{ .|. (fromIntegral u :: Word32)) | otherwise - = do symtab_map <- readIORef symtab_map_ref + = do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref 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) + let !symtab_map' = extendNameEnv symtab_map name off + let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms) + writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' ) - writeIORef symtab_map_ref - $! extendNameEnv symtab_map name off put_ bh (fromIntegral off :: Word32) where freshIndex :: IO Int ===================================== testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout ===================================== @@ -1 +1 @@ -import DRFPatSynExport_A ( MkT, m ) +import DRFPatSynExport_A ( m, MkT ) ===================================== testsuite/tests/rename/should_compile/T1792_imports.stdout ===================================== @@ -1 +1 @@ -import qualified Data.ByteString as B ( putStr, readFile ) +import qualified Data.ByteString as B ( readFile, putStr ) ===================================== testsuite/tests/rename/should_compile/T18264.stdout ===================================== @@ -1,6 +1,6 @@ import Data.Char ( isDigit, isLetter ) import Data.List ( sortOn ) -import Data.Maybe ( fromJust, isJust ) +import Data.Maybe ( isJust, fromJust ) import qualified Data.Char as C ( isLetter, isDigit ) import qualified Data.List as S ( sort ) import qualified Data.List as T ( nub ) ===================================== testsuite/tests/rename/should_compile/T4239.stdout ===================================== @@ -1 +1 @@ -import T4239A ( (·), type (:+++)((:---), (:+++), X) ) +import T4239A ( type (:+++)((:---), (:+++), X), (·) ) ===================================== testsuite/tests/showIface/DocsInHiFile1.stdout ===================================== @@ -19,49 +19,53 @@ docs: export docs: [] declaration docs: - [elem -> [text: - -- | '()', 'elem'. - identifiers: - {DocsInHiFile.hs:14:13-16} - GHC.Internal.Data.Foldable.elem - {DocsInHiFile.hs:14:13-16} - elem], - D -> [text: - -- | A datatype. + [F -> [text: + -- | A type family identifiers:], - D0 -> [text: - -- ^ A constructor for 'D'. ' - identifiers: - {DocsInHiFile.hs:20:32} - D], - D1 -> [text: - -- ^ Another constructor + D:R:FInt -> [text: + -- | A type family instance + identifiers:], + D' -> [text: + -- | Another datatype... + identifiers:, + text: + -- ^ ...with two docstrings. identifiers:], - P -> [text: - -- | A class - identifiers:], - p -> [text: - -- | A class method - identifiers:], $fShowD -> [text: -- ^ 'Show' instance identifiers: {DocsInHiFile.hs:22:25-28} GHC.Internal.Show.Show], - D' -> [text: - -- | Another datatype... - identifiers:, - text: - -- ^ ...with two docstrings. + p -> [text: + -- | A class method + identifiers:], + P -> [text: + -- | A class + identifiers:], + D1 -> [text: + -- ^ Another constructor identifiers:], - D:R:FInt -> [text: - -- | A type family instance - identifiers:], - F -> [text: - -- | A type family - identifiers:]] + D0 -> [text: + -- ^ A constructor for 'D'. ' + identifiers: + {DocsInHiFile.hs:20:32} + D], + D -> [text: + -- | A datatype. + identifiers:], + elem -> [text: + -- | '()', 'elem'. + identifiers: + {DocsInHiFile.hs:14:13-16} + GHC.Internal.Data.Foldable.elem + {DocsInHiFile.hs:14:13-16} + elem]] arg docs: - [add -> 0: + [p -> 0: + text: + -- ^ An argument + identifiers:, + add -> 0: text: -- ^ First summand for 'add' identifiers: @@ -74,11 +78,7 @@ docs: 2: text: -- ^ Sum - identifiers:, - p -> 0: - text: - -- ^ An argument - identifiers:] + identifiers:] documentation structure: avails: [elem] ===================================== testsuite/tests/showIface/DocsInHiFileTH.stdout ===================================== @@ -6,137 +6,153 @@ docs: export docs: [] declaration docs: - [Tup2 -> [text: - -- |Matches a tuple of (a, a) - identifiers:], - f -> [text: - -- |The meaning of life - identifiers:], - g -> [text: - -- |Some documentation - identifiers:], - qux -> [text: - -- |This is qux + [D:R:WD13Foo -> [text: + -- |13 + identifiers:], + D:R:WD11Int0 -> [text: + -- |This is a data instance + identifiers:], + D:R:WD11Foo0 -> [text: + -- |11 + identifiers:], + D:R:WD11Bool0 -> [text: + -- |This is a newtype instance + identifiers:], + D:R:EBool -> [text: + -- |A type family instance + identifiers:], + $fF -> [text: + -- |14 identifiers:], - sin -> [text: - -- |15 + $fDka -> [text: + -- |Another new instance + identifiers:], + $fCTYPEList -> [text: + -- |Another new instance + identifiers:], + $fCTYPEInt -> [text: + -- |A new instance + identifiers:], + $fCTYPEFoo -> [text: + -- |7 + identifiers:], + WD6 -> [text: + -- |6 identifiers:], - wd1 -> [text: - -- |1 + WD5 -> [text: + -- |5 identifiers:], - wd17 -> [text: - -- |17 + WD4 -> [text: + -- |4 + identifiers:], + WD3 -> [text: + -- |3 + identifiers:], + WD12 -> [text: + -- |12 identifiers:], - wd18 -> [text: - -- |18 + WD11Int -> [text: + -- |This is a data instance constructor + identifiers:], + WD11Bool -> [text: + -- |This is a newtype instance constructor + identifiers:], + WD10 -> [text: + -- |10 identifiers:], - wd2 -> [text: - -- |2 - identifiers:], - wd20 -> [text: - -- |20 + quuz1_a -> [text: + -- |This is the record constructor's argument + identifiers:], + Quuz -> [text: + -- |This is a record constructor identifiers:], - wd8 -> [text: - -- |8 + Quux2 -> [text: + -- |This is Quux2 + identifiers:], + Quux1 -> [text: + -- |This is Quux1 + identifiers:], + Quux -> [text: + -- |This is Quux + identifiers:], + prettyPrint -> [text: + -- |Prettily prints the object + identifiers:], + Pretty -> [text: + -- |My cool class + identifiers:], + Foo -> [text: + -- |A new constructor identifiers:], - C -> [text: - -- |A new class + Foo -> [text: + -- |A new data type + identifiers:], + E -> [text: + -- |A type family identifiers:], - Corge -> [text: - -- |This is a newtype record constructor - identifiers:], runCorge -> [text: -- |This is the newtype record constructor's argument identifiers:], - E -> [text: - -- |A type family + Corge -> [text: + -- |This is a newtype record constructor + identifiers:], + C -> [text: + -- |A new class identifiers:], - Foo -> [text: - -- |A new data type - identifiers:], - Foo -> [text: - -- |A new constructor + wd8 -> [text: + -- |8 identifiers:], - Pretty -> [text: - -- |My cool class - identifiers:], - prettyPrint -> [text: - -- |Prettily prints the object - identifiers:], - Quux -> [text: - -- |This is Quux - identifiers:], - Quux1 -> [text: - -- |This is Quux1 - identifiers:], - Quux2 -> [text: - -- |This is Quux2 - identifiers:], - Quuz -> [text: - -- |This is a record constructor + wd20 -> [text: + -- |20 identifiers:], - quuz1_a -> [text: - -- |This is the record constructor's argument - identifiers:], - WD10 -> [text: - -- |10 + wd2 -> [text: + -- |2 + identifiers:], + wd18 -> [text: + -- |18 identifiers:], - WD11Bool -> [text: - -- |This is a newtype instance constructor - identifiers:], - WD11Int -> [text: - -- |This is a data instance constructor - identifiers:], - WD12 -> [text: - -- |12 + wd17 -> [text: + -- |17 identifiers:], - WD3 -> [text: - -- |3 - identifiers:], - WD4 -> [text: - -- |4 - identifiers:], - WD5 -> [text: - -- |5 + wd1 -> [text: + -- |1 identifiers:], - WD6 -> [text: - -- |6 + sin -> [text: + -- |15 identifiers:], - $fCTYPEFoo -> [text: - -- |7 - identifiers:], - $fCTYPEInt -> [text: - -- |A new instance - identifiers:], - $fCTYPEList -> [text: - -- |Another new instance - identifiers:], - $fDka -> [text: - -- |Another new instance - identifiers:], - $fF -> [text: - -- |14 + qux -> [text: + -- |This is qux identifiers:], - D:R:EBool -> [text: - -- |A type family instance - identifiers:], - D:R:WD11Bool0 -> [text: - -- |This is a newtype instance - identifiers:], - D:R:WD11Foo0 -> [text: - -- |11 - identifiers:], - D:R:WD11Int0 -> [text: - -- |This is a data instance - identifiers:], - D:R:WD13Foo -> [text: - -- |13 - identifiers:]] + g -> [text: + -- |Some documentation + identifiers:], + f -> [text: + -- |The meaning of life + identifiers:], + Tup2 -> [text: + -- |Matches a tuple of (a, a) + identifiers:]] arg docs: - [Tup2 -> 0: - text: - -- |The thing to match twice - identifiers:, + [WD11Int -> 0: + text: + -- |This is a data instance constructor argument + identifiers:, + WD11Bool -> 0: + text: + -- |This is a newtype instance constructor argument + identifiers:, + Quux2 -> 1: + text: + -- |I am a bool + identifiers:, + Quux1 -> 0: + text: + -- |I am an integer + identifiers:, + qux -> 1: + text: + -- |Arg dos + identifiers:, h -> 0: text: -- ^Your favourite number @@ -149,26 +165,10 @@ docs: text: -- ^A return value identifiers:, - qux -> 1: - text: - -- |Arg dos - identifiers:, - Quux1 -> 0: - text: - -- |I am an integer - identifiers:, - Quux2 -> 1: - text: - -- |I am a bool - identifiers:, - WD11Bool -> 0: - text: - -- |This is a newtype instance constructor argument - identifiers:, - WD11Int -> 0: - text: - -- |This is a data instance constructor argument - identifiers:] + Tup2 -> 0: + text: + -- |The thing to match twice + identifiers:] documentation structure: avails: [f] ===================================== testsuite/tests/showIface/NoExportList.stdout ===================================== @@ -6,7 +6,10 @@ docs: export docs: [] declaration docs: - [fα -> [text: + [$fEqR -> [text: + -- | A very lazy Eq instance + identifiers:], + fα -> [text: -- ^ Documentation for 'R'\'s 'fα' field. identifiers: {NoExportList.hs:14:38} @@ -14,10 +17,7 @@ docs: {NoExportList.hs:14:38} R {NoExportList.hs:14:45-46} - fα], - $fEqR -> [text: - -- | A very lazy Eq instance - identifiers:]] + fα]] arg docs: [] documentation structure: @@ -99,3 +99,4 @@ docs: ListTuplePuns ImplicitStagePersistence extensible fields: + ===================================== testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr ===================================== @@ -5,10 +5,10 @@ subsumption_sort_hole_fits.hs:2:5: warning: [GHC-88464] [-Wtyped-holes (in -Wdef • Relevant bindings include f :: [String] (bound at subsumption_sort_hole_fits.hs:2:1) Valid hole fits include - lines :: String -> [String] + words :: String -> [String] (imported from ‘Prelude’ (and originally defined in ‘GHC.Internal.Data.OldList’)) - words :: String -> [String] + lines :: String -> [String] (imported from ‘Prelude’ (and originally defined in ‘GHC.Internal.Data.OldList’)) repeat :: forall a. a -> [a] ===================================== utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs ===================================== @@ -173,13 +173,11 @@ writeInterfaceFile filename iface = do -- Make some intial state symtab_next <- newFastMutInt 0 - symtab_tbl <- newIORef emptyModuleEnv - symtab_map <- newIORef emptyNameEnv + symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv) 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 @@ -215,7 +213,7 @@ writeInterfaceFile filename iface = do -- write the symbol table itself symtab_next' <- readFastMutInt symtab_next - symtab_tbl' <- readIORef symtab_tbl + (_, symtab_tbl') <- readIORef symtab_map putSymbolTable bh symtab_next' symtab_tbl' -- write the dictionary pointer at the fornt of the file @@ -268,26 +266,22 @@ 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 + (symtab_map, symtab_tbl) <- readIORef symtab_map_ref 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 $! - extendNameEnv symtab_map name off + let !symtab_map' = extendNameEnv symtab_map name off + let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms) + writeIORef symtab_map_ref $! (symtab_map', symtab_tbl') put_ bh (fromIntegral off :: Word32) where freshIndex :: IO Int @@ -298,10 +292,9 @@ putName data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt -- The next index to use - , bin_symtab_map :: !(IORef (NameEnv Int)) + , bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int, Name)])) -- ^ Deduplication indexed by Name - , bin_symtab_tbl :: !(IORef (ModuleEnv [(Int, Name)])) - -- ^ Group table data by module for serialization + -- ; Group table data by module for serialization } putFastString :: BinDictionary -> WriteBinHandle -> FastString -> IO () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23db8741032098b26ff7d6be63add4d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23db8741032098b26ff7d6be63add4d... You're receiving this email because of your account on gitlab.haskell.org.