[Git][ghc/ghc][wip/fendor/ghc-iface-refact] 8 commits: Add performance regression test for '-fwrite-simplified-core'
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Wed Apr 24 07:49:10 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ghc-iface-refact at Glasgow Haskell Compiler / GHC
Commits:
593f4e04 by Fendor at 2024-04-23T10:19:14-04:00
Add performance regression test for '-fwrite-simplified-core'
- - - - -
1ba39b05 by Fendor at 2024-04-23T10:19:14-04:00
Typecheck corebindings lazily during bytecode generation
This delays typechecking the corebindings until the bytecode generation
happens.
We also avoid allocating a thunk that is retained by `unsafeInterleaveIO`.
In general, we shouldn't retain values of the hydrated `Type`, as not evaluating
the bytecode object keeps it alive.
It is better if we retain the unhydrated `IfaceType`.
See Note [Hydrating Modules]
- - - - -
e916fc92 by Alan Zimmerman at 2024-04-23T10:19:50-04:00
EPA: Keep comments in a CaseAlt match
The comments now live in the surrounding location, not inside the
Match. Make sure we keep them.
Closes #24707
- - - - -
d2b17f32 by Cheng Shao at 2024-04-23T15:01:22-04:00
driver: force merge objects when building dynamic objects
This patch forces the driver to always merge objects when building
dynamic objects even when ar -L is supported. It is an oversight of
!8887: original rationale of that patch is favoring the relatively
cheap ar -L operation over object merging when ar -L is supported,
which makes sense but only if we are building static objects! Omitting
check for whether we are building dynamic objects will result in
broken .so files with undefined reference errors at executable link
time when building GHC with llvm-ar. Fixes #22210.
- - - - -
209d09f5 by Julian Ospald at 2024-04-23T15:02:03-04:00
Allow non-absolute values for bootstrap GHC variable
Fixes #24682
- - - - -
3fff0977 by Matthew Pickering at 2024-04-23T15:02:38-04:00
Don't depend on registerPackage function in Cabal
More recent versions of Cabal modify the behaviour of libAbiHash which
breaks our usage of registerPackage.
It is simpler to inline the part of registerPackage that we need and
avoid any additional dependency and complication using the higher-level
function introduces.
- - - - -
d636f6a2 by Fendor at 2024-04-24T09:47:56+02:00
Refactor the Binary serialisation interface
The goal is simplifiy adding deduplication tables to `ModIface`
interface serialisation.
We identify two main points of interest that make this difficult:
1. UserData hardcodes what `Binary` instances can have deduplication
tables. Moreover, it heavily uses partial functions.
2. GHC.Iface.Binary hardcodes the deduplication tables for 'Name' and
'FastString', making it difficult to add more deduplication.
Instead of having a single `UserData` record with fields for all the
types that can have deduplication tables, we allow to provide custom
serialisers for any `Typeable`.
These are wrapped in existentials and stored in a `Map` indexed by their
respective `TypeRep`.
The `Binary` instance of the type to deduplicate still needs to
explicitly look up the decoder via `findUserDataReader` and
`findUserDataWriter`, which is no worse than the status-quo.
`Map` was chosen as microbenchmarks indicate it is the fastest for a
small number of keys (< 10).
To generalise the deduplication table serialisation mechanism, we
introduce the types `ReaderTable` and `WriterTable` which provide a
simple interface that is sufficient to implement a general purpose
deduplication mechanism for `writeBinIface` and `readBinIface`.
This allows us to provide a list of deduplication tables for
serialisation that can be extended more easily, for example for
`IfaceTyCon`, see the issue https://gitlab.haskell.org/ghc/ghc/-/issues/24540
for more motivation.
In addition to this refactoring, we split `UserData` into `ReaderUserData`
and `WriterUserData`, to avoid partial functions and reduce overall
memory usage, as we need fewer mutable variables.
Bump haddock submodule to accomodate for `UserData` split.
-------------------------
Metric Increase:
MultiLayerModulesTH_Make
MultiLayerModulesRecomp
T21839c
-------------------------
- - - - -
be6836a2 by Fendor at 2024-04-24T09:47: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.
- - - - -
27 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Binary.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
- configure.ac
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithCore.script
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/perf/compiler/genMultiLayerModulesCore
- + testsuite/tests/printer/CaseAltComments.hs
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -990,16 +990,16 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM
types_var <- newIORef (md_types details)
let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
- core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
- -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
- -- reports a bug.
- let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
-- The bytecode generation itself is lazy because otherwise even when doing
-- recompilation checking the bytecode will be generated (which slows things down a lot)
-- the laziness is OK because generateByteCode just depends on things already loaded
-- in the interface file.
LoadedBCOs <$> (unsafeInterleaveIO $ do
+ core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
+ -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
+ -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
+ -- reports a bug.
+ let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
go ul = return ul
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1040,13 +1040,22 @@ this is accomplished with the `ld -r` command. We rely on this for two ends:
The command used for object linking is set using the -pgmlm and -optlm
command-line options.
-Sadly, the LLD linker that we use on Windows does not support the `-r` flag
-needed to support object merging (see #21068). For this reason on Windows we do
-not support GHCi objects. To deal with foreign stubs we build a static archive
-of all of a module's object files instead merging them. Consequently, we can
-end up producing `.o` files which are in fact static archives. However,
-toolchains generally don't have a problem with this as they use file headers,
-not the filename, to determine the nature of inputs.
+However, `ld -r` is broken in some cases:
+
+ * The LLD linker that we use on Windows does not support the `-r`
+ flag needed to support object merging (see #21068). For this reason
+ on Windows we do not support GHCi objects.
+ * `wasm-ld -r` is prohibitively slow, especially when handling large
+ input objects (e.g. profiled objects).
+
+In these cases, we bundle a module's own object file with its foreign
+stub's object file, instead of merging them. Consequently, we can end
+up producing `.o` files which are in fact static archives. This can
+only work if `ar -L` is supported, so the archive `.o` files can be
+properly added to the final static library. We must also take care not
+to produce archive `.dyn_o` when building dynamic objects, otherwise
+we end up with broken `.so` files when GHC is built with `llvm-ar`
+(#22210).
Note that this has somewhat non-obvious consequences when producing
initializers and finalizers. See Note [Initializers and finalizers in Cmm]
@@ -1072,7 +1081,7 @@ via gcc.
-- | See Note [Object merging].
joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
joinObjectFiles hsc_env o_files output_fn
- | can_merge_objs && not dashLSupported = do
+ | can_merge_objs && (not dashLSupported || is_dyn) = do
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
@@ -1100,6 +1109,7 @@ joinObjectFiles hsc_env o_files output_fn
withAtomicRename output_fn $ \tmp_ar ->
liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files
where
+ is_dyn = ways dflags `hasWay` WayDyn
dashLSupported = sArSupportsDashL (settings dflags)
dashL = if dashLSupported then "L" else ""
can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env))
=====================================
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
@@ -75,7 +75,7 @@ readBinIfaceHeader
-> CheckHiWay
-> TraceBinIFace
-> FilePath
- -> IO (Fingerprint, BinHandle)
+ -> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
let platform = profilePlatform profile
@@ -121,6 +121,8 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
pure (src_hash, bh)
-- | Read an interface file.
+--
+-- See Note [Deduplication during iface binary serialisation] for details.
readBinIface
:: Profile
-> NameCache
@@ -135,7 +137,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
mod_iface <- getWithUserData name_cache bh
- seekBin bh extFields_p
+ seekBinReader bh extFields_p
extFields <- get bh
return mod_iface
@@ -146,7 +148,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
+getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a
getWithUserData name_cache bh = do
bh <- getTables name_cache bh
get bh
@@ -154,24 +156,30 @@ getWithUserData name_cache bh = do
-- | Setup a BinHandle to read something written using putWithTables
--
-- Reading names has the side effect of adding them into the given NameCache.
-getTables :: NameCache -> BinHandle -> IO BinHandle
+getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables name_cache bh = do
- -- Read the dictionary
- -- The next word in the file is a pointer to where the dictionary is
- -- (probably at the end of the file)
- dict <- Binary.forwardGet bh (getDictionary bh)
+ 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
@@ -184,14 +192,14 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
put_ bh tag
put_ bh (mi_src_hash mod_iface)
- extFields_p_p <- tellBin bh
+ extFields_p_p <- tellBinWriter bh
put_ bh extFields_p_p
putWithUserData traceBinIface bh mod_iface
- extFields_p <- tellBin bh
+ extFields_p <- tellBinWriter bh
putAt bh extFields_p_p extFields_p
- seekBin bh extFields_p
+ seekBinWriter bh extFields_p
put_ bh (mi_ext_fields mod_iface)
-- And send the result to the file
@@ -201,7 +209,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
+putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
(name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
@@ -225,59 +233,263 @@ 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 :: WriteBinHandle -> (WriteBinHandle -> 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
--
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
+
+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 :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh name_count symtab = do
put_ bh name_count
let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
@@ -286,7 +498,7 @@ putSymbolTable bh name_count symtab = do
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable bh name_cache = do
sz <- get bh :: IO Int
-- create an array of Names for the symbols and add them to the NameCache
@@ -307,7 +519,7 @@ getSymbolTable bh name_cache = do
arr <- unsafeFreeze mut_arr
return (cache, arr)
-serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
+serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -331,8 +543,8 @@ serialiseName bh name _ = do
-- See Note [Symbol table representation of names]
-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
-putName _dict BinSymbolTable{
+putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
+putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
@@ -356,10 +568,9 @@ putName _dict BinSymbolTable{
put_ bh (fromIntegral off :: Word32)
-- See Note [Symbol table representation of names]
-getSymtabName :: NameCache
- -> Dictionary -> SymbolTable
- -> BinHandle -> IO Name
-getSymtabName _name_cache _dict symtab bh = do
+getSymtabName :: SymbolTable Name
+ -> ReadBinHandle -> IO Name
+getSymtabName symtab bh = do
i :: Word32 <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral i
@@ -376,10 +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
- }
-
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -67,7 +67,7 @@ hieMagicLen = length hieMagic
ghcVersion :: ByteString
ghcVersion = BSC.pack cProjectVersion
-putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine :: WriteBinHandle -> ByteString -> IO ()
putBinLine bh xs = do
mapM_ (putByte bh) $ BS.unpack xs
putByte bh 10 -- newline char
@@ -85,11 +85,11 @@ writeHieFile hie_file_path hiefile = do
putBinLine bh0 $ ghcVersion
-- remember where the dictionary pointer will go
- dict_p_p <- tellBin bh0
+ dict_p_p <- tellBinWriter bh0
put_ bh0 dict_p_p
-- remember where the symbol table pointer will go
- symtab_p_p <- tellBin bh0
+ symtab_p_p <- tellBinWriter bh0
put_ bh0 symtab_p_p
-- Make some initial state
@@ -105,15 +105,16 @@ writeHieFile hie_file_path hiefile = do
hie_dict_map = dict_map_ref }
-- put the main thing
- let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
- (putName hie_symtab)
- (putFastString hie_dict)
+ let bh = setWriterUserData bh0
+ $ newWriteState (putName hie_symtab)
+ (putName hie_symtab)
+ (putFastString hie_dict)
put_ bh hiefile
-- write the symtab pointer at the front of the file
- symtab_p <- tellBin bh
+ symtab_p <- tellBinWriter bh
putAt bh symtab_p_p symtab_p
- seekBin bh symtab_p
+ seekBinWriter bh symtab_p
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
@@ -121,9 +122,9 @@ writeHieFile hie_file_path hiefile = do
putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the front of the file
- dict_p <- tellBin bh
+ dict_p <- tellBinWriter bh
putAt bh dict_p_p dict_p
- seekBin bh dict_p
+ seekBinWriter bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt dict_next_ref
@@ -181,7 +182,7 @@ readHieFile name_cache file = do
hieFile <- readHieFileContents bh0 name_cache
return $ HieFileResult hieVersion ghcVersion hieFile
-readBinLine :: BinHandle -> IO ByteString
+readBinLine :: ReadBinHandle -> IO ByteString
readBinLine bh = BS.pack . reverse <$> loop []
where
loop acc = do
@@ -190,7 +191,7 @@ readBinLine bh = BS.pack . reverse <$> loop []
then return acc
else loop (char : acc)
-readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader
readHieFileHeader file bh0 = do
-- Read the header
magic <- replicateM hieMagicLen (get bh0)
@@ -213,15 +214,16 @@ readHieFileHeader file bh0 = do
]
return (readHieVersion, ghcVersion)
-readHieFileContents :: BinHandle -> NameCache -> IO HieFile
+readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile
readHieFileContents bh0 name_cache = do
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
bh1 <- do
- let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
- (getDictFastString dict)
+ let bh1 = setReaderUserData bh0
+ $ newReadState (error "getSymtabName")
+ (getDictFastString dict)
symtab <- get_symbol_table bh1
- let bh1' = setUserData bh1
+ let bh1' = setReaderUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return bh1'
@@ -231,21 +233,21 @@ readHieFileContents bh0 name_cache = do
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
- data_p <- tellBin bin_handle
- seekBin bin_handle dict_p
+ data_p <- tellBinReader bin_handle
+ seekBinReader bin_handle dict_p
dict <- getDictionary bin_handle
- seekBin bin_handle data_p
+ seekBinReader 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
+ seekBinReader bh1 symtab_p
symtab <- getSymbolTable bh1 name_cache
- seekBin bh1 data_p'
+ seekBinReader bh1 data_p'
return symtab
-putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
@@ -259,13 +261,13 @@ putFastString HieDictionary { hie_dict_next = j_r,
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out unique (j, f)
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable bh name_cache = do
sz <- get bh
mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
@@ -275,12 +277,12 @@ getSymbolTable bh name_cache = do
A.writeArray mut_arr i name
A.unsafeFreeze mut_arr
-getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name
getSymTabName st bh = do
i :: Word32 <- get bh
return $ st A.! (fromIntegral i)
-putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName :: HieSymbolTable -> WriteBinHandle -> Name -> IO ()
putName (HieSymbolTable next ref) bh name = do
symmap <- readIORef ref
case lookupUFM symmap name of
@@ -333,7 +335,7 @@ fromHieName nc hie_name = do
-- ** Reading and writing `HieName`'s
-putHieName :: BinHandle -> HieName -> IO ()
+putHieName :: WriteBinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
put_ bh (mod, occ, BinSrcSpan span)
@@ -344,7 +346,7 @@ putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
-getHieName :: BinHandle -> IO HieName
+getHieName :: ReadBinHandle -> IO HieName
getHieName bh = do
t <- getByte bh
case t of
=====================================
compiler/GHC/Iface/Ext/Fields.hs
=====================================
@@ -33,16 +33,16 @@ instance Binary ExtensibleFields where
-- for a payload pointer after each name:
header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
put_ bh name
- field_p_p <- tellBin bh
+ field_p_p <- tellBinWriter bh
put_ bh field_p_p
return (field_p_p, dat)
-- Now put the payloads and use the reserved space
-- to point to the start of each payload:
forM_ header_entries $ \(field_p_p, dat) -> do
- field_p <- tellBin bh
+ field_p <- tellBinWriter bh
putAt bh field_p_p field_p
- seekBin bh field_p
+ seekBinWriter bh field_p
put_ bh dat
get bh = do
@@ -54,7 +54,7 @@ instance Binary ExtensibleFields where
-- Seek to and get each field's payload:
fields <- forM header_entries $ \(name, field_p) -> do
- seekBin bh field_p
+ seekBinReader bh field_p
dat <- get bh
return (name, dat)
@@ -72,7 +72,7 @@ emptyExtensibleFields = ExtensibleFields Map.empty
readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField name = readFieldWith name get
-readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
Map.lookup name (getExtensibleFields fields)
@@ -82,7 +82,7 @@ readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField name x = writeFieldWith name (`put_` x)
-writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith name write fields = do
bh <- openBinMem (1024 * 1024)
write bh
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1032,7 +1032,7 @@ addFingerprints hsc_env iface0
-- change if the fingerprint for anything it refers to (transitively)
-- changes.
mk_put_name :: OccEnv (OccName,Fingerprint)
- -> BinHandle -> Name -> IO ()
+ -> WriteBinHandle -> Name -> IO ()
mk_put_name local_env bh name
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
=====================================
compiler/GHC/Iface/Recomp/Binary.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
-fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
where
f bs =
@@ -26,7 +26,7 @@ fingerprintBinMem bh = withBinBuffer bh f
in fp `seq` return fp
computeFingerprint :: (Binary a)
- => (BinHandle -> Name -> IO ())
+ => (WriteBinHandle -> Name -> IO ())
-> a
-> IO Fingerprint
computeFingerprint put_nonbinding_name a = do
@@ -35,11 +35,11 @@ computeFingerprint put_nonbinding_name a = do
fingerprintBinMem bh
where
set_user_data bh =
- setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+ setWriterUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
-putNameLiterally :: BinHandle -> Name -> IO ()
+putNameLiterally :: WriteBinHandle -> Name -> IO ()
putNameLiterally bh name = assert (isExternalName name) $ do
put_ bh $! nameModule name
put_ bh $! nameOccName name
=====================================
compiler/GHC/Iface/Recomp/Flags.hs
=====================================
@@ -31,7 +31,7 @@ import System.FilePath (normalise)
-- NB: The 'Module' parameter is the 'Module' recorded by the *interface*
-- file, not the actual 'Module' according to our 'DynFlags'.
fingerprintDynFlags :: HscEnv -> Module
- -> (BinHandle -> Name -> IO ())
+ -> (WriteBinHandle -> Name -> IO ())
-> IO Fingerprint
fingerprintDynFlags hsc_env this_mod nameio =
@@ -88,7 +88,7 @@ fingerprintDynFlags hsc_env this_mod nameio =
-- object files as they can.
-- See Note [Ignoring some flag changes]
fingerprintOptFlags :: DynFlags
- -> (BinHandle -> Name -> IO ())
+ -> (WriteBinHandle -> Name -> IO ())
-> IO Fingerprint
fingerprintOptFlags DynFlags{..} nameio =
let
@@ -106,7 +106,7 @@ fingerprintOptFlags DynFlags{..} nameio =
-- file compiled for HPC when not actually using HPC.
-- See Note [Ignoring some flag changes]
fingerprintHpcFlags :: DynFlags
- -> (BinHandle -> Name -> IO ())
+ -> (WriteBinHandle -> Name -> IO ())
-> IO Fingerprint
fingerprintHpcFlags dflags at DynFlags{..} nameio =
let
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -94,6 +94,7 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
+import Data.Proxy
infixl 3 &&&
@@ -118,15 +119,15 @@ type IfaceTopBndr = Name
-- We don't serialise the namespace onto the disk though; rather we
-- drop it when serialising and add it back in when deserialising.
-getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr
+getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr
getIfaceTopBndr bh = get bh
-putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
+putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO ()
putIfaceTopBndr bh name =
- case getUserData bh of
- UserData{ ud_put_binding_name = put_binding_name } ->
+ case findUserDataWriter (Proxy @BindingName) bh of
+ tbl ->
--pprTrace "putIfaceTopBndr" (ppr name) $
- put_binding_name bh name
+ putEntry tbl bh (BindingName name)
data IfaceDecl
@@ -2444,13 +2445,13 @@ instance Binary IfGuidance where
c <- get bh
return (IfWhen a b c)
-putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()
+putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO ()
putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
, uf_is_work_free = wf, uf_expandable = exp }) = do
let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp
putByte bh b
-getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache
+getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache
getUnfoldingCache bh = do
b <- getByte bh
let hnf = testBit b 3
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -9,7 +9,6 @@ This module defines interface types and binders
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
-
module GHC.Iface.Type (
IfExtName, IfLclName,
@@ -90,10 +89,10 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
-import Data.Maybe( isJust )
-import qualified Data.Semigroup as Semi
import Control.DeepSeq
import Control.Monad ((<$!>))
+import qualified Data.Semigroup as Semi
+import Data.Maybe( isJust )
{-
************************************************************************
@@ -2045,11 +2044,12 @@ instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
- put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
+ put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
- get bh = do n <- get bh
- i <- get bh
- return (IfaceTyCon n i)
+ get bh = do
+ n <- get bh
+ i <- get bh
+ return (IfaceTyCon n i)
instance Binary IfaceTyConSort where
put_ bh IfaceNormalTyCon = putByte bh 0
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3342,7 +3342,7 @@ alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs
alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
: PATS alt_rhs { $2 >>= \ $2 ->
- acsA (sLLAsl $1 $> ()) (\loc cs -> L (locA loc)
+ amsA' (sLLAsl $1 $>
(Match { m_ext = []
, m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing
, m_pats = $1
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -66,6 +66,9 @@ import GHC.Prelude
import Control.Monad
import Data.Array
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import Data.Char (isSpace)
import Data.Int
import Data.IntSet (IntSet)
import qualified Data.IntSet as IS
@@ -75,10 +78,7 @@ import Data.Map (Map)
import qualified Data.Map as M
import Data.Word
import Data.Semigroup
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Unsafe as B
-import Data.Char (isSpace)
-import System.IO
+import System.IO
import GHC.Settings.Constants (hiVersion)
@@ -168,7 +168,7 @@ wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"#
data Object = Object
{ objModuleName :: !ModuleName
-- ^ name of the module
- , objHandle :: !BinHandle
+ , objHandle :: !ReadBinHandle
-- ^ BinHandle that can be used to read the ObjBlocks
, objPayloadOffset :: !(Bin ObjBlock)
-- ^ Offset of the payload (units)
@@ -253,7 +253,7 @@ instance Outputable ExportedFun where
-- | Write an ObjBlock, except for the top level symbols which are stored in the
-- index
-putObjBlock :: BinHandle -> ObjBlock -> IO ()
+putObjBlock :: WriteBinHandle -> ObjBlock -> IO ()
putObjBlock bh (ObjBlock _syms b c d e f g) = do
put_ bh b
put_ bh c
@@ -264,7 +264,7 @@ putObjBlock bh (ObjBlock _syms b c d e f g) = do
-- | Read an ObjBlock and associate it to the given symbols (that must have been
-- read from the index)
-getObjBlock :: [FastString] -> BinHandle -> IO ObjBlock
+getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock
getObjBlock syms bh = do
b <- get bh
c <- get bh
@@ -299,7 +299,7 @@ data IndexEntry = IndexEntry
-- | Given a handle to a Binary payload, add the module, 'mod_name', its
-- dependencies, 'deps', and its linkable units to the payload.
putObject
- :: BinHandle
+ :: WriteBinHandle
-> ModuleName -- ^ module
-> BlockInfo -- ^ block infos
-> [ObjBlock] -- ^ linkable units and their symbols
@@ -313,15 +313,16 @@ putObject bh mod_name deps os = do
-- object in an archive.
put_ bh (moduleNameString mod_name)
- (bh_fs, _bin_dict, put_dict) <- initFSTable bh
+ (fs_tbl, fs_writer) <- initFastStringWriterTable
+ let bh_fs = addWriterToUserData (mkSomeBinaryWriter fs_writer) bh
- forwardPut_ bh (const put_dict) $ do
+ forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do
put_ bh_fs deps
-- forward put the index
forwardPut_ bh_fs (put_ bh_fs) $ do
idx <- forM os $ \o -> do
- p <- tellBin bh_fs
+ p <- tellBinWriter bh_fs
-- write units without their symbols
putObjBlock bh_fs o
-- return symbols and offset to store in the index
@@ -329,7 +330,7 @@ putObject bh mod_name deps os = do
pure idx
-- | Parse object header
-getObjectHeader :: BinHandle -> IO (Either String ModuleName)
+getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName)
getObjectHeader bh = do
magic <- getByteString bh (B.length hsHeader)
case magic == hsHeader of
@@ -344,15 +345,15 @@ getObjectHeader bh = do
-- | Parse object body. Must be called after a successful getObjectHeader
-getObjectBody :: BinHandle -> ModuleName -> IO Object
+getObjectBody :: ReadBinHandle -> ModuleName -> IO Object
getObjectBody bh0 mod_name = do
-- Read the string table
dict <- forwardGet bh0 (getDictionary bh0)
- let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }
+ let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict)
block_info <- get bh
idx <- forwardGet bh (get bh)
- payload_pos <- tellBin bh
+ payload_pos <- tellBinReader bh
pure $ Object
{ objModuleName = mod_name
@@ -363,7 +364,7 @@ getObjectBody bh0 mod_name = do
}
-- | Parse object
-getObject :: BinHandle -> IO (Maybe Object)
+getObject :: ReadBinHandle -> IO (Maybe Object)
getObject bh = do
getObjectHeader bh >>= \case
Left _err -> pure Nothing
@@ -392,7 +393,7 @@ getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..])
bh = objHandle obj
read_entry (IndexEntry syms offset,i)
| IS.member i bids = do
- seekBin bh offset
+ seekBinReader bh offset
Just <$> getObjBlock syms bh
| otherwise = pure Nothing
@@ -408,12 +409,12 @@ readObjectBlocks file bids = do
-- Helper functions
--------------------------------------------------------------------------------
-putEnum :: Enum a => BinHandle -> a -> IO ()
+putEnum :: Enum a => WriteBinHandle -> a -> IO ()
putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)
| otherwise = put_ bh n
where n = fromIntegral $ fromEnum x :: Word16
-getEnum :: Enum a => BinHandle -> IO a
+getEnum :: Enum a => ReadBinHandle -> IO a
getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16)
-- | Helper to convert Int to Int32
@@ -778,7 +779,7 @@ writeJSObject opts contents output_fn = do
-- | Read a JS object from BinHandle
-parseJSObject :: BinHandle -> IO (JSOptions, B.ByteString)
+parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString)
parseJSObject bh = do
magic <- getByteString bh (B.length jsHeader)
case magic == jsHeader of
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -1010,7 +1010,7 @@ data TupleSort
= BoxedTuple
| UnboxedTuple
| ConstraintTuple
- deriving( Eq, Data )
+ deriving( Eq, Data, Ord )
instance Outputable TupleSort where
ppr ts = text $
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -140,9 +140,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
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -663,12 +663,12 @@ instance Data Name where
-- distinction.
instance Binary Name where
put_ bh name =
- case getUserData bh of
- UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name
+ case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh name
get bh =
- case getUserData bh of
- UserData { ud_get_name = get_name } -> get_name bh
+ case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# LANGUAGE TypeFamilies #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -21,7 +22,7 @@
module GHC.Utils.Binary
( {-type-} Bin,
{-class-} Binary(..),
- {-type-} BinHandle,
+ {-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
@@ -30,8 +31,10 @@ module GHC.Utils.Binary
openBinMem,
-- closeBin,
- seekBin,
- tellBin,
+ seekBinWriter,
+ seekBinReader,
+ tellBinReader,
+ tellBinWriter,
castBin,
withBinBuffer,
@@ -66,15 +69,28 @@ 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 +103,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 +141,8 @@ import qualified Data.IntMap as IntMap
import GHC.ForeignPtr ( unsafeWithForeignPtr )
#endif
+import Unsafe.Coerce (unsafeCoerce)
+
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -150,49 +174,91 @@ instance Binary BinData where
copyBytes dest orig sz
return (BinData sz dat)
-dataHandle :: BinData -> IO BinHandle
+dataHandle :: BinData -> IO ReadBinHandle
dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
- szr <- newFastMutInt size
- binr <- newIORef bin
- return (BinMem noUserData ixr szr binr)
+ return (ReadBinMem noReaderUserData ixr size bin)
-handleData :: BinHandle -> IO BinData
-handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+handleData :: WriteBinHandle -> IO BinData
+handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
-data BinHandle
- = BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
- _off_r :: !FastMutInt, -- the current offset
- _sz_r :: !FastMutInt, -- size of the array (cached)
- _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
+-- | A write-only handle that can be used to serialise binary data into a buffer.
+--
+-- The buffer is an unboxed binary array.
+data WriteBinHandle
+ = WriteBinMem {
+ wbm_userData :: WriterUserData,
+ -- ^ User data for writing binary outputs.
+ -- Allows users to overwrite certain 'Binary' instances.
+ -- This is helpful when a non-canonical 'Binary' instance is required,
+ -- such as in the case of 'Name'.
+ wbm_off_r :: !FastMutInt, -- ^ the current offset
+ wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached)
+ wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))
}
- -- XXX: should really store a "high water mark" for dumping out
- -- the binary data to a file.
-getUserData :: BinHandle -> UserData
-getUserData bh = bh_usr bh
+-- | A read-only handle that can be used to deserialise binary data from a buffer.
+--
+-- The buffer is an unboxed binary array.
+data ReadBinHandle
+ = ReadBinMem {
+ rbm_userData :: ReaderUserData,
+ -- ^ User data for reading binary inputs.
+ -- Allows users to overwrite certain 'Binary' instances.
+ -- This is helpful when a non-canonical 'Binary' instance is required,
+ -- such as in the case of 'Name'.
+ rbm_off_r :: !FastMutInt, -- ^ the current offset
+ rbm_sz_r :: !Int, -- ^ size of the array (cached)
+ rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1))
+ }
+
+getReaderUserData :: ReadBinHandle -> ReaderUserData
+getReaderUserData bh = rbm_userData bh
+
+getWriterUserData :: WriteBinHandle -> WriterUserData
+getWriterUserData bh = wbm_userData bh
-setUserData :: BinHandle -> UserData -> BinHandle
-setUserData bh us = bh { bh_usr = us }
+setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
+setWriterUserData bh us = bh { wbm_userData = us }
+
+setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
+setReaderUserData bh us = bh { rbm_userData = us }
+
+-- | Add 'SomeBinaryReader' as a known binary decoder.
+-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',
+-- it is overwritten.
+addReaderToUserData :: SomeBinaryReader -> ReadBinHandle -> ReadBinHandle
+addReaderToUserData cache@(SomeBinaryReader typRep _) bh = bh
+ { rbm_userData = (rbm_userData bh)
+ { ud_reader_data = Map.insert (Refl.SomeTypeRep typRep) cache (ud_reader_data (rbm_userData bh))
+ }
+ }
+
+-- | Add 'SomeBinaryWriter' as a known binary encoder.
+-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',
+-- it is overwritten.
+addWriterToUserData :: SomeBinaryWriter -> WriteBinHandle -> WriteBinHandle
+addWriterToUserData cache@(SomeBinaryWriter typRep _) bh = bh
+ { wbm_userData = (wbm_userData bh)
+ { ud_writer_data = Map.insert (Refl.SomeTypeRep typRep) cache (ud_writer_data (wbm_userData bh))
+ }
+ }
-- | Get access to the underlying buffer.
-withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
-withBinBuffer (BinMem _ ix_r _ arr_r) action = do
- arr <- readIORef arr_r
+withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a
+withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do
ix <- readFastMutInt ix_r
+ arr <- readIORef arr_r
action $ BS.fromForeignPtr arr 0 ix
-unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
+unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt len
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (ReadBinMem noReaderUserData ix_r len arr)
---------------------------------------------------------------
-- Bin
@@ -211,23 +277,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 seekBinReader bh p; get bh
-openBinMem :: Int -> IO BinHandle
+openBinMem :: Int -> IO WriteBinHandle
openBinMem size
| size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"
| otherwise = do
@@ -235,45 +301,60 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noUserData ix_r sz_r arr_r)
+ return WriteBinMem
+ { wbm_userData = noWriterUserData
+ , wbm_off_r = ix_r
+ , wbm_sz_r = sz_r
+ , wbm_arr_r = arr_r
+ }
+
+tellBinWriter :: WriteBinHandle -> IO (Bin a)
+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBinReader :: ReadBinHandle -> IO (Bin a)
+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-seekBin :: BinHandle -> Bin a -> IO ()
-seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBinWriter :: WriteBinHandle -> Bin a -> IO ()
+seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p > sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
--- | 'seekBinNoExpand' moves the index pointer to the location pointed to
+-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to
-- by 'Bin a'.
-- 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
+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"
+ then panic "seekBinNoExpandWriter: 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
+seekBinReader :: ReadBinHandle -> Bin a -> IO ()
+seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do
+ if (p > sz_r)
+ then panic "seekBinReader: 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
@@ -282,20 +363,23 @@ readBinMemN size filename = do
then pure Nothing
else Just <$> readBinMem_ size h
-readBinMem_ :: Int -> Handle -> IO BinHandle
+readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ filesize h = do
arr <- mallocForeignPtrBytes filesize
count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt filesize
- return (BinMem noUserData ix_r sz_r arr_r)
+ return ReadBinMem
+ { rbm_userData = noReaderUserData
+ , rbm_off_r = ix_r
+ , rbm_sz_r = filesize
+ , rbm_arr_r = arr
+ }
-- expand the size of the array to include a specified offset
-expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ _ sz_r arr_r) !off = do
+expandBin :: WriteBinHandle -> Int -> IO ()
+expandBin (WriteBinMem _ _ sz_r arr_r) !off = do
!sz <- readFastMutInt sz_r
let !sz' = getSize sz
arr <- readIORef arr_r
@@ -316,7 +400,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
@@ -332,7 +416,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
@@ -353,8 +437,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) $
@@ -375,39 +459,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))
@@ -415,7 +497,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
@@ -428,7 +510,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))
@@ -440,7 +522,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
@@ -461,10 +543,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
-- -----------------------------------------------------------------------------
@@ -487,15 +569,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) $
@@ -512,15 +594,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
@@ -536,15 +618,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 ()
@@ -564,15 +646,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 )
@@ -983,63 +1065,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
+ seekBinReader bh p
r <- get_A
- seekBinNoExpand bh p_a
+ seekBinReader 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
+ seekBinReader bh p -- skip over the object for now
return a
-- | Serialize the constructor strictly but lazily serialize a value inside a
@@ -1047,14 +1129,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
@@ -1065,7 +1147,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,73 +1168,230 @@ 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
}
-newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
- -> (BinHandle -> IO FastString)
- -> UserData
-newReadState get_name get_fs
- = UserData { ud_get_name = get_name,
- ud_get_fs = get_fs,
- ud_put_nonbinding_name = undef "put_nonbinding_name",
- ud_put_binding_name = undef "put_binding_name",
- ud_put_fs = undef "put_fs"
- }
-
-newWriteState :: (BinHandle -> Name -> IO ())
+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 :: ReadBinHandle -> IO s
+ } deriving (Functor)
+
+newtype BinaryWriter s = BinaryWriter
+ { putEntry :: WriteBinHandle -> s -> IO ()
+ }
+
+mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
+mkWriter f = BinaryWriter
+ { putEntry = f
+ }
+
+mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s
+mkReader f = BinaryReader
+ { getEntry = f
+ }
+
+-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.
+--
+-- If no 'BinaryReader' has been configured before, this function will panic.
+findUserDataReader :: forall a . (HasCallStack, Refl.Typeable a) => Proxy a -> ReadBinHandle -> 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' has been configured before, this function will panic.
+findUserDataWriter :: forall a . (HasCallStack, Refl.Typeable a) => Proxy a -> WriteBinHandle -> 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 :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's
+ -> (ReadBinHandle -> IO FastString)
+ -> ReaderUserData
+newReadState get_name get_fs =
+ mkReaderUserData
+ [ mkSomeBinaryReader $ mkReader get_name
+ , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name)
+ , mkSomeBinaryReader $ mkReader get_fs
+ ]
+
+newWriteState :: (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize non-binding 'Name's
- -> (BinHandle -> Name -> IO ())
+ -> (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize binding 'Name's
- -> (BinHandle -> FastString -> IO ())
- -> UserData
-newWriteState put_nonbinding_name put_binding_name put_fs
- = UserData { ud_get_name = undef "get_name",
- ud_get_fs = undef "get_fs",
- ud_put_nonbinding_name = put_nonbinding_name,
- ud_put_binding_name = put_binding_name,
- ud_put_fs = put_fs
- }
-
-noUserData :: UserData
-noUserData = UserData
- { ud_get_name = undef "get_name"
- , ud_get_fs = undef "get_fs"
- , ud_put_nonbinding_name = undef "put_nonbinding_name"
- , ud_put_binding_name = undef "put_binding_name"
- , ud_put_fs = undef "put_fs"
+ -> (WriteBinHandle -> FastString -> IO ())
+ -> WriterUserData
+newWriteState put_non_binding_name put_binding_name put_fs =
+ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_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 :: ReadBinHandle -> 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 :: WriteBinHandle -> 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
-putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
+ return
+ ( WriterTable
+ { putTable = put_dict
+ }
+ , mkWriter $ putDictFastString bin_dict
+ )
+
+putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary bh sz dict = do
put_ bh sz
mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
-- It's OK to use nonDetEltsUFM here because the elements have indices
-- that array uses to create order
-getDictionary :: BinHandle -> IO Dictionary
+getDictionary :: ReadBinHandle -> IO Dictionary
getDictionary bh = do
sz <- get bh :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
@@ -1159,34 +1400,12 @@ getDictionary bh = do
writeArray mut_arr i fs
unsafeFreeze mut_arr
-getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
-
-initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
-initFSTable bh = do
- dict_next_ref <- newFastMutInt 0
- dict_map_ref <- newIORef emptyUFM
- let bin_dict = FSTable
- { fs_tab_next = dict_next_ref
- , fs_tab_map = dict_map_ref
- }
- let put_dict = do
- fs_count <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh fs_count dict_map
- pure fs_count
-
- -- BinHandle with FastString writing support
- let ud = getUserData bh
- let ud_fs = ud { ud_put_fs = putDictFastString bin_dict }
- let bh_fs = setUserData bh ud_fs
-
- return (bh_fs,bin_dict,put_dict)
-
-putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
+putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: FSTable -> FastString -> IO Word32
@@ -1215,43 +1434,42 @@ data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use
-- The Symbol Table
---------------------------------------------------------
--- On disk, the symbol table is an array of IfExtName, when
--- reading it in we turn it into a SymbolTable.
-
-type SymbolTable = Array Int Name
+-- | Symbols that are read from disk.
+-- The 'SymbolTable' index starts on '0'.
+type SymbolTable a = Array Int a
---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------
-putFS :: BinHandle -> FastString -> IO ()
+putFS :: WriteBinHandle -> FastString -> IO ()
putFS bh fs = putBS bh $ bytesFS fs
-getFS :: BinHandle -> IO FastString
+getFS :: ReadBinHandle -> IO FastString
getFS bh = do
l <- get bh :: IO Int
getPrim bh l (\src -> pure $! mkFastStringBytes src l )
-- | Put a ByteString without its length (can't be read back without knowing the
-- length!)
-putByteString :: BinHandle -> ByteString -> IO ()
+putByteString :: WriteBinHandle -> ByteString -> IO ()
putByteString bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-- | Get a ByteString whose length is known
-getByteString :: BinHandle -> Int -> IO ByteString
+getByteString :: ReadBinHandle -> Int -> IO ByteString
getByteString bh l =
BS.create l $ \dest -> do
getPrim bh l (\src -> copyBytes dest src l)
-putBS :: BinHandle -> ByteString -> IO ()
+putBS :: WriteBinHandle -> ByteString -> IO ()
putBS bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
put_ bh l
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-getBS :: BinHandle -> IO ByteString
+getBS :: ReadBinHandle -> IO ByteString
getBS bh = do
l <- get bh :: IO Int
BS.create l $ \dest -> do
@@ -1263,12 +1481,12 @@ instance Binary ByteString where
instance Binary FastString where
put_ bh f =
- case getUserData bh of
- UserData { ud_put_fs = put_fs } -> put_fs bh f
+ case findUserDataWriter (Proxy :: Proxy FastString) bh of
+ tbl -> putEntry tbl bh f
get bh =
- case getUserData bh of
- UserData { ud_get_fs = get_fs } -> get_fs bh
+ case findUserDataReader (Proxy :: Proxy FastString) bh of
+ tbl -> getEntry tbl bh
deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString
=====================================
compiler/GHC/Utils/Binary/Typeable.hs
=====================================
@@ -35,7 +35,7 @@ instance Binary TyCon where
get bh =
mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-getSomeTypeRep :: BinHandle -> IO SomeTypeRep
+getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep
getSomeTypeRep bh = do
tag <- get bh :: IO Word8
case tag of
@@ -167,7 +167,7 @@ instance Binary TypeLitSort where
2 -> pure TypeLitChar
_ -> fail "Binary.putTypeLitSort: invalid tag"
-putTypeRep :: BinHandle -> TypeRep a -> IO ()
+putTypeRep :: WriteBinHandle -> TypeRep a -> IO ()
putTypeRep bh rep -- Handle Type specially since it's so common
| Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
= put_ bh (0 :: Word8)
=====================================
configure.ac
=====================================
@@ -97,11 +97,11 @@ dnl use either is considered a Feature.
dnl ** What command to use to compile compiler sources ?
dnl --------------------------------------------------------------
-AC_ARG_VAR(GHC,[Use as the full path to GHC. [default=autodetect]])
-AC_PATH_PROG([GHC], [ghc])
+AC_ARG_VAR(GHC,[Use as the bootstrap GHC. [default=autodetect]])
+AC_CHECK_PROG([GHC], [ghc], [ghc])
AC_ARG_WITH([ghc],
- AS_HELP_STRING([--with-ghc=PATH], [Use PATH as the full path to ghc (obsolete, use GHC=PATH instead) [default=autodetect]]),
- AC_MSG_ERROR([--with-ghc=$withval is obsolete (use './configure GHC=$withval' or 'GHC=$withval ./configure' instead)]))
+ AS_HELP_STRING([--with-ghc=PATH], [Use PATH as the bootstrap ghc (obsolete, use GHC=PATH instead) [default=autodetect]]),
+ AC_MSG_ERROR([--with-ghc=$withval is obsolete (use './configure GHC=$withval' instead)]))
AC_SUBST(WithGhc,$GHC)
AC_ARG_ENABLE(bootstrap-with-devel-snapshot,
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -31,6 +31,7 @@ import qualified Distribution.PackageDescription.Parsec as C
import qualified Distribution.Simple.Compiler as C
import qualified Distribution.Simple.Program.Db as C
import qualified Distribution.Simple as C
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.Program.Builtin as C
import qualified Distribution.Simple.Utils as C
import qualified Distribution.Simple.Program.Types as C
@@ -363,12 +364,11 @@ registerPackage rs context = do
need [setupConfig] -- This triggers 'configurePackage'
pd <- packageDescription <$> readContextData context
db_path <- packageDbPath (PackageDbLoc (stage context) (iplace context))
- dist_dir <- Context.buildPath context
pid <- pkgUnitId (stage context) (package context)
-- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
-- from the local build info @lbi at .
lbi <- liftIO $ C.getPersistBuildConfig cPath
- liftIO $ register db_path pid dist_dir pd lbi
+ liftIO $ register db_path pid pd lbi
-- Then after the register, which just writes the .conf file, do the recache step.
buildWithResources rs $
target context (GhcPkg Recache (stage context)) [] []
@@ -377,25 +377,23 @@ registerPackage rs context = do
-- into a different package database to the one it was configured against.
register :: FilePath
-> String -- ^ Package Identifier
- -> FilePath
-> C.PackageDescription
-> LocalBuildInfo
-> IO ()
-register pkg_db pid build_dir pd lbi
+register pkg_db pid pd lbi
= withLibLBI pd lbi $ \lib clbi -> do
- absPackageDBs <- C.absolutePackageDBPaths packageDbs
- installedPkgInfo <- C.generateRegistrationInfo
- C.silent pd lib lbi clbi False reloc build_dir
- (C.registrationPackageDB absPackageDBs)
-
+ when reloc $ error "register does not support reloc"
+ installedPkgInfo <- generateRegistrationInfo pd lbi lib clbi
writeRegistrationFile installedPkgInfo
where
regFile = pkg_db </> pid <.> "conf"
reloc = relocatable lbi
- -- Using a specific package db here is why we have to copy the function from Cabal.
- packageDbs = [C.SpecificPackageDB pkg_db]
+
+ generateRegistrationInfo pkg lbi lib clbi = do
+ abi_hash <- C.mkAbiHash <$> GHC.libAbiHash C.silent pkg lbi lib clbi
+ return (C.absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi)
writeRegistrationFile installedPkgInfo = do
writeUTF8File regFile (CP.showInstalledPackageInfo installedPkgInfo)
=====================================
testsuite/tests/perf/compiler/Makefile
=====================================
@@ -17,6 +17,12 @@ MultiModulesRecomp:
./genMultiLayerModules
'$(TEST_HC)' $(TEST_HC_OPTS) -v0 MultiLayerModules.hs
+# -e "" exits the ghci session immediately and merely makes sure, we generated interface files
+# containing core expressions, aka `mi_extra_decls` are populated.
+MultiModulesRecompDefsWithCore:
+ ./genMultiLayerModulesCore
+ '$(TEST_HC)' --interactive $(TEST_HC_OPTS) -e "" -fwrite-if-simplified-core MultiLayerModules
+
MultiComponentModulesRecomp:
'$(PYTHON)' genMultiComp.py
TEST_HC='$(TEST_HC)' TEST_HC_OPTS='$(TEST_HC_OPTS)' ./run
=====================================
testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithCore.script
=====================================
@@ -0,0 +1 @@
+:m + MultiLayerModules
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -405,6 +405,20 @@ test('MultiLayerModulesDefsGhci',
ghci_script,
['MultiLayerModulesDefsGhci.script'])
+test('MultiLayerModulesDefsGhciWithCore',
+ [ collect_compiler_residency(15),
+ pre_cmd('$MAKE -s --no-print-directory MultiModulesRecompDefsWithCore'),
+ extra_files(['genMultiLayerModulesCore', 'MultiLayerModulesDefsGhciWithCore.script']),
+ compile_timeout_multiplier(5),
+ # this is _a lot_
+ # but this test has been failing every now and then,
+ # especially on i386. Let's just give it some room
+ # to complete successfully reliably everywhere.
+ extra_run_opts('-fwrite-if-simplified-core MultiLayerModules')
+ ],
+ ghci_script,
+ ['MultiLayerModulesDefsGhciWithCore.script'])
+
test('MultiLayerModulesDefsGhciReload',
[ collect_compiler_residency(15),
pre_cmd('./genMultiLayerModulesDefs'),
=====================================
testsuite/tests/perf/compiler/genMultiLayerModulesCore
=====================================
@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+# Generate $WIDTH modules with one type each $FIELDS type variables.
+# The type has $CONSTRS constructors with each $FIELDS fields.
+# All types derive 'Generic' to generate a large amount of Types.
+# MultiLayerModules.hs imports all the modules
+WIDTH=10
+FIELDS=10
+CONSTRS=15
+FIELD_VARS=$(for field in $(seq -w 1 $FIELDS); do echo -n "a${field} "; done)
+for i in $(seq -w 1 $WIDTH); do
+ echo "module DummyLevel$i where" > DummyLevel$i.hs;
+ echo "import GHC.Generics" >> DummyLevel$i.hs;
+ echo "data Type_${i} ${FIELD_VARS}" >> DummyLevel$i.hs;
+ for constr in $(seq -w 1 $CONSTRS); do
+ if [ $constr -eq 1 ]; then
+ echo -n " = Constr_${i}_${constr} " >> DummyLevel$i.hs;
+ else
+ echo -n " | Constr_${i}_${constr} " >> DummyLevel$i.hs;
+ fi
+ echo ${FIELD_VARS} >> DummyLevel$i.hs;
+ done
+ echo " deriving (Show, Eq, Ord, Generic)" >> DummyLevel$i.hs;
+done
+
+echo "module MultiLayerModules where" > MultiLayerModules.hs
+for j in $(seq -w 1 $WIDTH); do
+ echo "import DummyLevel$j" >> MultiLayerModules.hs;
+done
=====================================
testsuite/tests/printer/CaseAltComments.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternGuards #-}
+module CaseAltComments where
+
+nfCom = case expr of
+ x :*: y -- comment
+ | x' <= y' -> x' :*: y'
+ _ -> blah
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -826,3 +826,8 @@ Test24533:
PprLetIn:
$(CHECK_PPR) $(LIBDIR) PprLetIn.hs
$(CHECK_EXACT) $(LIBDIR) PprLetIn.hs
+
+.PHONY: CaseAltComments
+CaseAltComments:
+ $(CHECK_PPR) $(LIBDIR) CaseAltComments.hs
+ $(CHECK_EXACT) $(LIBDIR) CaseAltComments.hs
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -198,3 +198,4 @@ test('ListTuplePuns', extra_files(['ListTuplePuns.hs']), ghci_script, ['ListTupl
test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test, ['AnnotationNoListTuplePuns'])
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
+test('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 358307f6fa52daa2c2411a4975c87b30932af3dc
+Subproject commit ccad8012338201e41580e159f0bd79afa349eb39
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eda3aa6ee1c86bab4c07b81ce758fc4520e72f69...be6836a22245743b736ae1fc88b4c0ba3e2cce6e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eda3aa6ee1c86bab4c07b81ce758fc4520e72f69...be6836a22245743b736ae1fc88b4c0ba3e2cce6e
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/20240424/d8fec6ba/attachment-0001.html>
More information about the ghc-commits
mailing list