diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index a1611fe2637a03b220bf683cc64a552440a7ff23..f00237f8865a1a00d01e9aea99765b9d718ac579 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/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
@@ -39,6 +38,7 @@ import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
+import GHC.Data.FastString (FastString)
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
@@ -121,6 +121,8 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
pure (src_hash, bh)
-- | Read an interface file.
+--
+-- See Note [Deduplication during iface binary serialisation] for details.
readBinIface
:: Profile
-> NameCache
@@ -156,22 +158,28 @@ getWithUserData name_cache bh = do
-- Reading names has the side effect of adding them into the given NameCache.
getTables :: NameCache -> BinHandle -> IO BinHandle
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)
+ fsReaderTable <- initFastStringReaderTable
+ nameReaderTable <- initNameReaderTable name_cache
+
- -- Initialise the user-data field of bh
- let bh_fs = setUserData bh $ newReadState (error "getSymtabName")
- (getDictFastString dict)
+ -- The order of these deserialisation matters!
+ --
+ -- See Note [Order of deduplication tables during iface binary serialisation] for details.
+ fsTable <- Binary.forwardGet bh (getTable fsReaderTable bh)
+ let
+ fsReader = mkReaderFromTable fsReaderTable fsTable
+ bhFs = addReaderToUserData (mkSomeBinaryReader fsReader) bh
- symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)
+ nameTable <- Binary.forwardGet bh (getTable nameReaderTable bhFs)
+ let
+ nameReader = mkReaderFromTable nameReaderTable nameTable
+ bhName = addReaderToUserData (mkSomeBinaryReader nameReader) bhFs
- -- It is only now that we know how to get a Name
- return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
- (getDictFastString dict)
+ pure bhName
--- | Write an interface file
+-- | Write an interface file.
+--
+-- See Note [Deduplication during iface binary serialisation] for details.
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
writeBinIface profile traceBinIface hi_path mod_iface = do
bh <- openBinMem initBinMemSize
@@ -225,58 +233,262 @@ 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
- }
+-- See Note [Order of deduplication tables during iface binary serialisation]
+putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int, Int, b)
+putWithTables bh' put_payload = do
+ -- Initialise deduplicating tables.
+ (fast_wt, fsWriter) <- initFastStringWriterTable
+ (name_wt, nameWriter) <- initNameWriterTable
+
+ -- Initialise the 'WriterUserData'.
+ let writerUserData = mkWriterUserData
+ [ mkSomeBinaryWriter @FastString fsWriter
+ , mkSomeBinaryWriter @Name nameWriter
+ -- We sometimes serialise binding and non-binding names differently, but
+ -- not during 'ModIface' serialisation. Here, we serialise both to the same
+ -- deduplication table.
+ --
+ -- See Note [Binary UserData]
+ , mkSomeBinaryWriter @BindingName $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name))
+ ]
+ let bh = setWriterUserData bh' writerUserData
+
+ (fs_count : name_count : _, r) <-
+ -- The order of these entries matters!
+ --
+ -- See Note [Order of deduplication tables during iface binary serialisation] for details.
+ putAllTables bh [fast_wt, name_wt] $ 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)
- (bh_fs, bin_dict, put_dict) <- initFSTable bh
-
- (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
+-- | Initial ram buffer to allocate for writing interface files
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024
- -- 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
+binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
+binaryInterfaceMagic platform
+ | target32Bit platform = FixedLengthEncoding 0x1face
+ | otherwise = FixedLengthEncoding 0x1face64
- 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
+{-
+Note [Deduplication during iface binary serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we serialise a 'ModIface', many symbols are redundant.
+For example, there can be many duplicated 'FastString's and 'Name's.
+To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name',
+by maintaining a table of already seen symbols.
- put_payload bh_name
+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'.
- return (name_count, fs_count, r)
+The general idea is, when serialising a value of type 'Name', we first have to create a deduplication
+table (see 'putWithTables.initNameWriterTable' for example). Then, we create a 'BinaryWriter' function
+which we add to the 'WriterUserData'. When this 'BinaryWriter' is used to serialise a value of type 'Name',
+it looks up whether we have seen this value before. If so, we write an index to disk.
+If we haven't seen the value before, we add it to the deduplication table and produce a new index.
+Both the 'ReaderUserData' and 'WriterUserData' can contain many 'BinaryReader's and 'BinaryWriter's
+respectively, which can each individually be tweaked to use a deduplication table, or to serialise
+the value without deduplication.
+After the payload (e.g., the 'ModIface') has been serialised to disk, we serialise the deduplication tables
+to disk. This happens in 'putAllTables', where we serialise all tables that we use during 'ModIface'
+serialisation. See 'initNameWriterTable' and 'putSymbolTable' for an implementation example.
+This uses the 'real' serialisation function, e.g., 'serialiseName'.
+However, these tables need to be deserialised before we can read the 'ModIface' from disk.
+Thus, we write before the 'ModIface' a forward pointer to the deduplication table, so we can
+read this table before deserialising the 'ModIface'.
--- | Initial ram buffer to allocate for writing interface files
-initBinMemSize :: Int
-initBinMemSize = 1024 * 1024
+To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following:
-binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
-binaryInterfaceMagic platform
- | target32Bit platform = FixedLengthEncoding 0x1face
- | otherwise = FixedLengthEncoding 0x1face64
+* The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser function instead of
+ serialising the value of 'IfaceTyCon'. It needs to look up the serialiser in the 'ReaderUserData' and
+ 'WriterUserData' respectively.
+ This allows us to change the serialisation of 'IfaceTyCon' at run-time.
+ We can still serialise 'IfaceTyCon' to disk directly, or use a deduplication table to reduce the size of
+ the .hi file.
+
+ For example:
+
+ @
+ instance Binary IfaceTyCon where
+ put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of
+ tbl -> putEntry tbl bh ty
+ get bh = case findUserDataReader (Proxy @IfaceTyCon) bh of
+ tbl -> getEntry tbl bh
+ @
+
+ We include the signatures of 'findUserDataWriter' and 'findUserDataReader' to make this code example
+ easier to understand:
+
+ @
+ findUserDataReader :: Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
+ findUserDataWriter :: Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
+ @
+
+ where 'BinaryReader' and 'BinaryWriter' correspond to the 'Binary' class methods
+ 'get' and 'put_' respectively, thus:
+
+ @
+ newtype BinaryReader s = BinaryReader { getEntry :: ReadBinHandle -> IO s }
+
+ newtype BinaryWriter s = BinaryWriter { putEntry :: WriteBinHandle -> s -> IO () }
+ @
+
+ 'findUserData*' looks up the serialisation function for 'IfaceTyCon', which we then subsequently
+ use to serialise said 'IfaceTyCon'. If no such serialiser can be found, 'findUserData*'
+ crashes at run-time.
+
+* Whenever a value of 'IfaceTyCon' needs to be serialised, there are two serialisation functions involved:
+
+ * The literal serialiser that puts/gets the value to/from disk:
+ Writes or reads a value of type 'IfaceTyCon' from the 'Write/ReadBinHandle'.
+ This serialiser is primarily used to write the values stored in the deduplication table.
+ It is also used to read the values from disk.
+
+ * The deduplicating serialiser:
+ Replaces the serialised value of 'IfaceTyCon' with an offset that is stored in the
+ deduplication table.
+ This serialiser is used while serialising the payload.
+
+ We need to add the deduplicating serialiser to the 'ReaderUserData' and 'WriterUserData'
+ respectively, so that 'findUserData*' can find them.
+
+ For example, adding a serialiser for writing 'IfaceTyCon's:
+
+ @
+ let bh0 :: WriteBinHandle = ...
+ putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk
+ bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0
+ @
+
+ Naturally, you have to do something similar for reading values of 'IfaceTyCon'.
+
+ The provided code example implements the previous behaviour:
+ serialise all values of type 'IfaceTyCon' directly. No deduplication is happening.
+
+ Now, instead of literally putting the value, we can introduce a deduplication table!
+ Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk,
+ we provide a function that looks up values in a table and provides an index of each value
+ we have already seen.
+ If the particular 'IfaceTyCon' we want to serialise isn't already in the de-dup table,
+ we allocate a new index and extend the table.
+
+ See the definition of 'initNameWriterTable' and 'initNameReaderTable' for example deduplication tables.
+
+* Storing the deduplication table.
+
+ After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication
+ table full with all the values.
+ We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon').
+
+ When serialisation is complete, we write out the de-dup table in 'putAllTables',
+ serialising each 'IfaceTyCon' in the table. Of course, doing so might in turn serialise
+ another de-dup'd thing (e.g. a FastString), thereby extending its respective de-dup table.
+
+Note [Order of deduplication tables during iface binary serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often.
+See Note [Deduplication during iface binary serialisation].
+
+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.
+What deduplication tables exist and the order of serialisation is currently statically specified
+in 'putWithTables'. 'putWithTables' also takes care of the serialisation of used deduplication tables.
+The deserialisation of the deduplication tables happens 'getTables', using 'Binary' utility
+functions such as 'forwardGet'.
+
+Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'):
+
+┌──────────────â”
+│ Headers │
+├──────────────┤
+│ Ptr FS ├────────â”
+├──────────────┤ │
+│ Ptr Name ├─────┠│
+├──────────────┤ │ │
+│ │ │ │
+│ ModIface │ │ │
+│ Payload │ │ │
+│ │ │ │
+├──────────────┤ │ │
+│ │ │ │
+│ Name Table │◄────┘ │
+│ │ │
+├──────────────┤ │
+│ │ │
+│ FS Table │◄───────┘
+│ │
+└──────────────┘
+
+-}
-- -----------------------------------------------------------------------------
-- The symbol table
--
+
+initNameReaderTable :: NameCache -> IO (ReaderTable Name)
+initNameReaderTable 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
+ }
+
+initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
+initNameWriterTable = 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 :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh name_count symtab = do
put_ bh name_count
@@ -286,7 +498,7 @@ putSymbolTable bh name_count symtab = do
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: BinHandle -> 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
@@ -331,8 +543,8 @@ serialiseName bh name _ = do
-- See Note [Symbol table representation of names]
-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
-putName _dict BinSymbolTable{
+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
@@ -356,10 +568,9 @@ putName _dict BinSymbolTable{
put_ bh (fromIntegral off :: Word32)
-- See Note [Symbol table representation of names]
-getSymtabName :: NameCache
- -> Dictionary -> SymbolTable
+getSymtabName :: SymbolTable Name
-> BinHandle -> IO Name
-getSymtabName _name_cache _dict symtab bh = do
+getSymtabName symtab bh = do
i :: Word32 <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral i
@@ -376,10 +587,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
- }
-
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index d9d57398b704da8cca495edb61d505ca08e21a10..f1a1058f4a39a50929faa22f3d037f5d5c8089de 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -105,9 +105,10 @@ 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
@@ -218,10 +219,11 @@ 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'
@@ -265,7 +267,7 @@ putSymbolTable bh next_off symtab = do
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: BinHandle -> 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,7 +277,7 @@ getSymbolTable bh name_cache = do
A.writeArray mut_arr i name
A.unsafeFreeze mut_arr
-getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName :: SymbolTable Name -> BinHandle -> IO Name
getSymTabName st bh = do
i :: Word32 <- get bh
return $ st A.! (fromIntegral i)
diff --git a/compiler/GHC/Iface/Recomp/Binary.hs b/compiler/GHC/Iface/Recomp/Binary.hs
index 60f0d5fc8650931f0fcacd35020fe393e4eeb105..a3ebb31e3eb520976874118c8324f5a6596dd0a7 100644
--- a/compiler/GHC/Iface/Recomp/Binary.hs
+++ b/compiler/GHC/Iface/Recomp/Binary.hs
@@ -35,7 +35,7 @@ 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.
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 96308f8d72aeb2a3cf0380b389712a938859ae5f..94cec93c2ec93d4d1222086611821c50d5a65a8d 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/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 &&&
@@ -123,10 +124,10 @@ getIfaceTopBndr bh = get bh
putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
putIfaceTopBndr bh name =
- case getUserData bh of
- UserData{ ud_put_binding_name = put_binding_name } ->
+ case findUserDataWriter (Proxy @BindingName) bh of
+ tbl ->
--pprTrace "putIfaceTopBndr" (ppr name) $
- put_binding_name bh name
+ putEntry tbl bh (BindingName name)
data IfaceDecl
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index acf5794802f338c9452dfddae3f1fc7048ee0704..134f165946610caf8e8b61c0782db8c6d0285067 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/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,
@@ -93,7 +92,7 @@ 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 Control.Monad
{-
************************************************************************
@@ -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
diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs
index ab05817c90344201ed545a21db381bc92ce34b62..5dd298af57a12c16d71b7932215a2f53f87eb62e 100644
--- a/compiler/GHC/StgToJS/Object.hs
+++ b/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)
@@ -313,9 +313,10 @@ 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
@@ -348,7 +349,7 @@ getObjectBody :: BinHandle -> 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)
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 5d174347036f485b7a585016b521005dfdf7a71f..5bc85c0e4c13f94b0937fe95dd5d82b8d7ace999 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/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 $
diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs
index 9c35a3ee30da81c5c368008a30a5f9bbb3037d64..edadf377412c83169e0ae26217342b923dc699fe 100644
--- a/compiler/GHC/Types/FieldLabel.hs
+++ b/compiler/GHC/Types/FieldLabel.hs
@@ -140,9 +140,7 @@ 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
+ put_ bh ac
get bh = do
aa <- get bh
ab <- get bh
diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs
index f1979dcbb9a3c523a3b5fe1a52790a1f279cb5a7..981a9817f5e8f4a7a4b9e389b67bccea412664b3 100644
--- a/compiler/GHC/Types/Name.hs
+++ b/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
{-
************************************************************************
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 2b246f3c66d209ab5f607893a8764cc5f9d1bf67..77be07ea593e46e15bfcd9d7348f557bcbd585fc 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -66,15 +66,29 @@ 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
+ ReaderTable(..),
+ 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
+ BindingName(..),
) where
import GHC.Prelude
@@ -87,31 +101,37 @@ import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
+import GHC.Utils.Misc (HasCallStack)
import GHC.Types.SrcLoc
import GHC.Types.Unique
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
import Data.Array.Unsafe
import Data.ByteString (ByteString)
+import Data.Coerce
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
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.Proxy
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 System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
+import qualified Type.Reflection as Refl
import GHC.Real ( Ratio(..) )
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
@@ -119,6 +139,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)
@@ -155,10 +177,10 @@ dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
szr <- newFastMutInt size
binr <- newIORef bin
- return (BinMem noUserData ixr szr binr)
+ return (BinMem noReaderUserData noWriterUserData ixr szr binr)
handleData :: BinHandle -> IO BinData
-handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+handleData (BinMem _ _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
---------------------------------------------------------------
-- BinHandle
@@ -166,7 +188,8 @@ handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef
data BinHandle
= BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
+ bh_reader :: ReaderUserData, -- sigh, need parameterized modules :-)
+ bh_writer :: WriterUserData, -- 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))
@@ -174,15 +197,35 @@ data BinHandle
-- 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
+getReaderUserData :: BinHandle -> ReaderUserData
+getReaderUserData bh = bh_reader bh
-setUserData :: BinHandle -> UserData -> BinHandle
-setUserData bh us = bh { bh_usr = us }
+getWriterUserData :: BinHandle -> WriterUserData
+getWriterUserData bh = bh_writer bh
+
+setWriterUserData :: BinHandle -> WriterUserData -> BinHandle
+setWriterUserData bh us = bh { bh_writer = us }
+
+setReaderUserData :: BinHandle -> ReaderUserData -> BinHandle
+setReaderUserData bh us = bh { bh_reader = us }
+
+addReaderToUserData :: SomeBinaryReader -> BinHandle -> BinHandle
+addReaderToUserData cache@(SomeBinaryReader typRep _) bh = bh
+ { bh_reader = (bh_reader bh)
+ { ud_reader_data = Map.insert (Refl.SomeTypeRep typRep) cache (ud_reader_data (bh_reader bh))
+ }
+ }
+
+addWriterToUserData :: SomeBinaryWriter -> BinHandle -> BinHandle
+addWriterToUserData cache@(SomeBinaryWriter typRep _) bh = bh
+ { bh_writer = (bh_writer bh)
+ { ud_writer_data = Map.insert (Refl.SomeTypeRep typRep) cache (ud_writer_data (bh_writer bh))
+ }
+ }
-- | Get access to the underlying buffer.
withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
-withBinBuffer (BinMem _ ix_r _ arr_r) action = do
+withBinBuffer (BinMem _ _ ix_r _ arr_r) action = do
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
action $ BS.fromForeignPtr arr 0 ix
@@ -192,7 +235,7 @@ 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 (BinMem noReaderUserData noWriterUserData ix_r sz_r arr_r)
---------------------------------------------------------------
-- Bin
@@ -235,13 +278,13 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (BinMem noReaderUserData noWriterUserData ix_r sz_r arr_r)
tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBin (BinMem _ _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin :: BinHandle -> Bin a -> IO ()
-seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBin h@(BinMem _ _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p > sz)
then do expandBin h p; writeFastMutInt ix_r p
@@ -252,14 +295,14 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
-- This operation may 'panic', if the pointer location is out of bounds of the
-- buffer of 'BinHandle'.
seekBinNoExpand :: BinHandle -> Bin a -> IO ()
-seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBinNoExpand (BinMem _ _ 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
+writeBinMem (BinMem _ _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
@@ -291,11 +334,11 @@ readBinMem_ filesize h = do
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt filesize
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (BinMem noReaderUserData noWriterUserData ix_r sz_r arr_r)
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ _ sz_r arr_r) !off = do
+expandBin (BinMem _ _ _ sz_r arr_r) !off = do
!sz <- readFastMutInt sz_r
let !sz' = getSize sz
arr <- readIORef arr_r
@@ -354,7 +397,7 @@ foldGet' n bh init_b f = go 0 init_b
-- 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 h@(BinMem _ _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix + size > sz) $
@@ -376,7 +419,7 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
-- 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 (BinMem _ _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix + size > sz) $
@@ -1065,7 +1108,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,
@@ -1084,64 +1129,221 @@ 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 binding names differently to non-binding 'Name'.
+-- See Note [Binary UserData]
+newtype BindingName = BindingName { getBindingName :: Name }
+ deriving ( Eq )
+
+-- | Existential for 'BinaryWriter' with a type witness.
+data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a)
+
+-- | Existential for 'BinaryReader' with a type witness.
+data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a)
+
+-- | UserData required to serialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data WriterUserData =
+ WriterUserData {
+ ud_writer_data :: Map Refl.SomeTypeRep 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
}
+-- | UserData required to deserialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data ReaderUserData =
+ ReaderUserData {
+ ud_reader_data :: Map Refl.SomeTypeRep 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 _) -> (Refl.SomeTypeRep typRep, cache)) caches
+ }
+
+mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData
+mkReaderUserData caches = noReaderUserData
+ { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (Refl.SomeTypeRep typRep, cache)) caches
+ }
+
+mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter
+mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb
+
+mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader
+mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb
+
+newtype BinaryReader s = BinaryReader
+ { getEntry :: BinHandle -> IO s
+ } deriving (Functor)
+
+newtype BinaryWriter s = BinaryWriter
+ { putEntry :: BinHandle -> s -> IO ()
+ }
+
+mkWriter :: (BinHandle -> s -> IO ()) -> BinaryWriter s
+mkWriter f = BinaryWriter
+ { putEntry = f
+ }
+
+mkReader :: (BinHandle -> IO s) -> BinaryReader s
+mkReader f = BinaryReader
+ { getEntry = f
+ }
+
+-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.
+--
+-- If no 'BinaryReader' for that type can be found, this function will panic at run-time.
+findUserDataReader :: forall a . (HasCallStack, Refl.Typeable a) => Proxy a -> BinHandle -> BinaryReader a
+findUserDataReader query bh =
+ case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query)
+ Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
+ unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader
+ -- This 'unsafeCoerce' could be written safely like this:
+ --
+ -- @
+ -- Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
+ -- case testEquality (typeRep @a) tyRep of
+ -- Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader
+ -- Nothing -> panic $ "Invariant violated"
+ -- @
+ --
+ -- But it comes at a slight performance cost and this function is used in
+ -- binary serialisation hot loops, thus, we prefer the small performance boost over
+ -- the additional type safety.
+
+-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'.
+--
+-- If no 'BinaryWriter' for that type can be found, this function will panic at run-time.
+findUserDataWriter :: forall a . (HasCallStack, Refl.Typeable a) => Proxy a -> BinHandle -> BinaryWriter a
+findUserDataWriter query bh =
+ case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query)
+ Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) ->
+ unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer
+ -- This 'unsafeCoerce' could be written safely like this:
+ --
+ -- @
+ -- Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) ->
+ -- case testEquality (typeRep @a) tyRep of
+ -- Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer
+ -- Nothing -> panic $ "Invariant violated"
+ -- @
+ --
+ -- But it comes at a slight performance cost and this function is used in
+ -- binary serialisation hot loops, thus, we prefer the small performance boost over
+ -- the additional type safety.
+
+
+noReaderUserData :: ReaderUserData
+noReaderUserData = ReaderUserData
+ { ud_reader_data = Map.empty
+ }
+
+noWriterUserData :: WriterUserData
+noWriterUserData = WriterUserData
+ { ud_writer_data = Map.empty
+ }
+
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"
- }
+ -> ReaderUserData
+newReadState get_name get_fs =
+ mkReaderUserData
+ [ mkSomeBinaryReader $ mkReader get_name
+ , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name)
+ , mkSomeBinaryReader $ mkReader get_fs
+ ]
newWriteState :: (BinHandle -> Name -> IO ())
-- ^ how to serialize non-binding 'Name's
-> (BinHandle -> 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"
+ -> WriterUserData
+newWriteState put_non_binding_name put_binding_name put_fs =
+ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name))
+ , mkSomeBinaryWriter $ mkWriter put_non_binding_name
+ , mkSomeBinaryWriter $ mkWriter put_fs
+ ]
+
+-- ----------------------------------------------------------------------------
+-- Types for lookup and deduplication tables.
+-- ----------------------------------------------------------------------------
+
+-- | A 'ReaderTable' describes how to deserialise a table from disk,
+-- and how to create a 'BinaryReader' that looks up values in the deduplication table.
+data ReaderTable a = ReaderTable
+ { getTable :: BinHandle -> IO (SymbolTable a)
+ -- ^ Deserialise a list of elements into a 'SymbolTable'.
+ , mkReaderFromTable :: SymbolTable a -> BinaryReader a
+ -- ^ Given the table from 'getTable', create a 'BinaryReader'
+ -- that reads values only from the 'SymbolTable'.
}
-undef :: String -> a
-undef s = panic ("Binary.UserData: no " ++ s)
+-- | A 'WriterTable' is an interface any deduplication table can implement to
+-- describe how the table can be written to disk.
+newtype WriterTable = WriterTable
+ { putTable :: BinHandle -> IO Int
+ -- ^ Serialise a table to disk. Returns the number of written elements.
+ }
---------------------------------------------------------
-- 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
+
+ return
+ ( WriterTable
+ { putTable = put_dict
+ }
+ , mkWriter $ putDictFastString bin_dict
+ )
putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary bh sz dict = do
@@ -1164,28 +1366,6 @@ 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 dict bh fs = allocateFastString dict fs >>= put_ bh
@@ -1215,10 +1395,9 @@ 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
@@ -1263,12 +1442,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
diff --git a/utils/haddock b/utils/haddock
index 358307f6fa52daa2c2411a4975c87b30932af3dc..278f8b07e027ce33f11a73d3f055c99a34d3cee9 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 358307f6fa52daa2c2411a4975c87b30932af3dc
+Subproject commit 278f8b07e027ce33f11a73d3f055c99a34d3cee9