[Git][ghc/ghc][wip/fendor/ghc-iface-refact] 2 commits: Refactor the Binary serialisation interface
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Wed Apr 3 11:58:26 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ghc-iface-refact at Glasgow Haskell Compiler / GHC
Commits:
413b0ba9 by Fendor at 2024-04-03T13:57:05+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.
- - - - -
54a9bfea by Fendor at 2024-04-03T13:57:58+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.
- - - - -
13 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Recomp/Binary.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,9 @@ import Data.Char
import Data.Word
import Data.IORef
import Control.Monad
+import Data.Functor.Identity
+import Data.Bifunctor (Bifunctor(second))
+import Data.Coerce
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -75,7 +77,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 +123,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 +139,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 +150,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 +158,33 @@ 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)
+ , SomeReaderTable @IO @NonBindingName (coerce (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 +197,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 +214,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 +238,40 @@ 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
+ , SomeWriterTable (fmap (second (\(BinaryWriter f) -> BinaryWriter (\bh name -> f bh (getNonBindingName name)))) 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 +283,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 +393,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 +414,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 +438,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 +463,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 +482,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,15 +105,16 @@ 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)
+ (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
@@ -121,9 +122,9 @@ writeHieFile hie_file_path hiefile = do
putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the front of the file
- dict_p <- tellBin bh
+ 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 +182,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 +191,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 +214,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 +233,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 +261,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 +277,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 +335,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 +346,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/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 =
@@ -35,11 +35,11 @@ computeFingerprint put_nonbinding_name a = do
fingerprintBinMem bh
where
set_user_data bh =
- setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+ setWriterUserData bh $ newWriteState put_nonbinding_name 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/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
@@ -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,14 +140,14 @@ 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 (NonBindingName ac)
get bh = do
aa <- get bh
ab <- get bh
- ac <- get bh
- return (FieldLabel aa ab ac)
+ ac <- case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
+ return (FieldLabel aa ab $ getNonBindingName ac)
flIsOverloaded :: FieldLabel -> Bool
flIsOverloaded fl =
=====================================
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,15 +69,30 @@ 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,
-- * Newtype wrappers
- BinSpan(..), BinSrcSpan(..), BinLocated(..)
+ BinSpan(..), BinSrcSpan(..), BinLocated(..),
+ -- * Newtypes for types that have canonically more than one valid encoding
+ NonBindingName(..),
) where
import GHC.Prelude
@@ -93,6 +111,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 +123,13 @@ 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.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 +140,9 @@ import qualified Data.IntMap as IntMap
import GHC.ForeignPtr ( unsafeWithForeignPtr )
#endif
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Coerce
+
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -150,49 +174,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
-setUserData :: BinHandle -> UserData -> BinHandle
-setUserData bh us = bh { bh_usr = us }
+setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
+setWriterUserData bh us = bh { wbm_userData = 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 +269,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 +293,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 +352,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 +389,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 +405,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 +426,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 +448,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 +486,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 +499,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 +511,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 +532,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 +558,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 +583,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 +607,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 +635,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 +1054,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 +1118,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 +1136,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 +1157,197 @@ 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 ()
+
+-- | Newtype to serialise non-binding names differently to 'Name'.
+-- See Note [Binary UserData]
+newtype NonBindingName = NonBindingName { getNonBindingName :: Name }
+ deriving ( Eq )
+
+-- | 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 ())
+-- | 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
+ } deriving (Functor)
+
+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 the 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 the 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 @NonBindingName (coerce get_name)
+ , mkSomeBinaryReader $ mkReader get_fs
+ ]
+
+newWriteState :: (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize non-binding 'Name's
- -> (BinHandle -> Name -> IO ())
+ -> (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_non_binding_name put_binding_name put_fs =
+ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_non_binding_name bh (getNonBindingName name))
+ , 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
+ }
---------------------------------------------------------
-- 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)
+ }
+
+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
-putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
+ 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 +1356,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 +1390,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 +1437,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 edf742131e272fc29c6d6eae549b0fe37eea11b9
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3b37648179355fde9e450a55a56e09bc3a12944...54a9bfea91adfb6d72315e1b9570793b3ed9ebca
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3b37648179355fde9e450a55a56e09bc3a12944...54a9bfea91adfb6d72315e1b9570793b3ed9ebca
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/20240403/b6e7bf1d/attachment-0001.html>
More information about the ghc-commits
mailing list