[Git][ghc/ghc][wip/fendor/ghc-iface-refact] Split `BinHandle` into `ReadBinHandle` and `WriteBinHandle`
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Tue Apr 2 11:57:18 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ghc-iface-refact at Glasgow Haskell Compiler / GHC
Commits:
2c19bd36 by Fendor at 2024-04-02T13:56:56+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.
- - - - -
10 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/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -75,7 +75,7 @@ readBinIfaceHeader
-> CheckHiWay
-> TraceBinIFace
-> FilePath
- -> IO (Fingerprint, BinHandle)
+ -> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
let platform = profilePlatform profile
@@ -137,7 +137,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
mod_iface <- getWithUserData name_cache bh
- seekBin bh extFields_p
+ seekBinNoExpandReader bh extFields_p
extFields <- get bh
return mod_iface
@@ -148,7 +148,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
+getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a
getWithUserData name_cache bh = do
bh <- getTables name_cache bh
get bh
@@ -156,7 +156,7 @@ 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
let
-- The order of these entries matters!
@@ -194,14 +194,14 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
put_ bh tag
put_ bh (mi_src_hash mod_iface)
- extFields_p_p <- tellBin bh
+ extFields_p_p <- tellBinWriter bh
put_ bh extFields_p_p
putWithUserData traceBinIface bh mod_iface
- extFields_p <- tellBin bh
+ extFields_p <- tellBinWriter bh
putAt bh extFields_p_p extFields_p
- seekBin bh extFields_p
+ seekBinWriter bh extFields_p
put_ bh (mi_ext_fields mod_iface)
-- And send the result to the file
@@ -211,7 +211,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
+putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
(name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
@@ -235,7 +235,7 @@ 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 :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
putWithTables bh' put_payload = do
let
-- The order of these entries matters!
@@ -380,7 +380,7 @@ initWriteNameTable = do
)
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
+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))
@@ -389,7 +389,7 @@ putSymbolTable bh name_count symtab = do
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO (SymbolTable Name)
+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
@@ -410,7 +410,7 @@ getSymbolTable bh name_cache = do
arr <- unsafeFreeze mut_arr
return (cache, arr)
-serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
+serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -434,7 +434,7 @@ serialiseName bh name _ = do
-- See Note [Symbol table representation of names]
-putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
@@ -460,7 +460,7 @@ putName BinSymbolTable{
-- See Note [Symbol table representation of names]
getSymtabName :: SymbolTable Name
- -> BinHandle -> IO Name
+ -> ReadBinHandle -> IO Name
getSymtabName symtab bh = do
i :: Word32 <- get bh
case i .&. 0xC0000000 of
=====================================
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
@@ -111,9 +111,9 @@ writeHieFile hie_file_path hiefile = do
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 +121,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 +181,7 @@ readHieFile name_cache file = do
hieFile <- readHieFileContents bh0 name_cache
return $ HieFileResult hieVersion ghcVersion hieFile
-readBinLine :: BinHandle -> IO ByteString
+readBinLine :: ReadBinHandle -> IO ByteString
readBinLine bh = BS.pack . reverse <$> loop []
where
loop acc = do
@@ -190,7 +190,7 @@ readBinLine bh = BS.pack . reverse <$> loop []
then return acc
else loop (char : acc)
-readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader
readHieFileHeader file bh0 = do
-- Read the header
magic <- replicateM hieMagicLen (get bh0)
@@ -213,7 +213,7 @@ 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
@@ -232,21 +232,21 @@ readHieFileContents bh0 name_cache = do
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
- data_p <- tellBin bin_handle
- seekBin bin_handle dict_p
+ data_p <- tellBinReader bin_handle
+ seekBinNoExpandReader bin_handle dict_p
dict <- getDictionary bin_handle
- seekBin bin_handle data_p
+ seekBinNoExpandReader bin_handle data_p
return dict
get_symbol_table bh1 = do
symtab_p <- get bh1
- data_p' <- tellBin bh1
- seekBin bh1 symtab_p
+ data_p' <- tellBinReader bh1
+ seekBinNoExpandReader bh1 symtab_p
symtab <- getSymbolTable bh1 name_cache
- seekBin bh1 data_p'
+ seekBinNoExpandReader bh1 data_p'
return symtab
-putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
@@ -260,13 +260,13 @@ putFastString HieDictionary { hie_dict_next = j_r,
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out unique (j, f)
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
-getSymbolTable :: BinHandle -> NameCache -> IO (SymbolTable Name)
+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)
@@ -276,12 +276,12 @@ getSymbolTable bh name_cache = do
A.writeArray mut_arr i name
A.unsafeFreeze mut_arr
-getSymTabName :: SymbolTable Name -> 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
@@ -334,7 +334,7 @@ fromHieName nc hie_name = do
-- ** Reading and writing `HieName`'s
-putHieName :: BinHandle -> HieName -> IO ()
+putHieName :: WriteBinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
put_ bh (mod, occ, BinSrcSpan span)
@@ -345,7 +345,7 @@ putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
-getHieName :: BinHandle -> IO HieName
+getHieName :: ReadBinHandle -> IO HieName
getHieName bh = do
t <- getByte bh
case t of
=====================================
compiler/GHC/Iface/Ext/Fields.hs
=====================================
@@ -33,16 +33,16 @@ instance Binary ExtensibleFields where
-- for a payload pointer after each name:
header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
put_ bh name
- field_p_p <- tellBin bh
+ field_p_p <- tellBinWriter bh
put_ bh field_p_p
return (field_p_p, dat)
-- Now put the payloads and use the reserved space
-- to point to the start of each payload:
forM_ header_entries $ \(field_p_p, dat) -> do
- field_p <- tellBin bh
+ field_p <- tellBinWriter bh
putAt bh field_p_p field_p
- seekBin bh field_p
+ seekBinWriter bh field_p
put_ bh dat
get bh = do
@@ -54,7 +54,7 @@ instance Binary ExtensibleFields where
-- Seek to and get each field's payload:
fields <- forM header_entries $ \(name, field_p) -> do
- seekBin bh field_p
+ seekBinNoExpandReader bh field_p
dat <- get bh
return (name, dat)
@@ -72,7 +72,7 @@ emptyExtensibleFields = ExtensibleFields Map.empty
readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField name = readFieldWith name get
-readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
Map.lookup name (getExtensibleFields fields)
@@ -82,7 +82,7 @@ readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField name x = writeFieldWith name (`put_` x)
-writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith name write fields = do
bh <- openBinMem (1024 * 1024)
write bh
=====================================
compiler/GHC/Iface/Recomp/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 =
@@ -37,7 +37,7 @@ computeFingerprint a = do
-- | 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
=====================================
@@ -119,10 +119,10 @@ 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 findUserDataWriter Proxy bh of
tbl ->
@@ -2445,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
=====================================
@@ -89,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 Data.Proxy
+import Control.Monad ((<$!>))
+import qualified Data.Semigroup as Semi
+import Data.Maybe( isJust )
{-
************************************************************************
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -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
@@ -322,7 +322,7 @@ putObject bh mod_name deps os = do
-- 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
@@ -330,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
@@ -345,7 +345,7 @@ 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)
@@ -353,7 +353,7 @@ getObjectBody bh0 mod_name = do
block_info <- get bh
idx <- forwardGet bh (get bh)
- payload_pos <- tellBin bh
+ payload_pos <- tellBinReader bh
pure $ Object
{ objModuleName = mod_name
@@ -364,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
@@ -393,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
@@ -409,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
@@ -779,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/Utils/Binary.hs
=====================================
@@ -22,7 +22,7 @@
module GHC.Utils.Binary
( {-type-} Bin,
{-class-} Binary(..),
- {-type-} BinHandle,
+ {-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
@@ -31,8 +31,10 @@ module GHC.Utils.Binary
openBinMem,
-- closeBin,
- seekBin,
- tellBin,
+ seekBinWriter,
+ seekBinNoExpandReader,
+ tellBinReader,
+ tellBinWriter,
castBin,
withBinBuffer,
@@ -87,7 +89,23 @@ module GHC.Utils.Binary
initFastStringReaderTable, initFastStringWriterTable,
putDictionary, getDictionary, putFS,
FSTable(..), getDictFastString, putDictFastString,
-
+<<<<<<< HEAD
+ -- * Generic Symbol that can be used for user-defined deduplication tables.
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ putGenericSymbolTable, getGenericSymbolTable,
+ putGenericSymTab, getGenericSymtab,
+||||||| parent of f3fd018a62 (Fixup: Generic Symbol Table)
+
+=======
+
+ -- * Generic Symbol that can be used for user-defined deduplication tables.
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ putGenericSymbolTable, getGenericSymbolTable,
+ putGenericSymTab, getGenericSymtab,
+
+>>>>>>> f3fd018a62 (Fixup: Generic Symbol Table)
-- * Newtype wrappers
BinSpan(..), BinSrcSpan(..), BinLocated(..)
) where
@@ -171,70 +189,83 @@ instance Binary BinData where
copyBytes dest orig sz
return (BinData sz dat)
-dataHandle :: BinData -> IO BinHandle
+dataHandle :: BinData -> IO ReadBinHandle
dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
- szr <- newFastMutInt size
- binr <- newIORef bin
- return (BinMem noReaderUserData noWriterUserData 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_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))
+-- | 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))
+ }
+
+-- | 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))
}
- -- XXX: should really store a "high water mark" for dumping out
- -- the binary data to a file.
-getReaderUserData :: BinHandle -> ReaderUserData
-getReaderUserData bh = bh_reader bh
+getReaderUserData :: ReadBinHandle -> ReaderUserData
+getReaderUserData bh = rbm_userData bh
-getWriterUserData :: BinHandle -> WriterUserData
-getWriterUserData bh = bh_writer bh
+getWriterUserData :: WriteBinHandle -> WriterUserData
+getWriterUserData bh = wbm_userData bh
-setWriterUserData :: BinHandle -> WriterUserData -> BinHandle
-setWriterUserData bh us = bh { bh_writer = us }
+setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
+setWriterUserData bh us = bh { wbm_userData = us }
-setReaderUserData :: BinHandle -> ReaderUserData -> BinHandle
-setReaderUserData bh us = bh { bh_reader = us }
+setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
+setReaderUserData bh us = bh { rbm_userData = us }
-addReaderToUserData :: SomeBinaryReader -> BinHandle -> BinHandle
+-- | 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
- { bh_reader = (bh_reader bh)
- { ud_reader_data = Map.insert typRep cache (ud_reader_data (bh_reader bh))
+ { rbm_userData = (rbm_userData bh)
+ { ud_reader_data = Map.insert typRep cache (ud_reader_data (rbm_userData bh))
}
}
-addWriterToUserData :: SomeBinaryWriter -> BinHandle -> BinHandle
+-- | 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
- { bh_writer = (bh_writer bh)
- { ud_writer_data = Map.insert typRep cache (ud_writer_data (bh_writer 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 noReaderUserData noWriterUserData ix_r sz_r arr_r)
+ return (ReadBinMem noReaderUserData ix_r len arr)
---------------------------------------------------------------
-- Bin
@@ -253,23 +284,23 @@ castBin (BinPtr i) = BinPtr i
-- | Do not rely on instance sizes for general types,
-- we use variable length encoding for many of them.
class Binary a where
- put_ :: BinHandle -> a -> IO ()
- put :: BinHandle -> a -> IO (Bin a)
- get :: BinHandle -> IO a
+ put_ :: WriteBinHandle -> a -> IO ()
+ put :: WriteBinHandle -> a -> IO (Bin a)
+ get :: ReadBinHandle -> IO a
-- define one of put_, put. Use of put_ is recommended because it
-- is more likely that tail-calls can kick in, and we rarely need the
-- position return value.
put_ bh a = do _ <- put bh a; return ()
- put bh a = do p <- tellBin bh; put_ bh a; return p
+ put bh a = do p <- tellBinWriter bh; put_ bh a; return p
-putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
-putAt bh p x = do seekBin bh p; put_ bh x; return ()
+putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()
-getAt :: Binary a => BinHandle -> Bin a -> IO a
-getAt bh p = do seekBin bh p; get bh
+getAt :: Binary a => ReadBinHandle -> Bin a -> IO a
+getAt bh p = do seekBinNoExpandReader bh p; get bh
-openBinMem :: Int -> IO BinHandle
+openBinMem :: Int -> IO WriteBinHandle
openBinMem size
| size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"
| otherwise = do
@@ -277,42 +308,57 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noReaderUserData noWriterUserData 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
+ }
-tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinMem _ _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBinWriter :: WriteBinHandle -> IO (Bin a)
+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-seekBin :: BinHandle -> Bin a -> IO ()
-seekBin h@(BinMem _ _ ix_r sz_r _) (BinPtr !p) = do
+tellBinReader :: ReadBinHandle -> IO (Bin a)
+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+
+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
@@ -321,20 +367,23 @@ readBinMemN size filename = do
then pure Nothing
else Just <$> readBinMem_ size h
-readBinMem_ :: Int -> Handle -> IO BinHandle
+readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ filesize h = do
arr <- mallocForeignPtrBytes filesize
count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt filesize
- return (BinMem noReaderUserData noWriterUserData 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
@@ -355,7 +404,7 @@ expandBin (BinMem _ _ _ sz_r arr_r) !off = do
foldGet
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -371,7 +420,7 @@ foldGet n bh init_b f = go 0 init_b
foldGet'
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -392,8 +441,8 @@ foldGet' n bh init_b f = go 0 init_b
-- | Takes a size and action writing up to @size@ bytes.
-- After the action has run advance the index to the buffer
-- by size bytes.
-putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
-putPrim h@(BinMem _ _ ix_r sz_r arr_r) size f = do
+putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
+putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix + size > sz) $
@@ -414,39 +463,37 @@ putPrim h@(BinMem _ _ ix_r sz_r arr_r) size f = do
-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
-- writeFastMutInt ix_r (ix + written)
-getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
-getPrim (BinMem _ _ ix_r sz_r arr_r) size f = do
+getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
+getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
- when (ix + size > sz) $
+ when (ix + size > sz_r) $
ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
- arr <- readIORef arr_r
- w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)
+ w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)
-- This is safe WRT #17760 as we we guarantee that the above line doesn't
-- diverge
writeFastMutInt ix_r (ix + size)
return w
-putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 :: WriteBinHandle -> Word8 -> IO ()
putWord8 h !w = putPrim h 1 (\op -> poke op w)
-getWord8 :: BinHandle -> IO Word8
+getWord8 :: ReadBinHandle -> IO Word8
getWord8 h = getPrim h 1 peek
-putWord16 :: BinHandle -> Word16 -> IO ()
+putWord16 :: WriteBinHandle -> Word16 -> IO ()
putWord16 h w = putPrim h 2 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
)
-getWord16 :: BinHandle -> IO Word16
+getWord16 :: ReadBinHandle -> IO Word16
getWord16 h = getPrim h 2 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
return $! w0 `shiftL` 8 .|. w1
)
-putWord32 :: BinHandle -> Word32 -> IO ()
+putWord32 :: WriteBinHandle -> Word32 -> IO ()
putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
@@ -454,7 +501,7 @@ putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
)
-getWord32 :: BinHandle -> IO Word32
+getWord32 :: ReadBinHandle -> IO Word32
getWord32 h = getPrim h 4 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -467,7 +514,7 @@ getWord32 h = getPrim h 4 (\op -> do
w3
)
-putWord64 :: BinHandle -> Word64 -> IO ()
+putWord64 :: WriteBinHandle -> Word64 -> IO ()
putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
@@ -479,7 +526,7 @@ putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
)
-getWord64 :: BinHandle -> IO Word64
+getWord64 :: ReadBinHandle -> IO Word64
getWord64 h = getPrim h 8 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -500,10 +547,10 @@ getWord64 h = getPrim h 8 (\op -> do
w7
)
-putByte :: BinHandle -> Word8 -> IO ()
+putByte :: WriteBinHandle -> Word8 -> IO ()
putByte bh !w = putWord8 bh w
-getByte :: BinHandle -> IO Word8
+getByte :: ReadBinHandle -> IO Word8
getByte h = getWord8 h
-- -----------------------------------------------------------------------------
@@ -526,15 +573,15 @@ getByte h = getWord8 h
-- for now.
-- Unsigned numbers
-{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}
-putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()
putULEB128 bh w =
#if defined(DEBUG)
(if w < 0 then panic "putULEB128: Signed number" else id) $
@@ -551,15 +598,15 @@ putULEB128 bh w =
putByte bh byte
go (w `unsafeShiftR` 7)
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}
-getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-}
+getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a
getULEB128 bh =
go 0 0
where
@@ -575,15 +622,15 @@ getULEB128 bh =
return $! val
-- Signed numbers
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}
-putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
go :: a -> IO ()
@@ -603,15 +650,15 @@ putSLEB128 bh initial = go initial
unless done $ go val'
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}
-getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}
+getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a
getSLEB128 bh = do
(val,shift,signed) <- go 0 0
if signed && (shift < finiteBitSize val )
@@ -1022,63 +1069,63 @@ instance Binary (Bin a) where
-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B
-- by using a forward reference
-forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)
+forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut bh put_A put_B = do
-- write placeholder pointer to A
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a
-- write B
r_b <- put_B
-- update A's pointer
- a <- tellBin bh
+ a <- tellBinWriter bh
putAt bh pre_a a
- seekBinNoExpand bh a
+ seekBinNoExpandWriter bh a
-- write A
r_a <- put_A r_b
pure (r_a,r_b)
-forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()
+forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B
-- | Read a value stored using a forward reference
-forwardGet :: BinHandle -> IO a -> IO a
+forwardGet :: ReadBinHandle -> IO a -> IO a
forwardGet bh get_A = do
-- read forward reference
p <- get bh -- a BinPtr
-- store current position
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
-- go read the forward value, then seek back
- seekBinNoExpand bh p
+ seekBinNoExpandReader bh p
r <- get_A
- seekBinNoExpand bh p_a
+ seekBinNoExpandReader bh p_a
pure r
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
-lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut :: Binary a => WriteBinHandle -> a -> IO ()
lazyPut bh a = do
-- output the obj with a ptr to skip over it:
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a -- save a slot for the ptr
put_ bh a -- dump the object
- q <- tellBin bh -- q = ptr to after object
+ q <- tellBinWriter bh -- q = ptr to after object
putAt bh pre_a q -- fill in slot before a with ptr to q
- seekBin bh q -- finally carry on writing at q
+ seekBinWriter bh q -- finally carry on writing at q
-lazyGet :: Binary a => BinHandle -> IO a
+lazyGet :: Binary a => ReadBinHandle -> IO a
lazyGet bh = do
p <- get bh -- a BinPtr
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
a <- unsafeInterleaveIO $ do
-- NB: Use a fresh off_r variable in the child thread, for thread
-- safety.
off_r <- newFastMutInt 0
- getAt bh { _off_r = off_r } p_a
- seekBin bh p -- skip over the object for now
+ getAt bh { rbm_off_r = off_r } p_a
+ seekBinNoExpandReader bh p -- skip over the object for now
return a
-- | Serialize the constructor strictly but lazily serialize a value inside a
@@ -1086,14 +1133,14 @@ lazyGet bh = do
--
-- This way we can check for the presence of a value without deserializing the
-- value itself.
-lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO ()
+lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()
lazyPutMaybe bh Nothing = putWord8 bh 0
lazyPutMaybe bh (Just x) = do
putWord8 bh 1
lazyPut bh x
-- | Deserialize a value serialized by 'lazyPutMaybe'.
-lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)
+lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)
lazyGetMaybe bh = do
h <- getWord8 bh
case h of
@@ -1183,31 +1230,31 @@ mkSomeBinaryReader :: forall a . Typeable a => BinaryReader a -> SomeBinaryReade
mkSomeBinaryReader cb = SomeBinaryReader (typeRep (Proxy :: Proxy a)) cb
data BinaryReader s = BinaryReader
- { getEntry :: BinHandle -> IO s
+ { getEntry :: ReadBinHandle -> IO s
}
data BinaryWriter s = BinaryWriter
- { putEntry :: BinHandle -> s -> IO ()
+ { putEntry :: WriteBinHandle -> s -> IO ()
}
-mkWriter :: (BinHandle -> s -> IO ()) -> BinaryWriter s
+mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter f = BinaryWriter
{ putEntry = f
}
-mkReader :: (BinHandle -> IO s) -> BinaryReader s
+mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s
mkReader f = BinaryReader
{ getEntry = f
}
-findUserDataReader :: forall a . Typeable a => Proxy a -> BinHandle -> BinaryReader a
+findUserDataReader :: forall a . Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
findUserDataReader query bh =
case Map.lookup (typeRep query) (ud_reader_data $ getReaderUserData bh) of
Nothing -> panic $ "Failed to find BinaryReader for key " ++ show (typeRep query)
Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader
-findUserDataWriter :: forall a . Typeable a => Proxy a -> BinHandle -> BinaryWriter a
+findUserDataWriter :: forall a . Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
findUserDataWriter query bh =
case Map.lookup (typeRep query) (ud_writer_data $ getWriterUserData bh) of
Nothing -> panic $ "Failed to find BinaryWriter for key " ++ show (typeRep query)
@@ -1224,8 +1271,8 @@ noWriterUserData = WriterUserData
{ ud_writer_data = Map.empty
}
-newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
- -> (BinHandle -> IO FastString)
+newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's
+ -> (ReadBinHandle -> IO FastString)
-> ReaderUserData
newReadState get_name get_fs =
mkReaderUserData
@@ -1233,9 +1280,9 @@ newReadState get_name get_fs =
, mkSomeBinaryReader $ mkReader get_fs
]
-newWriteState :: (BinHandle -> Name -> IO ())
+newWriteState :: (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize binding 'Name's
- -> (BinHandle -> FastString -> IO ())
+ -> (WriteBinHandle -> FastString -> IO ())
-> WriterUserData
newWriteState put_binding_name put_fs =
mkWriterUserData
@@ -1254,14 +1301,80 @@ data SomeWriterTable f = forall a . Typeable a =>
SomeWriterTable (f (WriterTable, BinaryWriter a))
data ReaderTable a = ReaderTable
- { getTable :: BinHandle -> IO (SymbolTable a)
+ { getTable :: ReadBinHandle -> IO (SymbolTable a)
, mkReaderFromTable :: SymbolTable a -> BinaryReader a
}
data WriterTable = WriterTable
- { putTable :: BinHandle -> IO Int
+ { putTable :: WriteBinHandle -> IO Int
+ }
+
+-- ----------------------------------------------------------------------------
+-- Common data structures for constructing and maintaining lookup tables for
+-- binary serialisation and deserialisation.
+-- ----------------------------------------------------------------------------
+
+data GenericSymbolTable a = GenericSymbolTable
+ { gen_symtab_next :: !FastMutInt
+ -- ^ The next index to use
+ , gen_symtab_map :: !(IORef (Map.Map a Int))
+ -- ^ Given a symbol, find the symbol
}
+initGenericSymbolTable :: IO (GenericSymbolTable a)
+initGenericSymbolTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef Map.empty
+ pure $ GenericSymbolTable
+ { gen_symtab_next = symtab_next
+ , gen_symtab_map = symtab_map
+ }
+
+putGenericSymbolTable :: forall a. GenericSymbolTable a -> (BinHandle -> a -> IO ()) -> BinHandle -> IO Int
+putGenericSymbolTable gen_sym_tab serialiser bh = do
+ table_count <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putGenericSymbolTable bh table_count symtab_map
+ pure table_count
+ where
+ symtab_map = gen_symtab_map gen_sym_tab
+ symtab_next = gen_symtab_next gen_sym_tab
+ putGenericSymbolTable :: BinHandle -> Int -> Map.Map a Int -> IO ()
+ putGenericSymbolTable bh name_count symtab = do
+ put_ bh name_count
+ let genElements = elems (array (0,name_count-1) (fmap swap $ Map.toList symtab))
+ mapM_ (\n -> serialiser bh n) genElements
+
+getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> BinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bh = do
+ sz <- get bh :: IO Int
+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
+ forM_ [0..(sz-1)] $ \i -> do
+ f <- deserialiser bh
+ writeArray mut_arr i f
+ unsafeFreeze mut_arr
+
+putGenericSymTab :: (Ord a, Binary a) => GenericSymbolTable a -> BinHandle -> a -> IO ()
+putGenericSymTab GenericSymbolTable{
+ gen_symtab_map = symtab_map_ref,
+ gen_symtab_next = symtab_next }
+ bh val = do
+ symtab_map <- readIORef symtab_map_ref
+ case Map.lookup val symtab_map of
+ Just off -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! Map.insert val off symtab_map
+ put_ bh (fromIntegral off :: Word32)
+
+getGenericSymtab :: Binary a => SymbolTable a
+ -> BinHandle -> IO a
+getGenericSymtab symtab bh = do
+ i :: Word32 <- get bh
+ return $! symtab ! fromIntegral i
+
---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------
@@ -1299,14 +1412,14 @@ initFastStringWriterTable = do
, mkWriter $ putDictFastString bin_dict
)
-putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
+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)
@@ -1315,12 +1428,12 @@ getDictionary bh = do
writeArray mut_arr i fs
unsafeFreeze mut_arr
-getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
-putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
+putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: FSTable -> FastString -> IO Word32
@@ -1357,34 +1470,34 @@ 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
=====================================
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 d559cde5afeb9323861428a7317a59be055b9e13
+Subproject commit 799390d1c6d59a606c3dd00dea057baa26ed0c2f
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c19bd36e0124194f641ef74a11aee0736125fa7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c19bd36e0124194f641ef74a11aee0736125fa7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240402/50da2511/attachment-0001.html>
More information about the ghc-commits
mailing list