[Git][ghc/ghc][wip/fendor/ghc-iface-refact] 2 commits: Refactor the Binary serialisation interface
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Tue Apr 2 10:56:14 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ghc-iface-refact at Glasgow Haskell Compiler / GHC
Commits:
df5c3fc0 by Fendor at 2024-04-02T12:55:43+02:00
Refactor the Binary serialisation interface
The end goal is to dynamically add deduplication tables for `ModIface`
interface serialisation.
We identify two main points of interest that make this difficult:
1. UserData hardcodes what `Binary` instances can have deduplication
tables. Moreover, it heavily uses partial functions.
2. GHC.Iface.Binary hardcodes the deduplication tables for 'Name' and
'FastString', making it difficult to add more deduplication.
Instead of having a single `UserData` record with fields for all the
types that can have deduplication tables, we allow to provide custom
serialisers for any `Typeable`.
These are wrapped in existentials and stored in a `Map` indexed by their
respective `TypeRep`.
The `Binary` instance of the type to deduplicate still needs to
explicitly look up the decoder via `findUserDataReader` and
`findUserDataWriter`, which is no worse than the status-quo.
`Map` was chosen as microbenchmarks indicate it is the fastest for a
small number of keys (< 10).
To generalise the deduplication table serialisation mechanism, we
introduce the types `ReaderTable` and `WriterTable` which provide a
simple interface that is sufficient to implement a general purpose
deduplication mechanism for `writeBinIface` and `readBinIface`.
This allows us to provide a list of deduplication tables for
serialisation that can be extended more easily, for example for
`IfaceTyCon`, see the issue https://gitlab.haskell.org/ghc/ghc/-/issues/24540
for more motivation.
In addition to ths refactoring, we split `UserData` into `ReaderUserData`
and `WriterUserData`, to avoid partial functions.
Bump haddock submodule to accomodate for `UserData` split.
- - - - -
aa3ccba8 by Fendor at 2024-04-02T12:55:43+02:00
Split `BinHandle` into `ReadBinHandle` and `WriteBinHandle`
A `BinHandle` contains too much information for reading data.
For example, it needs to keep a `FastMutInt` and a `IORef BinData`,
when the non-mutable variants would suffice.
Additionally, this change has the benefit that anyone can immediately
tell whether the `BinHandle` is used for reading or writing.
Bump haddock submodule BinHandle split.
- - - - -
15 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Binary.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -29,7 +29,6 @@ module GHC.Iface.Binary (
import GHC.Prelude
-import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName )
import GHC.Unit
import GHC.Unit.Module.ModIface
@@ -54,6 +53,7 @@ import Data.Char
import Data.Word
import Data.IORef
import Control.Monad
+import Data.Functor.Identity
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -75,7 +75,7 @@ readBinIfaceHeader
-> CheckHiWay
-> TraceBinIFace
-> FilePath
- -> IO (Fingerprint, BinHandle)
+ -> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
let platform = profilePlatform profile
@@ -121,6 +121,8 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
pure (src_hash, bh)
-- | Read an interface file.
+--
+-- See Note [Iface Binary Serialisation] for details.
readBinIface
:: Profile
-> NameCache
@@ -135,7 +137,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
mod_iface <- getWithUserData name_cache bh
- seekBin bh extFields_p
+ seekBinNoExpandReader bh extFields_p
extFields <- get bh
return mod_iface
@@ -146,7 +148,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
+getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a
getWithUserData name_cache bh = do
bh <- getTables name_cache bh
get bh
@@ -154,24 +156,32 @@ getWithUserData name_cache bh = do
-- | Setup a BinHandle to read something written using putWithTables
--
-- Reading names has the side effect of adding them into the given NameCache.
-getTables :: NameCache -> BinHandle -> IO BinHandle
+getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables name_cache bh = do
- -- Read the dictionary
- -- The next word in the file is a pointer to where the dictionary is
- -- (probably at the end of the file)
- dict <- Binary.forwardGet bh (getDictionary bh)
-
- -- Initialise the user-data field of bh
- let bh_fs = setUserData bh $ newReadState (error "getSymtabName")
- (getDictFastString dict)
-
- symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)
-
- -- It is only now that we know how to get a Name
- return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
- (getDictFastString dict)
-
--- | Write an interface file
+ let
+ -- The order of these entries matters!
+ --
+ -- See Note [Iface Binary Serialiser Order] for details.
+ tables :: [SomeReaderTable IO]
+ tables =
+ [ SomeReaderTable initFastStringReaderTable
+ , SomeReaderTable (initReadNameCachedBinary name_cache)
+ ]
+
+ tables <- traverse (\(SomeReaderTable tblM) -> tblM >>= pure . SomeReaderTable . pure) tables
+
+ final_bh <- foldM (\bh (SomeReaderTable (tbl' :: Identity (ReaderTable a))) -> do
+ let tbl = runIdentity tbl'
+ res <- Binary.forwardGet bh (getTable tbl bh)
+ let newDecoder = mkReaderFromTable tbl res
+ pure $ addReaderToUserData (mkSomeBinaryReader newDecoder) bh
+ ) bh tables
+
+ pure final_bh
+
+-- | Write an interface file.
+--
+-- See Note [Iface Binary Serialisation] for details.
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
writeBinIface profile traceBinIface hi_path mod_iface = do
bh <- openBinMem initBinMemSize
@@ -184,14 +194,14 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
put_ bh tag
put_ bh (mi_src_hash mod_iface)
- extFields_p_p <- tellBin bh
+ extFields_p_p <- tellBinWriter bh
put_ bh extFields_p_p
putWithUserData traceBinIface bh mod_iface
- extFields_p <- tellBin bh
+ extFields_p <- tellBinWriter bh
putAt bh extFields_p_p extFields_p
- seekBin bh extFields_p
+ seekBinWriter bh extFields_p
put_ bh (mi_ext_fields mod_iface)
-- And send the result to the file
@@ -201,7 +211,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
+putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
(name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
@@ -225,43 +235,39 @@ putWithUserData traceBinIface bh payload = do
--
-- It returns (number of names, number of FastStrings, payload write result)
--
-putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
-putWithTables bh put_payload = do
- -- initialize state for the name table and the FastString table.
- symtab_next <- newFastMutInt 0
- symtab_map <- newIORef emptyUFM
- let bin_symtab = BinSymbolTable
- { bin_symtab_next = symtab_next
- , bin_symtab_map = symtab_map
- }
-
- (bh_fs, bin_dict, put_dict) <- initFSTable bh
-
- (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
-
- -- NB. write the dictionary after the symbol table, because
- -- writing the symbol table may create more dictionary entries.
- let put_symtab = do
- name_count <- readFastMutInt symtab_next
- symtab_map <- readIORef symtab_map
- putSymbolTable bh_fs name_count symtab_map
- pure name_count
-
- forwardPut bh_fs (const put_symtab) $ do
-
- -- BinHandle with FastString and Name writing support
- let ud_fs = getUserData bh_fs
- let ud_name = ud_fs
- { ud_put_nonbinding_name = putName bin_dict bin_symtab
- , ud_put_binding_name = putName bin_dict bin_symtab
- }
- let bh_name = setUserData bh ud_name
-
- put_payload bh_name
-
- return (name_count, fs_count, r)
-
-
+putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
+putWithTables bh' put_payload = do
+ let
+ -- The order of these entries matters!
+ --
+ -- See Note [Iface Binary Serialiser Order] for details.
+ writerTables =
+ [ SomeWriterTable initFastStringWriterTable
+ , SomeWriterTable initWriteNameTable
+ ]
+
+ tables <- traverse (\(SomeWriterTable worker) -> worker >>= pure . SomeWriterTable . pure) writerTables
+
+ let writerUserData =
+ mkWriterUserData $
+ map
+ (\(SomeWriterTable tbl') -> mkSomeBinaryWriter (snd $ runIdentity tbl'))
+ tables
+
+ let bh = setWriterUserData bh' writerUserData
+ (fs_count : name_count : _, r) <-
+ putAllTables bh (fmap (\(SomeWriterTable tbl) -> fst $ runIdentity tbl) tables) $ do
+ put_payload bh
+
+ return (name_count, fs_count, r)
+ where
+ putAllTables _ [] act = do
+ a <- act
+ pure ([], a)
+ putAllTables bh (x : xs) act = do
+ (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
+ putAllTables bh xs act
+ pure (r : res, a)
-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
@@ -273,11 +279,108 @@ binaryInterfaceMagic platform
| otherwise = FixedLengthEncoding 0x1face64
+{-
+Note [Iface Binary Serialisation]
+~~~~~~~~~~~~~~~~~~~
+When we serialise a 'ModIface', many symbols are redundant.
+For example, there can be duplicated 'FastString's and 'Name's.
+To save space, we deduplicate some symbols, such as 'FastString' and 'Name',
+by maintaining a table of already seen symbols.
+When serialising a symbol, we lookup whether we have encountered the symbol before.
+If yes, we write the index of the symbol, otherwise we generate a new index and store it in the table.
+
+Besides saving a lot of disk space, this additionally enables us to automatically share
+these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'.
+
+Note [Iface Binary Serialiser Order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often.
+
+After 'ModIface' has been written to disk, we write the deduplication tables.
+Writing a table may add additional entries to *other* deduplication tables, thus
+we need to make sure that the symbol table we serialise only depends on
+deduplication tables that haven't been written to disk yet.
+
+For example, assume we maintain deduplication tables for 'FastString' and 'Name'.
+The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString'
+to the 'FastString' deduplication table.
+Thus, 'Name' table needs to be serialised to disk before the 'FastString' table.
+
+When we read the 'ModIface' from disk, we consequentially need to read the 'FastString'
+deduplication table from disk, before we can deserialise the 'Name' deduplication table.
+Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead
+to the table we need to deserialise first.
+
+Here, a visualisation of the table structure we currently have:
+
+┌──────────────┐
+│ Headers │
+├──────────────┤
+│ │
+│ ModIface │
+│ Payload │
+│ │
+├──────────────┤
+│ Ptr FS ├───────────┐
+├──────────────┤ │
+│ Ptr Name ├────────┐ │
+├──────────────┤ │ │
+│ │ │ │
+│ Name Table │◄───────┘ │
+│ │ │
+├──────────────┤ │
+│ │ │
+│ FS Table │◄──────────┘
+│ │
+└──────────────┘
+
+-}
+
+
-- -----------------------------------------------------------------------------
-- The symbol table
--
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
+
+initReadNameCachedBinary :: NameCache -> IO (ReaderTable Name)
+initReadNameCachedBinary cache = do
+ return $
+ ReaderTable
+ { getTable = \bh -> getSymbolTable bh cache
+ , mkReaderFromTable = \tbl -> mkReader (getSymtabName tbl)
+ }
+
+data BinSymbolTable = BinSymbolTable {
+ bin_symtab_next :: !FastMutInt, -- The next index to use
+ bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
+ -- indexed by Name
+ }
+
+initWriteNameTable :: IO (WriterTable, BinaryWriter Name)
+initWriteNameTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef emptyUFM
+ let bin_symtab =
+ BinSymbolTable
+ { bin_symtab_next = symtab_next
+ , bin_symtab_map = symtab_map
+ }
+
+ let put_symtab bh = do
+ name_count <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putSymbolTable bh name_count symtab_map
+ pure name_count
+
+ return
+ ( WriterTable
+ { putTable = put_symtab
+ }
+ , mkWriter $ putName bin_symtab
+ )
+
+
+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh name_count symtab = do
put_ bh name_count
let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
@@ -286,7 +389,7 @@ putSymbolTable bh name_count symtab = do
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable bh name_cache = do
sz <- get bh :: IO Int
-- create an array of Names for the symbols and add them to the NameCache
@@ -307,7 +410,7 @@ getSymbolTable bh name_cache = do
arr <- unsafeFreeze mut_arr
return (cache, arr)
-serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
+serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -331,8 +434,8 @@ serialiseName bh name _ = do
-- See Note [Symbol table representation of names]
-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
-putName _dict BinSymbolTable{
+putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
+putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
@@ -356,10 +459,9 @@ putName _dict BinSymbolTable{
put_ bh (fromIntegral off :: Word32)
-- See Note [Symbol table representation of names]
-getSymtabName :: NameCache
- -> Dictionary -> SymbolTable
- -> BinHandle -> IO Name
-getSymtabName _name_cache _dict symtab bh = do
+getSymtabName :: SymbolTable Name
+ -> ReadBinHandle -> IO Name
+getSymtabName symtab bh = do
i :: Word32 <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral i
@@ -376,10 +478,3 @@ getSymtabName _name_cache _dict symtab bh = do
Just n -> n
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
-
-data BinSymbolTable = BinSymbolTable {
- bin_symtab_next :: !FastMutInt, -- The next index to use
- bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
- -- indexed by Name
- }
-
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -67,7 +67,7 @@ hieMagicLen = length hieMagic
ghcVersion :: ByteString
ghcVersion = BSC.pack cProjectVersion
-putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine :: WriteBinHandle -> ByteString -> IO ()
putBinLine bh xs = do
mapM_ (putByte bh) $ BS.unpack xs
putByte bh 10 -- newline char
@@ -85,11 +85,11 @@ writeHieFile hie_file_path hiefile = do
putBinLine bh0 $ ghcVersion
-- remember where the dictionary pointer will go
- dict_p_p <- tellBin bh0
+ dict_p_p <- tellBinWriter bh0
put_ bh0 dict_p_p
-- remember where the symbol table pointer will go
- symtab_p_p <- tellBin bh0
+ symtab_p_p <- tellBinWriter bh0
put_ bh0 symtab_p_p
-- Make some initial state
@@ -105,25 +105,25 @@ writeHieFile hie_file_path hiefile = do
hie_dict_map = dict_map_ref }
-- put the main thing
- let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
- (putName hie_symtab)
- (putFastString hie_dict)
+ let bh = setWriterUserData bh0
+ $ newWriteState (putName hie_symtab)
+ (putFastString hie_dict)
put_ bh hiefile
-- write the symtab pointer at the front of the file
- symtab_p <- tellBin bh
+ symtab_p <- tellBinWriter bh
putAt bh symtab_p_p symtab_p
- seekBin bh symtab_p
+ seekBinWriter bh symtab_p
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
- -- write the dictionary pointer at the front of the file
- dict_p <- tellBin bh
+ -- write the tellBinWriter pointer at the front of the file
+ dict_p <- tellBinWriter bh
putAt bh dict_p_p dict_p
- seekBin bh dict_p
+ seekBinWriter bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt dict_next_ref
@@ -181,7 +181,7 @@ readHieFile name_cache file = do
hieFile <- readHieFileContents bh0 name_cache
return $ HieFileResult hieVersion ghcVersion hieFile
-readBinLine :: BinHandle -> IO ByteString
+readBinLine :: ReadBinHandle -> IO ByteString
readBinLine bh = BS.pack . reverse <$> loop []
where
loop acc = do
@@ -190,7 +190,7 @@ readBinLine bh = BS.pack . reverse <$> loop []
then return acc
else loop (char : acc)
-readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader
readHieFileHeader file bh0 = do
-- Read the header
magic <- replicateM hieMagicLen (get bh0)
@@ -213,15 +213,16 @@ readHieFileHeader file bh0 = do
]
return (readHieVersion, ghcVersion)
-readHieFileContents :: BinHandle -> NameCache -> IO HieFile
+readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile
readHieFileContents bh0 name_cache = do
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
bh1 <- do
- let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
- (getDictFastString dict)
+ let bh1 = setReaderUserData bh0
+ $ newReadState (error "getSymtabName")
+ (getDictFastString dict)
symtab <- get_symbol_table bh1
- let bh1' = setUserData bh1
+ let bh1' = setReaderUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return bh1'
@@ -231,21 +232,21 @@ readHieFileContents bh0 name_cache = do
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
- data_p <- tellBin bin_handle
- seekBin bin_handle dict_p
+ data_p <- tellBinReader bin_handle
+ seekBinNoExpandReader bin_handle dict_p
dict <- getDictionary bin_handle
- seekBin bin_handle data_p
+ seekBinNoExpandReader bin_handle data_p
return dict
get_symbol_table bh1 = do
symtab_p <- get bh1
- data_p' <- tellBin bh1
- seekBin bh1 symtab_p
+ data_p' <- tellBinReader bh1
+ seekBinNoExpandReader bh1 symtab_p
symtab <- getSymbolTable bh1 name_cache
- seekBin bh1 data_p'
+ seekBinNoExpandReader bh1 data_p'
return symtab
-putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
@@ -259,13 +260,13 @@ putFastString HieDictionary { hie_dict_next = j_r,
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out unique (j, f)
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable bh name_cache = do
sz <- get bh
mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
@@ -275,12 +276,12 @@ getSymbolTable bh name_cache = do
A.writeArray mut_arr i name
A.unsafeFreeze mut_arr
-getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name
getSymTabName st bh = do
i :: Word32 <- get bh
return $ st A.! (fromIntegral i)
-putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName :: HieSymbolTable -> WriteBinHandle -> Name -> IO ()
putName (HieSymbolTable next ref) bh name = do
symmap <- readIORef ref
case lookupUFM symmap name of
@@ -333,7 +334,7 @@ fromHieName nc hie_name = do
-- ** Reading and writing `HieName`'s
-putHieName :: BinHandle -> HieName -> IO ()
+putHieName :: WriteBinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
put_ bh (mod, occ, BinSrcSpan span)
@@ -344,7 +345,7 @@ putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
-getHieName :: BinHandle -> IO HieName
+getHieName :: ReadBinHandle -> IO HieName
getHieName bh = do
t <- getByte bh
case t of
=====================================
compiler/GHC/Iface/Ext/Fields.hs
=====================================
@@ -33,16 +33,16 @@ instance Binary ExtensibleFields where
-- for a payload pointer after each name:
header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
put_ bh name
- field_p_p <- tellBin bh
+ field_p_p <- tellBinWriter bh
put_ bh field_p_p
return (field_p_p, dat)
-- Now put the payloads and use the reserved space
-- to point to the start of each payload:
forM_ header_entries $ \(field_p_p, dat) -> do
- field_p <- tellBin bh
+ field_p <- tellBinWriter bh
putAt bh field_p_p field_p
- seekBin bh field_p
+ seekBinWriter bh field_p
put_ bh dat
get bh = do
@@ -54,7 +54,7 @@ instance Binary ExtensibleFields where
-- Seek to and get each field's payload:
fields <- forM header_entries $ \(name, field_p) -> do
- seekBin bh field_p
+ seekBinNoExpandReader bh field_p
dat <- get bh
return (name, dat)
@@ -72,7 +72,7 @@ emptyExtensibleFields = ExtensibleFields Map.empty
readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField name = readFieldWith name get
-readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
Map.lookup name (getExtensibleFields fields)
@@ -82,7 +82,7 @@ readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField name x = writeFieldWith name (`put_` x)
-writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith name write fields = do
bh <- openBinMem (1024 * 1024)
write bh
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -520,7 +520,7 @@ checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
checkFlagHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_flag_hash (mi_final_exts iface)
- new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally
+ new_hash <- fingerprintDynFlags hsc_env (mi_module iface)
case old_hash == new_hash of
True -> up_to_date logger (text "Module flags unchanged")
False -> out_of_date_hash logger FlagsChanged
@@ -533,7 +533,6 @@ checkOptimHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_opt_hash (mi_final_exts iface)
new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)
- putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "Optimisation flags unchanged")
| gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
@@ -549,7 +548,6 @@ checkHpcHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_hpc_hash (mi_final_exts iface)
new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)
- putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "HPC flags unchanged")
| gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
@@ -960,7 +958,6 @@ addFingerprints
-> IO ModIface
addFingerprints hsc_env iface0
= do
- eps <- hscEPS hsc_env
let
decls = mi_decls iface0
decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings $ mi_warns iface0)
@@ -1023,40 +1020,6 @@ addFingerprints hsc_env iface0
groups :: [SCC IfaceDeclABI]
groups = stronglyConnCompFromEdgedVerticesOrd edges
- global_hash_fn = mkHashFun hsc_env eps
-
- -- How to output Names when generating the data to fingerprint.
- -- Here we want to output the fingerprint for each top-level
- -- Name, whether it comes from the current module or another
- -- module. In this way, the fingerprint for a declaration will
- -- change if the fingerprint for anything it refers to (transitively)
- -- changes.
- mk_put_name :: OccEnv (OccName,Fingerprint)
- -> BinHandle -> Name -> IO ()
- mk_put_name local_env bh name
- | isWiredInName name = putNameLiterally bh name
- -- wired-in names don't have fingerprints
- | otherwise
- = assertPpr (isExternalName name) (ppr name) $
- let hash | nameModule name /= semantic_mod = global_hash_fn name
- -- Get it from the REAL interface!!
- -- This will trigger when we compile an hsig file
- -- and we know a backing impl for it.
- -- See Note [Identity versus semantic module]
- | semantic_mod /= this_mod
- , not (isHoleModule semantic_mod) = global_hash_fn name
- | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
- `orElse` pprPanic "urk! lookup local fingerprint"
- (ppr name $$ ppr local_env)))
- -- This panic indicates that we got the dependency
- -- analysis wrong, because we needed a fingerprint for
- -- an entity that wasn't in the environment. To debug
- -- it, turn the panic into a trace, uncomment the
- -- pprTraces below, run the compile again, and inspect
- -- the output and the generated .hi file with
- -- --show-iface.
- in hash >>= put_ bh
-
-- take a strongly-connected group of declarations and compute
-- its fingerprint.
@@ -1067,23 +1030,18 @@ addFingerprints hsc_env iface0
[(Fingerprint,IfaceDecl)])
fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
- = do let hash_fn = mk_put_name local_env
- decl = abiDecl abi
+ = do let decl = abiDecl abi
--pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
- hash <- computeFingerprint hash_fn abi
+ hash <- computeFingerprint abi
env' <- extend_hash_env local_env (hash,decl)
return (env', (hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
= do let stable_abis = sortBy cmp_abiNames abis
stable_decls = map abiDecl stable_abis
- local_env1 <- foldM extend_hash_env local_env
- (zip (map mkRecFingerprint [0..]) stable_decls)
- -- See Note [Fingerprinting recursive groups]
- let hash_fn = mk_put_name local_env1
-- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
-- put the cycle in a canonical order
- hash <- computeFingerprint hash_fn stable_abis
+ hash <- computeFingerprint stable_abis
let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls
-- See Note [Fingerprinting recursive groups]
local_env2 <- foldM extend_hash_env local_env pairs
@@ -1156,11 +1114,10 @@ addFingerprints hsc_env iface0
-- instances yourself, no need to consult hs-boot; if you do load the
-- interface into EPS, you will see a duplicate orphan instance.
- orphan_hash <- computeFingerprint (mk_put_name local_env)
- (map ifDFun orph_insts, orph_rules, orph_fis)
+ orphan_hash <- computeFingerprint (map ifDFun orph_insts, orph_rules, orph_fis)
-- Hash of the transitive things in dependencies
- dep_hash <- computeFingerprint putNameLiterally
+ dep_hash <- computeFingerprint
(dep_sig_mods (mi_deps iface0),
dep_boot_mods (mi_deps iface0),
-- Trusted packages are like orphans
@@ -1170,7 +1127,7 @@ addFingerprints hsc_env iface0
-- the export list hash doesn't depend on the fingerprints of
-- the Names it mentions, only the Names themselves, hence putNameLiterally.
- export_hash <- computeFingerprint putNameLiterally
+ export_hash <- computeFingerprint
(mi_exports iface0,
orphan_hash,
dep_hash,
@@ -1229,11 +1186,11 @@ addFingerprints hsc_env iface0
-- - (some of) dflags
-- it returns two hashes, one that shouldn't change
-- the abi hash and one that should
- flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally
+ flag_hash <- fingerprintDynFlags hsc_env this_mod
- opt_hash <- fingerprintOptFlags dflags putNameLiterally
+ opt_hash <- fingerprintOptFlags dflags
- hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+ hpc_hash <- fingerprintHpcFlags dflags
plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
@@ -1243,7 +1200,7 @@ addFingerprints hsc_env iface0
-- - orphans
-- - deprecations
-- - flag abi hash
- mod_hash <- computeFingerprint putNameLiterally
+ mod_hash <- computeFingerprint
(map fst sorted_decls,
export_hash, -- includes orphan_hash
mi_warns iface0)
@@ -1255,7 +1212,7 @@ addFingerprints hsc_env iface0
-- - usages
-- - deps (home and external packages, dependent files)
-- - hpc
- iface_hash <- computeFingerprint putNameLiterally
+ iface_hash <- computeFingerprint
(mod_hash,
mi_src_hash iface0,
ann_fn (mkVarOccFS (fsLit "module")), -- See mkIfaceAnnCache
@@ -1594,57 +1551,6 @@ mkOrphMap get_key decls
= (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
--- -----------------------------------------------------------------------------
--- Look up parents and versions of Names
-
--- This is like a global version of the mi_hash_fn field in each ModIface.
--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
--- the parent and version info.
-
-mkHashFun
- :: HscEnv -- needed to look up versions
- -> ExternalPackageState -- ditto
- -> (Name -> IO Fingerprint)
-mkHashFun hsc_env eps name
- | isHoleModule orig_mod
- = lookup (mkHomeModule home_unit (moduleName orig_mod))
- | otherwise
- = lookup orig_mod
- where
- home_unit = hsc_home_unit hsc_env
- dflags = hsc_dflags hsc_env
- hpt = hsc_HUG hsc_env
- pit = eps_PIT eps
- ctx = initSDocContext dflags defaultUserStyle
- occ = nameOccName name
- orig_mod = nameModule name
- lookup mod = do
- massertPpr (isExternalName name) (ppr name)
- iface <- case lookupIfaceByModule hpt pit mod of
- Just iface -> return iface
- Nothing ->
- -- This can occur when we're writing out ifaces for
- -- requirements; we didn't do any /real/ typechecking
- -- so there's no guarantee everything is loaded.
- -- Kind of a heinous hack.
- initIfaceLoad hsc_env . withIfaceErr ctx
- $ withoutDynamicNow
- -- If you try and load interfaces when dynamic-too
- -- enabled then it attempts to load the dyn_hi and hi
- -- interface files. Backpack doesn't really care about
- -- dynamic object files as it isn't doing any code
- -- generation so -dynamic-too is turned off.
- -- Some tests fail without doing this (such as T16219),
- -- but they fail because dyn_hi files are not found for
- -- one of the dependencies (because they are deliberately turned off)
- -- Why is this check turned off here? That is unclear but
- -- just one of the many horrible hacks in the backpack
- -- implementation.
- $ loadInterface (text "lookupVers2") mod ImportBySystem
- return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
- pprPanic "lookupVers1" (ppr mod <+> ppr occ))
-
-
-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
=====================================
compiler/GHC/Iface/Recomp/Binary.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
-fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
where
f bs =
@@ -26,20 +26,18 @@ fingerprintBinMem bh = withBinBuffer bh f
in fp `seq` return fp
computeFingerprint :: (Binary a)
- => (BinHandle -> Name -> IO ())
- -> a
+ => a
-> IO Fingerprint
-computeFingerprint put_nonbinding_name a = do
+computeFingerprint a = do
bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
put_ bh a
fingerprintBinMem bh
where
- set_user_data bh =
- setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+ set_user_data bh = setWriterUserData bh $ newWriteState putNameLiterally putFS
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
-putNameLiterally :: BinHandle -> Name -> IO ()
+putNameLiterally :: WriteBinHandle -> Name -> IO ()
putNameLiterally bh name = assert (isExternalName name) $ do
put_ bh $! nameModule name
put_ bh $! nameOccName name
=====================================
compiler/GHC/Iface/Recomp/Flags.hs
=====================================
@@ -13,9 +13,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
-import GHC.Utils.Binary
import GHC.Unit.Module
-import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Utils.Fingerprint
import GHC.Iface.Recomp.Binary
@@ -31,10 +29,9 @@ import System.FilePath (normalise)
-- NB: The 'Module' parameter is the 'Module' recorded by the *interface*
-- file, not the actual 'Module' according to our 'DynFlags'.
fingerprintDynFlags :: HscEnv -> Module
- -> (BinHandle -> Name -> IO ())
-> IO Fingerprint
-fingerprintDynFlags hsc_env this_mod nameio =
+fingerprintDynFlags hsc_env this_mod =
let dflags at DynFlags{..} = hsc_dflags hsc_env
mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing
-- see #5878
@@ -73,7 +70,7 @@ fingerprintDynFlags hsc_env this_mod nameio =
flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))
in -- pprTrace "flags" (ppr flags) $
- computeFingerprint nameio flags
+ computeFingerprint flags
-- Fingerprint the optimisation info. We keep this separate from the rest of
-- the flags because GHCi users (especially) may wish to ignore changes in
@@ -81,9 +78,8 @@ fingerprintDynFlags hsc_env this_mod nameio =
-- object files as they can.
-- See Note [Ignoring some flag changes]
fingerprintOptFlags :: DynFlags
- -> (BinHandle -> Name -> IO ())
-> IO Fingerprint
-fingerprintOptFlags DynFlags{..} nameio =
+fingerprintOptFlags DynFlags{..} =
let
-- See https://gitlab.haskell.org/ghc/ghc/issues/10923
-- We used to fingerprint the optimisation level, but as Joachim
@@ -92,22 +88,21 @@ fingerprintOptFlags DynFlags{..} nameio =
opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
(EnumSet.toList generalFlags)
- in computeFingerprint nameio opt_flags
+ in computeFingerprint opt_flags
-- Fingerprint the HPC info. We keep this separate from the rest of
-- the flags because GHCi users (especially) may wish to use an object
-- file compiled for HPC when not actually using HPC.
-- See Note [Ignoring some flag changes]
fingerprintHpcFlags :: DynFlags
- -> (BinHandle -> Name -> IO ())
-> IO Fingerprint
-fingerprintHpcFlags dflags at DynFlags{..} nameio =
+fingerprintHpcFlags dflags at DynFlags{..} =
let
-- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798
-- hpcDir is output-only, so we should recompile if it changes
hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
- in computeFingerprint nameio hpc
+ in computeFingerprint hpc
{- Note [path flags and recompilation]
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -94,6 +94,7 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
+import Data.Proxy
infixl 3 &&&
@@ -118,15 +119,15 @@ type IfaceTopBndr = Name
-- We don't serialise the namespace onto the disk though; rather we
-- drop it when serialising and add it back in when deserialising.
-getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr
+getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr
getIfaceTopBndr bh = get bh
-putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
+putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO ()
putIfaceTopBndr bh name =
- case getUserData bh of
- UserData{ ud_put_binding_name = put_binding_name } ->
+ case findUserDataWriter Proxy bh of
+ tbl ->
--pprTrace "putIfaceTopBndr" (ppr name) $
- put_binding_name bh name
+ putEntry tbl bh name
data IfaceDecl
@@ -585,7 +586,7 @@ ifaceDeclFingerprints hash decl
where
computeFingerprint' =
unsafeDupablePerformIO
- . computeFingerprint (panic "ifaceDeclFingerprints")
+ . computeFingerprint
fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings = \case
@@ -2444,13 +2445,13 @@ instance Binary IfGuidance where
c <- get bh
return (IfWhen a b c)
-putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()
+putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO ()
putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
, uf_is_work_free = wf, uf_expandable = exp }) = do
let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp
putByte bh b
-getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache
+getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache
getUnfoldingCache bh = do
b <- getByte bh
let hnf = testBit b 3
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -9,7 +9,6 @@ This module defines interface types and binders
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
-
module GHC.Iface.Type (
IfExtName, IfLclName,
@@ -90,10 +89,10 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
-import Data.Maybe( isJust )
-import qualified Data.Semigroup as Semi
import Control.DeepSeq
import Control.Monad ((<$!>))
+import qualified Data.Semigroup as Semi
+import Data.Maybe( isJust )
{-
************************************************************************
@@ -2045,11 +2044,12 @@ instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
- put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
+ put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
- get bh = do n <- get bh
- i <- get bh
- return (IfaceTyCon n i)
+ get bh = do
+ n <- get bh
+ i <- get bh
+ return (IfaceTyCon n i)
instance Binary IfaceTyConSort where
put_ bh IfaceNormalTyCon = putByte bh 0
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -66,6 +66,9 @@ import GHC.Prelude
import Control.Monad
import Data.Array
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import Data.Char (isSpace)
import Data.Int
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
@@ -75,10 +78,7 @@ import Data.Map (Map)
import qualified Data.Map as M
import Data.Word
import Data.Semigroup
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Unsafe as B
-import Data.Char (isSpace)
-import System.IO
+import System.IO
import GHC.Settings.Constants (hiVersion)
@@ -168,7 +168,7 @@ wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"#
data Object = Object
{ objModuleName :: !ModuleName
-- ^ name of the module
- , objHandle :: !BinHandle
+ , objHandle :: !ReadBinHandle
-- ^ BinHandle that can be used to read the ObjBlocks
, objPayloadOffset :: !(Bin ObjBlock)
-- ^ Offset of the payload (units)
@@ -253,7 +253,7 @@ instance Outputable ExportedFun where
-- | Write an ObjBlock, except for the top level symbols which are stored in the
-- index
-putObjBlock :: BinHandle -> ObjBlock -> IO ()
+putObjBlock :: WriteBinHandle -> ObjBlock -> IO ()
putObjBlock bh (ObjBlock _syms b c d e f g) = do
put_ bh b
put_ bh c
@@ -264,7 +264,7 @@ putObjBlock bh (ObjBlock _syms b c d e f g) = do
-- | Read an ObjBlock and associate it to the given symbols (that must have been
-- read from the index)
-getObjBlock :: [FastString] -> BinHandle -> IO ObjBlock
+getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock
getObjBlock syms bh = do
b <- get bh
c <- get bh
@@ -299,7 +299,7 @@ data IndexEntry = IndexEntry
-- | Given a handle to a Binary payload, add the module, 'mod_name', its
-- dependencies, 'deps', and its linkable units to the payload.
putObject
- :: BinHandle
+ :: WriteBinHandle
-> ModuleName -- ^ module
-> BlockInfo -- ^ block infos
-> [ObjBlock] -- ^ linkable units and their symbols
@@ -313,15 +313,16 @@ putObject bh mod_name deps os = do
-- object in an archive.
put_ bh (moduleNameString mod_name)
- (bh_fs, _bin_dict, put_dict) <- initFSTable bh
+ (fs_tbl, fs_writer) <- initFastStringWriterTable
+ let bh_fs = addWriterToUserData (mkSomeBinaryWriter fs_writer) bh
- forwardPut_ bh (const put_dict) $ do
+ forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do
put_ bh_fs deps
-- forward put the index
forwardPut_ bh_fs (put_ bh_fs) $ do
idx <- forM os $ \o -> do
- p <- tellBin bh_fs
+ p <- tellBinWriter bh_fs
-- write units without their symbols
putObjBlock bh_fs o
-- return symbols and offset to store in the index
@@ -329,7 +330,7 @@ putObject bh mod_name deps os = do
pure idx
-- | Parse object header
-getObjectHeader :: BinHandle -> IO (Either String ModuleName)
+getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName)
getObjectHeader bh = do
magic <- getByteString bh (B.length hsHeader)
case magic == hsHeader of
@@ -344,15 +345,15 @@ getObjectHeader bh = do
-- | Parse object body. Must be called after a successful getObjectHeader
-getObjectBody :: BinHandle -> ModuleName -> IO Object
+getObjectBody :: ReadBinHandle -> ModuleName -> IO Object
getObjectBody bh0 mod_name = do
-- Read the string table
dict <- forwardGet bh0 (getDictionary bh0)
- let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }
+ let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict)
block_info <- get bh
idx <- forwardGet bh (get bh)
- payload_pos <- tellBin bh
+ payload_pos <- tellBinReader bh
pure $ Object
{ objModuleName = mod_name
@@ -363,7 +364,7 @@ getObjectBody bh0 mod_name = do
}
-- | Parse object
-getObject :: BinHandle -> IO (Maybe Object)
+getObject :: ReadBinHandle -> IO (Maybe Object)
getObject bh = do
getObjectHeader bh >>= \case
Left _err -> pure Nothing
@@ -392,7 +393,7 @@ getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..])
bh = objHandle obj
read_entry (IndexEntry syms offset,i)
| IS.member i bids = do
- seekBin bh offset
+ seekBinNoExpandReader bh offset
Just <$> getObjBlock syms bh
| otherwise = pure Nothing
@@ -408,12 +409,12 @@ readObjectBlocks file bids = do
-- Helper functions
--------------------------------------------------------------------------------
-putEnum :: Enum a => BinHandle -> a -> IO ()
+putEnum :: Enum a => WriteBinHandle -> a -> IO ()
putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)
| otherwise = put_ bh n
where n = fromIntegral $ fromEnum x :: Word16
-getEnum :: Enum a => BinHandle -> IO a
+getEnum :: Enum a => ReadBinHandle -> IO a
getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16)
-- | Helper to convert Int to Int32
@@ -778,7 +779,7 @@ writeJSObject opts contents output_fn = do
-- | Read a JS object from BinHandle
-parseJSObject :: BinHandle -> IO (JSOptions, B.ByteString)
+parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString)
parseJSObject bh = do
magic <- getByteString bh (B.length jsHeader)
case magic == jsHeader of
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -1010,7 +1010,7 @@ data TupleSort
= BoxedTuple
| UnboxedTuple
| ConstraintTuple
- deriving( Eq, Data )
+ deriving( Eq, Data, Ord )
instance Outputable TupleSort where
ppr ts = text $
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -140,9 +140,8 @@ instance Binary Name => Binary FieldLabel where
put_ bh (FieldLabel aa ab ac) = do
put_ bh aa
put_ bh ab
- case getUserData bh of
- UserData{ ud_put_binding_name = put_binding_name } ->
- put_binding_name bh ac
+ case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh ac
get bh = do
aa <- get bh
ab <- get bh
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -663,12 +663,12 @@ instance Data Name where
-- distinction.
instance Binary Name where
put_ bh name =
- case getUserData bh of
- UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name
+ case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh name
get bh =
- case getUserData bh of
- UserData { ud_get_name = get_name } -> get_name bh
+ case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# LANGUAGE TypeFamilies #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -21,7 +22,7 @@
module GHC.Utils.Binary
( {-type-} Bin,
{-class-} Binary(..),
- {-type-} BinHandle,
+ {-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
@@ -30,8 +31,10 @@ module GHC.Utils.Binary
openBinMem,
-- closeBin,
- seekBin,
- tellBin,
+ seekBinWriter,
+ seekBinNoExpandReader,
+ tellBinReader,
+ tellBinWriter,
castBin,
withBinBuffer,
@@ -66,13 +69,43 @@ module GHC.Utils.Binary
lazyPutMaybe,
-- * User data
- UserData(..), getUserData, setUserData,
- newReadState, newWriteState, noUserData,
-
+ ReaderUserData(..), getReaderUserData, setReaderUserData, noReaderUserData,
+ WriterUserData(..), getWriterUserData, setWriterUserData, noWriterUserData,
+ mkWriterUserData, mkReaderUserData,
+ newReadState, newWriteState,
+ addReaderToUserData, addWriterToUserData,
+ findUserDataReader, findUserDataWriter,
+ -- * Binary Readers & Writers
+ BinaryReader(..), BinaryWriter(..),
+ mkWriter, mkReader,
+ SomeBinaryReader, SomeBinaryWriter,
+ mkSomeBinaryReader, mkSomeBinaryWriter,
+ -- * Tables
+ SomeReaderTable(..),
+ ReaderTable(..),
+ SomeWriterTable(..),
+ WriterTable(..),
-- * String table ("dictionary")
+ initFastStringReaderTable, initFastStringWriterTable,
putDictionary, getDictionary, putFS,
- FSTable, initFSTable, getDictFastString, putDictFastString,
-
+ FSTable(..), getDictFastString, putDictFastString,
+<<<<<<< HEAD
+ -- * Generic Symbol that can be used for user-defined deduplication tables.
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ putGenericSymbolTable, getGenericSymbolTable,
+ putGenericSymTab, getGenericSymtab,
+||||||| parent of f3fd018a62 (Fixup: Generic Symbol Table)
+
+=======
+
+ -- * Generic Symbol that can be used for user-defined deduplication tables.
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ putGenericSymbolTable, getGenericSymbolTable,
+ putGenericSymTab, getGenericSymtab,
+
+>>>>>>> f3fd018a62 (Fixup: Generic Symbol Table)
-- * Newtype wrappers
BinSpan(..), BinSrcSpan(..), BinLocated(..)
) where
@@ -93,6 +126,7 @@ import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
import Control.DeepSeq
+import Control.Monad ( when, (<$!>), unless, forM_, void )
import Foreign hiding (shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
@@ -104,11 +138,14 @@ import Data.IORef
import Data.Char ( ord, chr )
import Data.List.NonEmpty ( NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time
+import Data.Tuple (swap)
import Data.List (unfoldr)
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Data.Typeable
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
@@ -119,6 +156,8 @@ import qualified Data.IntMap as IntMap
import GHC.ForeignPtr ( unsafeWithForeignPtr )
#endif
+import Unsafe.Coerce (unsafeCoerce)
+
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -150,49 +189,83 @@ instance Binary BinData where
copyBytes dest orig sz
return (BinData sz dat)
-dataHandle :: BinData -> IO BinHandle
+dataHandle :: BinData -> IO ReadBinHandle
dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
- szr <- newFastMutInt size
- binr <- newIORef bin
- return (BinMem noUserData ixr szr binr)
+ return (ReadBinMem noReaderUserData ixr size bin)
-handleData :: BinHandle -> IO BinData
-handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+handleData :: WriteBinHandle -> IO BinData
+handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
-data BinHandle
- = BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
- _off_r :: !FastMutInt, -- the current offset
- _sz_r :: !FastMutInt, -- size of the array (cached)
- _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
+-- | A write-only handle that can be used to serialise binary data into a buffer.
+--
+-- The buffer is an unboxed binary array.
+data WriteBinHandle
+ = WriteBinMem {
+ wbm_userData :: !WriterUserData,
+ wbm_off_r :: !FastMutInt, -- ^ the current offset
+ wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached)
+ wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))
}
- -- XXX: should really store a "high water mark" for dumping out
- -- the binary data to a file.
-getUserData :: BinHandle -> UserData
-getUserData bh = bh_usr bh
+-- | A read-only handle that can be used to deserialise binary data from a buffer.
+--
+-- The buffer is an unboxed binary array.
+data ReadBinHandle
+ = ReadBinMem {
+ rbm_userData :: !ReaderUserData,
+ rbm_off_r :: !FastMutInt, -- ^ the current offset
+ rbm_sz_r :: !Int, -- ^ size of the array (cached)
+ rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1))
+ }
+
+getReaderUserData :: ReadBinHandle -> ReaderUserData
+getReaderUserData bh = rbm_userData bh
+
+getWriterUserData :: WriteBinHandle -> WriterUserData
+getWriterUserData bh = wbm_userData bh
+
+setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
+setWriterUserData bh us = bh { wbm_userData = us }
-setUserData :: BinHandle -> UserData -> BinHandle
-setUserData bh us = bh { bh_usr = us }
+setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
+setReaderUserData bh us = bh { rbm_userData = us }
+
+-- | Add 'SomeBinaryReader' as a known binary decoder.
+-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',
+-- it is overwritten.
+addReaderToUserData :: SomeBinaryReader -> ReadBinHandle -> ReadBinHandle
+addReaderToUserData cache@(SomeBinaryReader typRep _) bh = bh
+ { rbm_userData = (rbm_userData bh)
+ { ud_reader_data = Map.insert typRep cache (ud_reader_data (rbm_userData bh))
+ }
+ }
+
+-- | Add 'SomeBinaryWriter' as a known binary encoder.
+-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',
+-- it is overwritten.
+addWriterToUserData :: SomeBinaryWriter -> WriteBinHandle -> WriteBinHandle
+addWriterToUserData cache@(SomeBinaryWriter typRep _) bh = bh
+ { wbm_userData = (wbm_userData bh)
+ { ud_writer_data = Map.insert typRep cache (ud_writer_data (wbm_userData bh))
+ }
+ }
-- | Get access to the underlying buffer.
-withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
-withBinBuffer (BinMem _ ix_r _ arr_r) action = do
- arr <- readIORef arr_r
+withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a
+withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do
ix <- readFastMutInt ix_r
+ arr <- readIORef arr_r
action $ BS.fromForeignPtr arr 0 ix
-unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
+unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt len
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (ReadBinMem noReaderUserData ix_r len arr)
---------------------------------------------------------------
-- Bin
@@ -211,23 +284,23 @@ castBin (BinPtr i) = BinPtr i
-- | Do not rely on instance sizes for general types,
-- we use variable length encoding for many of them.
class Binary a where
- put_ :: BinHandle -> a -> IO ()
- put :: BinHandle -> a -> IO (Bin a)
- get :: BinHandle -> IO a
+ put_ :: WriteBinHandle -> a -> IO ()
+ put :: WriteBinHandle -> a -> IO (Bin a)
+ get :: ReadBinHandle -> IO a
-- define one of put_, put. Use of put_ is recommended because it
-- is more likely that tail-calls can kick in, and we rarely need the
-- position return value.
put_ bh a = do _ <- put bh a; return ()
- put bh a = do p <- tellBin bh; put_ bh a; return p
+ put bh a = do p <- tellBinWriter bh; put_ bh a; return p
-putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
-putAt bh p x = do seekBin bh p; put_ bh x; return ()
+putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()
-getAt :: Binary a => BinHandle -> Bin a -> IO a
-getAt bh p = do seekBin bh p; get bh
+getAt :: Binary a => ReadBinHandle -> Bin a -> IO a
+getAt bh p = do seekBinNoExpandReader bh p; get bh
-openBinMem :: Int -> IO BinHandle
+openBinMem :: Int -> IO WriteBinHandle
openBinMem size
| size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"
| otherwise = do
@@ -235,42 +308,57 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noUserData ix_r sz_r arr_r)
+ return WriteBinMem
+ { wbm_userData = noWriterUserData
+ , wbm_off_r = ix_r
+ , wbm_sz_r = sz_r
+ , wbm_arr_r = arr_r
+ }
+
+tellBinWriter :: WriteBinHandle -> IO (Bin a)
+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBinReader :: ReadBinHandle -> IO (Bin a)
+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-seekBin :: BinHandle -> Bin a -> IO ()
-seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBinWriter :: WriteBinHandle -> Bin a -> IO ()
+seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p >= sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
-- | SeekBin but without calling expandBin
-seekBinNoExpand :: BinHandle -> Bin a -> IO ()
-seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO ()
+seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p >= sz)
then panic "seekBinNoExpand: seek out of range"
else writeFastMutInt ix_r p
-writeBinMem :: BinHandle -> FilePath -> IO ()
-writeBinMem (BinMem _ ix_r _ arr_r) fn = do
+-- | SeekBin but without calling expandBin
+seekBinNoExpandReader :: ReadBinHandle -> Bin a -> IO ()
+seekBinNoExpandReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do
+ if (p >= sz_r)
+ then panic "seekBinNoExpand: seek out of range"
+ else writeFastMutInt ix_r p
+
+writeBinMem :: WriteBinHandle -> FilePath -> IO ()
+writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix
hClose h
-readBinMem :: FilePath -> IO BinHandle
+readBinMem :: FilePath -> IO ReadBinHandle
readBinMem filename = do
withBinaryFile filename ReadMode $ \h -> do
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
readBinMem_ filesize h
-readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle)
+readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle)
readBinMemN size filename = do
withBinaryFile filename ReadMode $ \h -> do
filesize' <- hFileSize h
@@ -279,20 +367,23 @@ readBinMemN size filename = do
then pure Nothing
else Just <$> readBinMem_ size h
-readBinMem_ :: Int -> Handle -> IO BinHandle
+readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ filesize h = do
arr <- mallocForeignPtrBytes filesize
count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt filesize
- return (BinMem noUserData ix_r sz_r arr_r)
+ return ReadBinMem
+ { rbm_userData = noReaderUserData
+ , rbm_off_r = ix_r
+ , rbm_sz_r = filesize
+ , rbm_arr_r = arr
+ }
-- expand the size of the array to include a specified offset
-expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ _ sz_r arr_r) !off = do
+expandBin :: WriteBinHandle -> Int -> IO ()
+expandBin (WriteBinMem _ _ sz_r arr_r) !off = do
!sz <- readFastMutInt sz_r
let !sz' = getSize sz
arr <- readIORef arr_r
@@ -313,7 +404,7 @@ expandBin (BinMem _ _ sz_r arr_r) !off = do
foldGet
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -329,7 +420,7 @@ foldGet n bh init_b f = go 0 init_b
foldGet'
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -350,8 +441,8 @@ foldGet' n bh init_b f = go 0 init_b
-- | Takes a size and action writing up to @size@ bytes.
-- After the action has run advance the index to the buffer
-- by size bytes.
-putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
-putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
+putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
+putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix + size > sz) $
@@ -372,39 +463,37 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
-- writeFastMutInt ix_r (ix + written)
-getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
-getPrim (BinMem _ ix_r sz_r arr_r) size f = do
+getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
+getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
- when (ix + size > sz) $
+ when (ix + size > sz_r) $
ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
- arr <- readIORef arr_r
- w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)
+ w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)
-- This is safe WRT #17760 as we we guarantee that the above line doesn't
-- diverge
writeFastMutInt ix_r (ix + size)
return w
-putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 :: WriteBinHandle -> Word8 -> IO ()
putWord8 h !w = putPrim h 1 (\op -> poke op w)
-getWord8 :: BinHandle -> IO Word8
+getWord8 :: ReadBinHandle -> IO Word8
getWord8 h = getPrim h 1 peek
-putWord16 :: BinHandle -> Word16 -> IO ()
+putWord16 :: WriteBinHandle -> Word16 -> IO ()
putWord16 h w = putPrim h 2 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
)
-getWord16 :: BinHandle -> IO Word16
+getWord16 :: ReadBinHandle -> IO Word16
getWord16 h = getPrim h 2 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
return $! w0 `shiftL` 8 .|. w1
)
-putWord32 :: BinHandle -> Word32 -> IO ()
+putWord32 :: WriteBinHandle -> Word32 -> IO ()
putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
@@ -412,7 +501,7 @@ putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
)
-getWord32 :: BinHandle -> IO Word32
+getWord32 :: ReadBinHandle -> IO Word32
getWord32 h = getPrim h 4 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -425,7 +514,7 @@ getWord32 h = getPrim h 4 (\op -> do
w3
)
-putWord64 :: BinHandle -> Word64 -> IO ()
+putWord64 :: WriteBinHandle -> Word64 -> IO ()
putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
@@ -437,7 +526,7 @@ putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
)
-getWord64 :: BinHandle -> IO Word64
+getWord64 :: ReadBinHandle -> IO Word64
getWord64 h = getPrim h 8 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -458,10 +547,10 @@ getWord64 h = getPrim h 8 (\op -> do
w7
)
-putByte :: BinHandle -> Word8 -> IO ()
+putByte :: WriteBinHandle -> Word8 -> IO ()
putByte bh !w = putWord8 bh w
-getByte :: BinHandle -> IO Word8
+getByte :: ReadBinHandle -> IO Word8
getByte h = getWord8 h
-- -----------------------------------------------------------------------------
@@ -484,15 +573,15 @@ getByte h = getWord8 h
-- for now.
-- Unsigned numbers
-{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}
-putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()
putULEB128 bh w =
#if defined(DEBUG)
(if w < 0 then panic "putULEB128: Signed number" else id) $
@@ -509,15 +598,15 @@ putULEB128 bh w =
putByte bh byte
go (w `unsafeShiftR` 7)
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}
-getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-}
+getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a
getULEB128 bh =
go 0 0
where
@@ -533,15 +622,15 @@ getULEB128 bh =
return $! val
-- Signed numbers
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}
-putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
go :: a -> IO ()
@@ -561,15 +650,15 @@ putSLEB128 bh initial = go initial
unless done $ go val'
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}
-getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}
+getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a
getSLEB128 bh = do
(val,shift,signed) <- go 0 0
if signed && (shift < finiteBitSize val )
@@ -980,63 +1069,63 @@ instance Binary (Bin a) where
-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B
-- by using a forward reference
-forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)
+forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut bh put_A put_B = do
-- write placeholder pointer to A
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a
-- write B
r_b <- put_B
-- update A's pointer
- a <- tellBin bh
+ a <- tellBinWriter bh
putAt bh pre_a a
- seekBinNoExpand bh a
+ seekBinNoExpandWriter bh a
-- write A
r_a <- put_A r_b
pure (r_a,r_b)
-forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()
+forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B
-- | Read a value stored using a forward reference
-forwardGet :: BinHandle -> IO a -> IO a
+forwardGet :: ReadBinHandle -> IO a -> IO a
forwardGet bh get_A = do
-- read forward reference
p <- get bh -- a BinPtr
-- store current position
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
-- go read the forward value, then seek back
- seekBinNoExpand bh p
+ seekBinNoExpandReader bh p
r <- get_A
- seekBinNoExpand bh p_a
+ seekBinNoExpandReader bh p_a
pure r
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
-lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut :: Binary a => WriteBinHandle -> a -> IO ()
lazyPut bh a = do
-- output the obj with a ptr to skip over it:
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a -- save a slot for the ptr
put_ bh a -- dump the object
- q <- tellBin bh -- q = ptr to after object
+ q <- tellBinWriter bh -- q = ptr to after object
putAt bh pre_a q -- fill in slot before a with ptr to q
- seekBin bh q -- finally carry on writing at q
+ seekBinWriter bh q -- finally carry on writing at q
-lazyGet :: Binary a => BinHandle -> IO a
+lazyGet :: Binary a => ReadBinHandle -> IO a
lazyGet bh = do
p <- get bh -- a BinPtr
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
a <- unsafeInterleaveIO $ do
-- NB: Use a fresh off_r variable in the child thread, for thread
-- safety.
off_r <- newFastMutInt 0
- getAt bh { _off_r = off_r } p_a
- seekBin bh p -- skip over the object for now
+ getAt bh { rbm_off_r = off_r } p_a
+ seekBinNoExpandReader bh p -- skip over the object for now
return a
-- | Serialize the constructor strictly but lazily serialize a value inside a
@@ -1044,14 +1133,14 @@ lazyGet bh = do
--
-- This way we can check for the presence of a value without deserializing the
-- value itself.
-lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO ()
+lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()
lazyPutMaybe bh Nothing = putWord8 bh 0
lazyPutMaybe bh (Just x) = do
putWord8 bh 1
lazyPut bh x
-- | Deserialize a value serialized by 'lazyPutMaybe'.
-lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)
+lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)
lazyGetMaybe bh = do
h <- getWord8 bh
case h of
@@ -1062,7 +1151,9 @@ lazyGetMaybe bh = do
-- UserData
-- -----------------------------------------------------------------------------
--- | Information we keep around during interface file
+-- Note [Binary UserData]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- Information we keep around during interface file
-- serialization/deserialization. Namely we keep the functions for serializing
-- and deserializing 'Name's and 'FastString's. We do this because we actually
-- use serialization in two distinct settings,
@@ -1081,73 +1172,254 @@ lazyGetMaybe bh = do
-- non-binding Name is serialized as the fingerprint of the thing they
-- represent. See Note [Fingerprinting IfaceDecls] for further discussion.
--
-data UserData =
- UserData {
- -- for *deserialising* only:
- ud_get_name :: BinHandle -> IO Name,
- ud_get_fs :: BinHandle -> IO FastString,
-
- -- for *serialising* only:
- ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
- -- ^ serialize a non-binding 'Name' (e.g. a reference to another
- -- binding).
- ud_put_binding_name :: BinHandle -> Name -> IO (),
- -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
- ud_put_fs :: BinHandle -> FastString -> IO ()
+
+-- | Existential for 'BinaryWriter' with a type witness.
+data SomeBinaryWriter = forall a . SomeBinaryWriter TypeRep (BinaryWriter a)
+
+-- | Existential for 'BinaryReader' with a type witness.
+data SomeBinaryReader = forall a . SomeBinaryReader TypeRep (BinaryReader a)
+
+-- | UserData required to serialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data WriterUserData =
+ WriterUserData {
+ ud_writer_data :: Map TypeRep SomeBinaryWriter
+ -- ^ A mapping from a type witness to the 'Writer' for the associated type.
+ -- This is a 'Map' because microbenchmarks indicated this is more efficient
+ -- than other representations for less than ten elements.
+ --
+ -- Considered representations:
+ --
+ -- * [(TypeRep, SomeBinaryWriter)]
+ -- * bytehash (on hackage)
+ -- * Map TypeRep SomeBinaryWriter
}
-newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
- -> (BinHandle -> IO FastString)
- -> UserData
-newReadState get_name get_fs
- = UserData { ud_get_name = get_name,
- ud_get_fs = get_fs,
- ud_put_nonbinding_name = undef "put_nonbinding_name",
- ud_put_binding_name = undef "put_binding_name",
- ud_put_fs = undef "put_fs"
- }
-
-newWriteState :: (BinHandle -> Name -> IO ())
- -- ^ how to serialize non-binding 'Name's
- -> (BinHandle -> Name -> IO ())
+-- | UserData required to deserialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data ReaderUserData =
+ ReaderUserData {
+ ud_reader_data :: Map TypeRep SomeBinaryReader
+ -- ^ A mapping from a type witness to the 'Reader' for the associated type.
+ -- This is a 'Map' because microbenchmarks indicated this is more efficient
+ -- than other representations for less than ten elements.
+ --
+ -- Considered representations:
+ --
+ -- * [(TypeRep, SomeBinaryReader)]
+ -- * bytehash (on hackage)
+ -- * Map TypeRep SomeBinaryReader
+ }
+
+mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData
+mkWriterUserData caches = noWriterUserData
+ { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (typRep, cache)) caches
+ }
+
+mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData
+mkReaderUserData caches = noReaderUserData
+ { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (typRep, cache)) caches
+ }
+
+mkSomeBinaryWriter :: forall a . Typeable a => BinaryWriter a -> SomeBinaryWriter
+mkSomeBinaryWriter cb = SomeBinaryWriter (typeRep (Proxy :: Proxy a)) cb
+
+mkSomeBinaryReader :: forall a . Typeable a => BinaryReader a -> SomeBinaryReader
+mkSomeBinaryReader cb = SomeBinaryReader (typeRep (Proxy :: Proxy a)) cb
+
+data BinaryReader s = BinaryReader
+ { getEntry :: ReadBinHandle -> IO s
+ }
+
+data BinaryWriter s = BinaryWriter
+ { putEntry :: WriteBinHandle -> s -> IO ()
+ }
+
+mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
+mkWriter f = BinaryWriter
+ { putEntry = f
+ }
+
+mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s
+mkReader f = BinaryReader
+ { getEntry = f
+ }
+
+findUserDataReader :: forall a . Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
+findUserDataReader query bh =
+ case Map.lookup (typeRep query) (ud_reader_data $ getReaderUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryReader for key " ++ show (typeRep query)
+ Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
+ unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader
+
+findUserDataWriter :: forall a . Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
+findUserDataWriter query bh =
+ case Map.lookup (typeRep query) (ud_writer_data $ getWriterUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryWriter for key " ++ show (typeRep query)
+ Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) ->
+ unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer
+
+noReaderUserData :: ReaderUserData
+noReaderUserData = ReaderUserData
+ { ud_reader_data = Map.empty
+ }
+
+noWriterUserData :: WriterUserData
+noWriterUserData = WriterUserData
+ { ud_writer_data = Map.empty
+ }
+
+newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's
+ -> (ReadBinHandle -> IO FastString)
+ -> ReaderUserData
+newReadState get_name get_fs =
+ mkReaderUserData
+ [ mkSomeBinaryReader $ mkReader get_name
+ , mkSomeBinaryReader $ mkReader get_fs
+ ]
+
+newWriteState :: (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize binding 'Name's
- -> (BinHandle -> FastString -> IO ())
- -> UserData
-newWriteState put_nonbinding_name put_binding_name put_fs
- = UserData { ud_get_name = undef "get_name",
- ud_get_fs = undef "get_fs",
- ud_put_nonbinding_name = put_nonbinding_name,
- ud_put_binding_name = put_binding_name,
- ud_put_fs = put_fs
- }
-
-noUserData :: UserData
-noUserData = UserData
- { ud_get_name = undef "get_name"
- , ud_get_fs = undef "get_fs"
- , ud_put_nonbinding_name = undef "put_nonbinding_name"
- , ud_put_binding_name = undef "put_binding_name"
- , ud_put_fs = undef "put_fs"
+ -> (WriteBinHandle -> FastString -> IO ())
+ -> WriterUserData
+newWriteState put_binding_name put_fs =
+ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter put_binding_name
+ , mkSomeBinaryWriter $ mkWriter put_fs
+ ]
+
+-- ----------------------------------------------------------------------------
+-- Types for lookup and deduplication tables.
+-- ----------------------------------------------------------------------------
+
+data SomeReaderTable f = forall a . Typeable a =>
+ SomeReaderTable (f (ReaderTable a))
+
+data SomeWriterTable f = forall a . Typeable a =>
+ SomeWriterTable (f (WriterTable, BinaryWriter a))
+
+data ReaderTable a = ReaderTable
+ { getTable :: ReadBinHandle -> IO (SymbolTable a)
+ , mkReaderFromTable :: SymbolTable a -> BinaryReader a
}
-undef :: String -> a
-undef s = panic ("Binary.UserData: no " ++ s)
+data WriterTable = WriterTable
+ { putTable :: WriteBinHandle -> IO Int
+ }
+
+-- ----------------------------------------------------------------------------
+-- Common data structures for constructing and maintaining lookup tables for
+-- binary serialisation and deserialisation.
+-- ----------------------------------------------------------------------------
+
+data GenericSymbolTable a = GenericSymbolTable
+ { gen_symtab_next :: !FastMutInt
+ -- ^ The next index to use
+ , gen_symtab_map :: !(IORef (Map.Map a Int))
+ -- ^ Given a symbol, find the symbol
+ }
+
+initGenericSymbolTable :: IO (GenericSymbolTable a)
+initGenericSymbolTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef Map.empty
+ pure $ GenericSymbolTable
+ { gen_symtab_next = symtab_next
+ , gen_symtab_map = symtab_map
+ }
+
+putGenericSymbolTable :: forall a. GenericSymbolTable a -> (BinHandle -> a -> IO ()) -> BinHandle -> IO Int
+putGenericSymbolTable gen_sym_tab serialiser bh = do
+ table_count <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putGenericSymbolTable bh table_count symtab_map
+ pure table_count
+ where
+ symtab_map = gen_symtab_map gen_sym_tab
+ symtab_next = gen_symtab_next gen_sym_tab
+ putGenericSymbolTable :: BinHandle -> Int -> Map.Map a Int -> IO ()
+ putGenericSymbolTable bh name_count symtab = do
+ put_ bh name_count
+ let genElements = elems (array (0,name_count-1) (fmap swap $ Map.toList symtab))
+ mapM_ (\n -> serialiser bh n) genElements
+
+getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> BinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bh = do
+ sz <- get bh :: IO Int
+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
+ forM_ [0..(sz-1)] $ \i -> do
+ f <- deserialiser bh
+ writeArray mut_arr i f
+ unsafeFreeze mut_arr
+
+putGenericSymTab :: (Ord a, Binary a) => GenericSymbolTable a -> BinHandle -> a -> IO ()
+putGenericSymTab GenericSymbolTable{
+ gen_symtab_map = symtab_map_ref,
+ gen_symtab_next = symtab_next }
+ bh val = do
+ symtab_map <- readIORef symtab_map_ref
+ case Map.lookup val symtab_map of
+ Just off -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! Map.insert val off symtab_map
+ put_ bh (fromIntegral off :: Word32)
+
+getGenericSymtab :: Binary a => SymbolTable a
+ -> BinHandle -> IO a
+getGenericSymtab symtab bh = do
+ i :: Word32 <- get bh
+ return $! symtab ! fromIntegral i
---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------
-type Dictionary = Array Int FastString -- The dictionary
- -- Should be 0-indexed
+-- | A 'SymbolTable' of 'FastString's.
+type Dictionary = SymbolTable FastString
+
+initFastStringReaderTable :: IO (ReaderTable FastString)
+initFastStringReaderTable = do
+ return $
+ ReaderTable
+ { getTable = getDictionary
+ , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl)
+ }
-putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
+initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)
+initFastStringWriterTable = do
+ dict_next_ref <- newFastMutInt 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict =
+ FSTable
+ { fs_tab_next = dict_next_ref
+ , fs_tab_map = dict_map_ref
+ }
+ let put_dict bh = do
+ fs_count <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
+ putDictionary bh fs_count dict_map
+ pure fs_count
+
+ return
+ ( WriterTable
+ { putTable = put_dict
+ }
+ , mkWriter $ putDictFastString bin_dict
+ )
+
+putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary bh sz dict = do
put_ bh sz
mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
-- It's OK to use nonDetEltsUFM here because the elements have indices
-- that array uses to create order
-getDictionary :: BinHandle -> IO Dictionary
+getDictionary :: ReadBinHandle -> IO Dictionary
getDictionary bh = do
sz <- get bh :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
@@ -1156,34 +1428,12 @@ getDictionary bh = do
writeArray mut_arr i fs
unsafeFreeze mut_arr
-getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
-
-initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
-initFSTable bh = do
- dict_next_ref <- newFastMutInt 0
- dict_map_ref <- newIORef emptyUFM
- let bin_dict = FSTable
- { fs_tab_next = dict_next_ref
- , fs_tab_map = dict_map_ref
- }
- let put_dict = do
- fs_count <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh fs_count dict_map
- pure fs_count
-
- -- BinHandle with FastString writing support
- let ud = getUserData bh
- let ud_fs = ud { ud_put_fs = putDictFastString bin_dict }
- let bh_fs = setUserData bh ud_fs
-
- return (bh_fs,bin_dict,put_dict)
-
-putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
+putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: FSTable -> FastString -> IO Word32
@@ -1212,43 +1462,42 @@ data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use
-- The Symbol Table
---------------------------------------------------------
--- On disk, the symbol table is an array of IfExtName, when
--- reading it in we turn it into a SymbolTable.
-
-type SymbolTable = Array Int Name
+-- | Symbols that are read from disk.
+-- The 'SymbolTable' index starts on '0'.
+type SymbolTable a = Array Int a
---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------
-putFS :: BinHandle -> FastString -> IO ()
+putFS :: WriteBinHandle -> FastString -> IO ()
putFS bh fs = putBS bh $ bytesFS fs
-getFS :: BinHandle -> IO FastString
+getFS :: ReadBinHandle -> IO FastString
getFS bh = do
l <- get bh :: IO Int
getPrim bh l (\src -> pure $! mkFastStringBytes src l )
-- | Put a ByteString without its length (can't be read back without knowing the
-- length!)
-putByteString :: BinHandle -> ByteString -> IO ()
+putByteString :: WriteBinHandle -> ByteString -> IO ()
putByteString bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-- | Get a ByteString whose length is known
-getByteString :: BinHandle -> Int -> IO ByteString
+getByteString :: ReadBinHandle -> Int -> IO ByteString
getByteString bh l =
BS.create l $ \dest -> do
getPrim bh l (\src -> copyBytes dest src l)
-putBS :: BinHandle -> ByteString -> IO ()
+putBS :: WriteBinHandle -> ByteString -> IO ()
putBS bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
put_ bh l
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-getBS :: BinHandle -> IO ByteString
+getBS :: ReadBinHandle -> IO ByteString
getBS bh = do
l <- get bh :: IO Int
BS.create l $ \dest -> do
@@ -1260,12 +1509,12 @@ instance Binary ByteString where
instance Binary FastString where
put_ bh f =
- case getUserData bh of
- UserData { ud_put_fs = put_fs } -> put_fs bh f
+ case findUserDataWriter (Proxy :: Proxy FastString) bh of
+ tbl -> putEntry tbl bh f
get bh =
- case getUserData bh of
- UserData { ud_get_fs = get_fs } -> get_fs bh
+ case findUserDataReader (Proxy :: Proxy FastString) bh of
+ tbl -> getEntry tbl bh
deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString
=====================================
compiler/GHC/Utils/Binary/Typeable.hs
=====================================
@@ -35,7 +35,7 @@ instance Binary TyCon where
get bh =
mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-getSomeTypeRep :: BinHandle -> IO SomeTypeRep
+getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep
getSomeTypeRep bh = do
tag <- get bh :: IO Word8
case tag of
@@ -167,7 +167,7 @@ instance Binary TypeLitSort where
2 -> pure TypeLitChar
_ -> fail "Binary.putTypeLitSort: invalid tag"
-putTypeRep :: BinHandle -> TypeRep a -> IO ()
+putTypeRep :: WriteBinHandle -> TypeRep a -> IO ()
putTypeRep bh rep -- Handle Type specially since it's so common
| Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
= put_ bh (0 :: Word8)
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 504d4c1842db93704b4c5e158ecc3af7050ba9fe
+Subproject commit 799390d1c6d59a606c3dd00dea057baa26ed0c2f
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/462541610e53b4fa54b6c67a361e730fedab62d9...aa3ccba8f9c84e141377908e96dd832c173d2267
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/462541610e53b4fa54b6c67a361e730fedab62d9...aa3ccba8f9c84e141377908e96dd832c173d2267
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240402/1f273f84/attachment-0001.html>
More information about the ghc-commits
mailing list