[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Improve sharing of duplicated values in `ModIface`, fixes #24723
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Jun 2 04:21:34 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0cc9b8aa by Fendor at 2024-06-02T00:21:01-04:00
Improve sharing of duplicated values in `ModIface`, fixes #24723
As a `ModIface` often contains duplicated values that are not
necessarily shared, we improve sharing by serialising the `ModIface`
to an in-memory byte array. Serialisation uses deduplication tables, and
deserialisation implicitly shares duplicated values.
This helps reducing the peak memory usage while compiling in
`--make` mode. The peak memory usage is especially smaller when
generating interface files with core expressions
(`-fwrite-if-simplified-core`).
On agda, this reduces the peak memory usage:
* `2.2 GB` to `1.9 GB` for a ghci session.
On `lib:Cabal`, we report:
* `570 MB` to `500 MB` for a ghci session
* `790 MB` to `667 MB` for compiling `lib:Cabal` with ghc
There is a small impact on execution time, around 2% on the agda code
base.
- - - - -
ef0e1096 by Fendor at 2024-06-02T00:21:01-04:00
Avoid unneccessarily re-serialising the `ModIface`
To reduce memory usage of `ModIface`, we serialise `ModIface` to an
in-memory byte array, which implicitly shares duplicated values.
This serialised byte array can be reused to avoid work when we actually
write the `ModIface` to disk.
We introduce a new field to `ModIface` which allows us to save the byte
array, and write it direclty to disk if the `ModIface` wasn't changed
after the initial serialisation.
This requires us to change absolute offsets, for example to jump to the
deduplication table for `Name` or `FastString` with relative offsets, as
the deduplication byte array doesn't contain header information, such as
fingerprints.
To allow us to dump the binary blob to disk, we need to replace all
absolute offsets with relative ones.
We introduce additional helpers for `ModIface` binary serialisation, which
construct relocatable binary blobs. We say the binary blob is relocatable,
if the binary representation can be moved and does not contain any
absolute offsets.
Further, we introduce new primitives for `Binary` that allow to create
relocatable binaries, such as `forwardGetRel` and `forwardPutRel`.
-------------------------
Metric Decrease:
MultiLayerModulesDefsGhcWithCore
Metric Increase:
MultiComponentModules
MultiLayerModules
T10421
T12234
T12425
T13035
T13701
T13719
T14697
T15703
T16875
T18730
T9198
mhu-perf
-------------------------
These metric increases may look bad, but they are all completely benign,
we simply allocate 1 MB per module for `shareIface`. As this allocation
is quite quick, it has a negligible impact on run-time performance.
- - - - -
d0675c6b by Cheng Shao at 2024-06-02T00:21:02-04:00
hadrian: disable PIC for in-tree GMP on wasm32
This patch disables PIC for in-tree GMP on wasm32 target. Enabling PIC
unconditionally adds undesired code size and runtime overhead for
wasm32.
- - - - -
59a6e3f8 by Cheng Shao at 2024-06-02T00:21:02-04:00
hadrian: disable in-tree gmp fft code path for wasm32
This patch disables in-tree GMP FFT code paths for wasm32 target in
order to give up some performance of multiplying very large operands
in exchange for reduced code size.
- - - - -
6304030e by Cheng Shao at 2024-06-02T00:21:03-04:00
hadrian: build in-tree GMP with malloc-notreentrant on wasm32
This patch makes hadrian build in-tree GMP with the
--enable-alloca=malloc-notreentrant configure option. We will only
need malloc-reentrant when we have threaded RTS and SMP support on
wasm32, which will take some time to happen, before which we should
use malloc-notreentrant to avoid undesired runtime overhead.
- - - - -
16 changed files:
- compiler/GHC.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Utils/Binary.hs
- hadrian/src/Settings/Builders/Configure.hs
- testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
-- -----------------------------------------------------------------------------
--
@@ -96,7 +97,35 @@ module GHC (
lookupGlobalName,
findGlobalAnns,
mkNamePprCtxForModule,
- ModIface, ModIface_(..),
+ ModIface,
+ ModIface_(
+ mi_module,
+ mi_sig_of,
+ mi_hsc_src,
+ mi_src_hash,
+ mi_hi_bytes,
+ mi_deps,
+ mi_usages,
+ mi_exports,
+ mi_used_th,
+ mi_fixities,
+ mi_warns,
+ mi_anns,
+ mi_insts,
+ mi_fam_insts,
+ mi_rules,
+ mi_decls,
+ mi_extra_decls,
+ mi_top_env,
+ mi_hpc,
+ mi_trust,
+ mi_trust_pkg,
+ mi_complete_matches,
+ mi_docs,
+ mi_final_exts,
+ mi_ext_fields
+ ),
+ pattern ModIface,
SafeHaskellMode(..),
-- * Printing
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Iface.Binary (
getSymtabName,
CheckHiWay(..),
TraceBinIFace(..),
+ getIfaceWithExtFields,
+ putIfaceWithExtFields,
getWithUserData,
putWithUserData,
@@ -61,6 +63,8 @@ import Data.Map.Strict (Map)
import Data.Word
import System.IO.Unsafe
import Data.Typeable (Typeable)
+import qualified GHC.Data.Strict as Strict
+import Data.Function ((&))
-- ---------------------------------------------------------------------------
@@ -169,17 +173,29 @@ readBinIface
readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
(src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path
- extFields_p <- get bh
+ mod_iface <- getIfaceWithExtFields name_cache bh
- mod_iface <- getWithUserData name_cache bh
+ return $ mod_iface
+ & addSourceFingerprint src_hash
- seekBinReader bh extFields_p
- extFields <- get bh
- return mod_iface
- { mi_ext_fields = extFields
- , mi_src_hash = src_hash
- }
+getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface
+getIfaceWithExtFields name_cache bh = do
+ -- Start offset for the byte array that contains the serialised 'ModIface'.
+ start <- tellBinReader bh
+ extFields_p_rel <- getRelBin bh
+
+ mod_iface <- getWithUserData name_cache bh
+
+ seekBinReaderRel bh extFields_p_rel
+ extFields <- get bh
+ -- Store the 'ModIface' byte array, so that we can avoid serialisation if
+ -- the 'ModIface' isn't modified.
+ -- See Note [Sharing of ModIface]
+ modIfaceBinData <- freezeBinHandle bh start
+ pure $ mod_iface
+ & set_mi_ext_fields extFields
+ & set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData)
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
@@ -209,7 +225,7 @@ getTables name_cache bh = do
-- add it to the 'ReaderUserData' of 'ReadBinHandle'.
decodeReaderTable :: Typeable a => ReaderTable a -> ReadBinHandle -> IO ReadBinHandle
decodeReaderTable tbl bh0 = do
- table <- Binary.forwardGet bh (getTable tbl bh0)
+ table <- Binary.forwardGetRel bh (getTable tbl bh0)
let binaryReader = mkReaderFromTable tbl table
pure $ addReaderToUserData binaryReader bh0
@@ -246,19 +262,24 @@ writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do
put_ bh tag
put_ bh (mi_src_hash mod_iface)
- extFields_p_p <- tellBinWriter bh
- put_ bh extFields_p_p
-
- putWithUserData traceBinIface compressionLevel bh mod_iface
-
- extFields_p <- tellBinWriter bh
- putAt bh extFields_p_p extFields_p
- seekBinWriter bh extFields_p
- put_ bh (mi_ext_fields mod_iface)
+ putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface
-- And send the result to the file
writeBinMem bh hi_path
+-- | Puts the 'ModIface' to the 'WriteBinHandle'.
+--
+-- This avoids serialisation of the 'ModIface' if the fields 'mi_hi_bytes' contains a
+-- 'Just' value. This field is populated by reading the 'ModIface' using
+-- 'getIfaceWithExtFields' and not modifying it in any way afterwards.
+putIfaceWithExtFields :: TraceBinIFace -> CompressionIFace -> WriteBinHandle -> ModIface -> IO ()
+putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface =
+ case mi_hi_bytes mod_iface of
+ FullIfaceBinHandle Strict.Nothing -> do
+ forwardPutRel_ bh (\_ -> put_ bh (mi_ext_fields mod_iface)) $ do
+ putWithUserData traceBinIface compressionLevel bh mod_iface
+ FullIfaceBinHandle (Strict.Just binData) -> putFullBinData bh binData
+
-- | Put a piece of data with an initialised `UserData` field. This
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
@@ -332,7 +353,7 @@ putAllTables _ [] act = do
a <- act
pure ([], a)
putAllTables bh (x : xs) act = do
- (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
+ (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do
putAllTables bh xs act
pure (r : res, a)
@@ -484,7 +505,7 @@ 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'.
+functions such as 'forwardGetRel'.
Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'):
@@ -585,7 +606,6 @@ initWriteIfaceType compressionLevel = do
putGenericSymTab sym_tab bh ty
_ -> putIfaceType bh ty
-
fullIfaceTypeSerialiser sym_tab bh ty = do
put_ bh ifaceTypeSharedByte
putGenericSymTab sym_tab bh ty
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -228,7 +228,7 @@ readHieFileContents bh0 name_cache = do
get bh1
where
get_dictionary tbl bin_handle = do
- fsTable <- Binary.forwardGet bin_handle (getTable tbl bin_handle)
+ fsTable <- Binary.forwardGetRel bin_handle (getTable tbl bin_handle)
let
fsReader = mkReaderFromTable tbl fsTable
bhFs = addReaderToUserData fsReader bin_handle
=====================================
compiler/GHC/Iface/Ext/Fields.hs
=====================================
@@ -41,7 +41,7 @@ instance Binary ExtensibleFields where
-- to point to the start of each payload:
forM_ header_entries $ \(field_p_p, dat) -> do
field_p <- tellBinWriter bh
- putAt bh field_p_p field_p
+ putAtRel bh field_p_p field_p
seekBinWriter bh field_p
put_ bh dat
@@ -50,11 +50,11 @@ instance Binary ExtensibleFields where
-- Get the names and field pointers:
header_entries <- replicateM n $
- (,) <$> get bh <*> get bh
+ (,) <$> get bh <*> getRelBin bh
-- Seek to and get each field's payload:
fields <- forM header_entries $ \(name, field_p) -> do
- seekBinReader bh field_p
+ seekBinReaderRel bh field_p
dat <- get bh
return (name, dat)
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -117,6 +117,7 @@ import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
import GHC.Iface.Errors.Types
+import Data.Function ((&))
{-
************************************************************************
@@ -515,14 +516,12 @@ loadInterface doc_str mod from
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
- ; let { final_iface = iface {
- mi_decls = panic "No mi_decls in PIT",
- mi_insts = panic "No mi_insts in PIT",
- mi_fam_insts = panic "No mi_fam_insts in PIT",
- mi_rules = panic "No mi_rules in PIT",
- mi_anns = panic "No mi_anns in PIT"
- }
- }
+ ; let final_iface = iface
+ & set_mi_decls (panic "No mi_decls in PIT")
+ & set_mi_insts (panic "No mi_insts in PIT")
+ & set_mi_fam_insts (panic "No mi_fam_insts in PIT")
+ & set_mi_rules (panic "No mi_rules in PIT")
+ & set_mi_anns (panic "No mi_anns in PIT")
; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
@@ -1018,13 +1017,13 @@ readIface dflags name_cache wanted_mod file_path = do
-- See Note [GHC.Prim] in primops.txt.pp.
ghcPrimIface :: ModIface
ghcPrimIface
- = empty_iface {
- mi_exports = ghcPrimExports,
- mi_decls = [],
- mi_fixities = fixities,
- mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },
- mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]
- }
+ = empty_iface
+ & set_mi_exports ghcPrimExports
+ & set_mi_decls []
+ & set_mi_fixities fixities
+ & set_mi_final_exts ((mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities })
+ & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs]
+
where
empty_iface = emptyFullModIface gHC_PRIM
@@ -1108,7 +1107,7 @@ pprModIfaceSimple unit_state iface =
--
-- The UnitState is used to pretty-print units
pprModIface :: UnitState -> ModIface -> SDoc
-pprModIface unit_state iface at ModIface{ mi_final_exts = exts }
+pprModIface unit_state iface
= vcat [ text "interface"
<+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
<+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)
@@ -1149,6 +1148,7 @@ pprModIface unit_state iface at ModIface{ mi_final_exts = exts }
, text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
]
where
+ exts = mi_final_exts iface
pp_hsc_src HsBootFile = text "[boot]"
pp_hsc_src HsigFile = text "[hsig]"
pp_hsc_src HsSrcFile = Outputable.empty
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -69,10 +69,13 @@ import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
import GHC.Types.SourceText
import GHC.Types.SrcLoc ( unLoc )
+import GHC.Types.Name.Cache
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
+import GHC.Utils.Binary
+import GHC.Iface.Binary
import GHC.Data.FastString
import GHC.Data.Maybe
@@ -142,14 +145,47 @@ mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
full_iface <-
{-# SCC "addFingerprints" #-}
- addFingerprints hsc_env partial_iface{ mi_decls = decls }
+ addFingerprints hsc_env (set_mi_decls decls partial_iface)
-- Debug printing
let unit_state = hsc_units hsc_env
putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText
(pprModIface unit_state full_iface)
+ final_iface <- shareIface (hsc_NC hsc_env) (flagsToIfCompression $ hsc_dflags hsc_env) full_iface
+ return final_iface
- return full_iface
+-- | Compress an 'ModIface' and share as many values as possible, depending on the 'CompressionIFace' level.
+-- See Note [Sharing of ModIface].
+--
+-- We compress the 'ModIface' by serialising the 'ModIface' to an in-memory byte array, and then deserialising it.
+-- The deserialisation will deduplicate certain values depending on the 'CompressionIFace' level.
+-- See Note [Deduplication during iface binary serialisation] for how we do that.
+--
+-- Additionally, we cache the serialised byte array, so if the 'ModIface' is not modified
+-- after calling 'shareIface', 'writeBinIface' will reuse that buffer without serialising the 'ModIface' again.
+-- Modifying the 'ModIface' forces us to re-serialise it again.
+shareIface :: NameCache -> CompressionIFace -> ModIface -> IO ModIface
+shareIface _ NormalCompression mi = do
+ -- In 'NormalCompression', the sharing isn't reducing the memory usage, as 'Name's and 'FastString's are
+ -- already shared, and at this compression level, we don't compress/share anything else.
+ -- Thus, for a brief moment we simply double the memory residency for no reason.
+ -- Therefore, we only try to share expensive values if the compression mode is higher than
+ -- 'NormalCompression'
+ pure mi
+shareIface nc compressionLevel mi = do
+ bh <- openBinMem initBinMemSize
+ start <- tellBinWriter bh
+ putIfaceWithExtFields QuietBinIFace compressionLevel bh mi
+ rbh <- shrinkBinBuffer bh
+ seekBinReader rbh start
+ res <- getIfaceWithExtFields nc rbh
+ let resiface = restoreFromOldModIface mi res
+ forceModIface resiface
+ return resiface
+
+-- | Initial ram buffer to allocate for writing interface files.
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024 -- 1 MB
updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
updateDecl decls Nothing Nothing = decls
@@ -304,40 +340,40 @@ mkIface_ hsc_env
icomplete_matches = map mkIfaceCompleteMatch complete_matches
!rdrs = maybeGlobalRdrEnv rdr_env
- ModIface {
- mi_module = this_mod,
+ emptyPartialModIface this_mod
-- Need to record this because it depends on the -instantiated-with flag
-- which could change
- mi_sig_of = if semantic_mod == this_mod
- then Nothing
- else Just semantic_mod,
- mi_hsc_src = hsc_src,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = mkIfaceExports exports,
+ & set_mi_sig_of (if semantic_mod == this_mod
+ then Nothing
+ else Just semantic_mod)
+ & set_mi_hsc_src hsc_src
+ & set_mi_deps deps
+ & set_mi_usages usages
+ & set_mi_exports (mkIfaceExports exports)
-- Sort these lexicographically, so that
-- the result is stable across compilations
- mi_insts = sortBy cmp_inst iface_insts,
- mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
- mi_rules = sortBy cmp_rule iface_rules,
-
- mi_fixities = fixities,
- mi_warns = warns,
- mi_anns = annotations,
- mi_top_env = rdrs,
- mi_used_th = used_th,
- mi_decls = decls,
- mi_extra_decls = extra_decls,
- mi_hpc = isHpcUsed hpc_info,
- mi_trust = trust_info,
- mi_trust_pkg = pkg_trust_req,
- mi_complete_matches = icomplete_matches,
- mi_docs = docs,
- mi_final_exts = (),
- mi_ext_fields = emptyExtensibleFields,
- mi_src_hash = ms_hs_hash mod_summary
- }
+ & set_mi_insts (sortBy cmp_inst iface_insts)
+ & set_mi_fam_insts (sortBy cmp_fam_inst iface_fam_insts)
+ & set_mi_rules (sortBy cmp_rule iface_rules)
+
+ & set_mi_fixities fixities
+ & set_mi_warns warns
+ & set_mi_anns annotations
+ & set_mi_top_env rdrs
+ & set_mi_used_th used_th
+ & set_mi_decls decls
+ & set_mi_extra_decls extra_decls
+ & set_mi_hpc (isHpcUsed hpc_info)
+ & set_mi_trust trust_info
+ & set_mi_trust_pkg pkg_trust_req
+ & set_mi_complete_matches (icomplete_matches)
+ & set_mi_docs docs
+ & set_mi_final_exts ()
+ & set_mi_ext_fields emptyExtensibleFields
+ & set_mi_src_hash (ms_hs_hash mod_summary)
+ & set_mi_hi_bytes PartialIfaceBinHandle
+
where
cmp_rule = lexicalCompareFS `on` ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
@@ -513,3 +549,22 @@ That is, in Y,
In the result of mkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.
-}
+
+{-
+Note [Sharing of ModIface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+A 'ModIface' contains many duplicated values such as 'Name', 'FastString' and 'IfaceType'.
+'Name's and 'FastString's are already deduplicated by default using the 'NameCache' and
+'FastStringTable' respectively.
+However, 'IfaceType' can be quite expensive in terms of memory usage.
+To improve the sharing of 'IfaceType', we introduced deduplication tables during
+serialisation of 'ModIface', see Note [Deduplication during iface binary serialisation].
+
+We can improve the sharing of 'ModIface' at run-time as well, by serialising the 'ModIface' to
+an in-memory buffer, and then deserialising it again.
+This implicitly shares duplicated values.
+
+To avoid re-serialising the 'ModIface' when writing it to disk, we save the serialised 'ModIface' buffer
+in 'mi_hi_bytes_' field of said 'ModIface'. This buffer is written to disk directly in 'putIfaceWithExtFields'.
+If we have to modify the 'ModIface' after 'shareIface' is called, the buffer needs to be discarded.
+-}
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1281,7 +1281,8 @@ addFingerprints hsc_env iface0
, mi_fix_fn = fix_fn
, mi_hash_fn = lookupOccEnv local_env
}
- final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts }
+ final_iface = completePartialModIface iface0
+ sorted_decls sorted_extra_decls final_iface_exts
--
return final_iface
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.Utils.Panic
import qualified Data.Traversable as T
import Data.IORef
+import Data.Function ((&))
tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a
tcRnMsgMaybe do_this = do
@@ -108,13 +109,14 @@ rnModIface hsc_env insts nsubst iface =
deps <- rnDependencies (mi_deps iface)
-- TODO:
-- mi_rules
- return iface { mi_module = mod
- , mi_sig_of = sig_of
- , mi_insts = insts
- , mi_fam_insts = fams
- , mi_exports = exports
- , mi_decls = decls
- , mi_deps = deps }
+ return $ iface
+ & set_mi_module mod
+ & set_mi_sig_of sig_of
+ & set_mi_insts insts
+ & set_mi_fam_insts fams
+ & set_mi_exports exports
+ & set_mi_decls decls
+ & set_mi_deps deps
-- | Rename just the exports of a 'ModIface'. Useful when we're doing
-- shaping prior to signature merging.
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -76,7 +76,7 @@ import GHC.Tc.Utils.Unify ( tcSubTypeSigma )
import GHC.HsToCore.Docs ( extractDocs )
import GHC.Hs.Doc
-import GHC.Unit.Module.ModIface ( ModIface_(..) )
+import GHC.Unit.Module.ModIface ( mi_docs )
import GHC.Iface.Load ( loadInterfaceForName )
import GHC.Builtin.Utils (knownKeyNames)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1562,7 +1562,8 @@ lookupDeclDoc nm = do
-- Wasn't in the current module. Try searching other external ones!
mIface <- getExternalModIface nm
case mIface of
- Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->
+ Just iface
+ | Just Docs{docs_decls = dmap} <- mi_docs iface ->
pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm
_ -> pure Nothing
@@ -1578,7 +1579,8 @@ lookupArgDoc i nm = do
Nothing -> do
mIface <- getExternalModIface nm
case mIface of
- Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->
+ Just iface
+ | Just Docs{docs_args = amap} <- mi_docs iface->
pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)
_ -> pure Nothing
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -87,6 +87,7 @@ import Control.Monad
import Data.List (find)
import GHC.Iface.Errors.Types
+import Data.Function ((&))
checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM sig_iface sig_thing real_thing = do
@@ -369,8 +370,8 @@ tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface avails iface =
- iface {
- mi_exports = avails,
+ iface
+ & set_mi_exports avails
-- mi_fixities = ...,
-- mi_warns = ...,
-- mi_anns = ...,
@@ -378,10 +379,9 @@ thinModIface avails iface =
-- perhaps there might be two IfaceTopBndr that are the same
-- OccName but different Name. Requires better understanding
-- of invariants here.
- mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
+ & set_mi_decls (exported_decls ++ non_exported_decls ++ dfun_decls)
-- mi_insts = ...,
-- mi_fam_insts = ...,
- }
where
decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -4,10 +4,68 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
+
module GHC.Unit.Module.ModIface
( ModIface
- , ModIface_ (..)
+ , ModIface_
+ ( mi_module
+ , mi_sig_of
+ , mi_hsc_src
+ , mi_deps
+ , mi_usages
+ , mi_exports
+ , mi_used_th
+ , mi_fixities
+ , mi_warns
+ , mi_anns
+ , mi_decls
+ , mi_extra_decls
+ , mi_top_env
+ , mi_insts
+ , mi_fam_insts
+ , mi_rules
+ , mi_hpc
+ , mi_trust
+ , mi_trust_pkg
+ , mi_complete_matches
+ , mi_docs
+ , mi_final_exts
+ , mi_ext_fields
+ , mi_src_hash
+ , mi_hi_bytes
+ )
+ , pattern ModIface
+ , restoreFromOldModIface
+ , addSourceFingerprint
+ , set_mi_module
+ , set_mi_sig_of
+ , set_mi_hsc_src
+ , set_mi_src_hash
+ , set_mi_hi_bytes
+ , set_mi_deps
+ , set_mi_usages
+ , set_mi_exports
+ , set_mi_used_th
+ , set_mi_fixities
+ , set_mi_warns
+ , set_mi_anns
+ , set_mi_insts
+ , set_mi_fam_insts
+ , set_mi_rules
+ , set_mi_decls
+ , set_mi_extra_decls
+ , set_mi_top_env
+ , set_mi_hpc
+ , set_mi_trust
+ , set_mi_trust_pkg
+ , set_mi_complete_matches
+ , set_mi_docs
+ , set_mi_final_exts
+ , set_mi_ext_fields
+ , completePartialModIface
+ , IfaceBinHandle(..)
, PartialModIface
, ModIfaceBackend (..)
, IfaceDeclExts
@@ -47,6 +105,7 @@ import GHC.Types.Fixity
import GHC.Types.Fixity.Env
import GHC.Types.HpcInfo
import GHC.Types.Name
+import GHC.Types.Name.Reader (IfGlobalRdrEnv)
import GHC.Types.SafeHaskell
import GHC.Types.SourceFile
import GHC.Types.Unique.DSet
@@ -59,7 +118,7 @@ import GHC.Utils.Binary
import Control.DeepSeq
import Control.Exception
-import GHC.Types.Name.Reader (IfGlobalRdrEnv)
+import qualified GHC.Data.Strict as Strict
{- Note [Interface file stages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -141,7 +200,17 @@ type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where
IfaceBackendExts 'ModIfaceCore = ()
IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend
-
+-- | In-memory byte array representation of a 'ModIface'.
+--
+-- See Note [Sharing of ModIface] for why we need this.
+data IfaceBinHandle (phase :: ModIfacePhase) where
+ -- | A partial 'ModIface' cannot be serialised to disk.
+ PartialIfaceBinHandle :: IfaceBinHandle 'ModIfaceCore
+ -- | Optional 'FullBinData' that can be serialised to disk directly.
+ --
+ -- See Note [Private fields in ModIface] for when this fields needs to be cleared
+ -- (e.g., set to 'Nothing').
+ FullIfaceBinHandle :: !(Strict.Maybe FullBinData) -> IfaceBinHandle 'ModIfaceFinal
-- | A 'ModIface' plus a 'ModDetails' summarises everything we know
-- about a compiled module. The 'ModIface' is the stuff *before* linking,
@@ -155,62 +224,65 @@ type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where
--
-- See Note [Strictness in ModIface] to learn about why some fields are
-- strict and others are not.
+--
+-- See Note [Private fields in ModIface] to learn why we don't export any of the
+-- fields.
data ModIface_ (phase :: ModIfacePhase)
- = ModIface {
- mi_module :: !Module, -- ^ Name of the module we are for
- mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod?
+ = PrivateModIface {
+ mi_module_ :: !Module, -- ^ Name of the module we are for
+ mi_sig_of_ :: !(Maybe Module), -- ^ Are we a sig of another mod?
- mi_hsc_src :: !HscSource, -- ^ Boot? Signature?
+ mi_hsc_src_ :: !HscSource, -- ^ Boot? Signature?
- mi_deps :: Dependencies,
+ mi_deps_ :: Dependencies,
-- ^ The dependencies of the module. This is
-- consulted for directly-imported modules, but not
-- for anything else (hence lazy)
- mi_usages :: [Usage],
+ mi_usages_ :: [Usage],
-- ^ Usages; kept sorted so that it's easy to decide
-- whether to write a new iface file (changing usages
-- doesn't affect the hash of this module)
-- NOT STRICT! we read this field lazily from the interface file
-- It is *only* consulted by the recompilation checker
- mi_exports :: ![IfaceExport],
+ mi_exports_ :: ![IfaceExport],
-- ^ Exports
-- Kept sorted by (mod,occ), to make version comparisons easier
-- Records the modules that are the declaration points for things
-- exported by this module, and the 'OccName's of those things
- mi_used_th :: !Bool,
+ mi_used_th_ :: !Bool,
-- ^ Module required TH splices when it was compiled.
-- This disables recompilation avoidance (see #481).
- mi_fixities :: [(OccName,Fixity)],
+ mi_fixities_ :: [(OccName,Fixity)],
-- ^ Fixities
-- NOT STRICT! we read this field lazily from the interface file
- mi_warns :: IfaceWarnings,
+ mi_warns_ :: IfaceWarnings,
-- ^ Warnings
-- NOT STRICT! we read this field lazily from the interface file
- mi_anns :: [IfaceAnnotation],
+ mi_anns_ :: [IfaceAnnotation],
-- ^ Annotations
-- NOT STRICT! we read this field lazily from the interface file
- mi_decls :: [IfaceDeclExts phase],
+ mi_decls_ :: [IfaceDeclExts phase],
-- ^ Type, class and variable declarations
-- The hash of an Id changes if its fixity or deprecations change
-- (as well as its type of course)
-- Ditto data constructors, class operations, except that
-- the hash of the parent class/tycon changes
- mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo],
+ mi_extra_decls_ :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo],
-- ^ Extra variable definitions which are **NOT** exposed but when
-- combined with mi_decls allows us to restart code generation.
-- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs]
- mi_top_env :: !(Maybe IfaceTopEnv),
+ mi_top_env_ :: !(Maybe IfaceTopEnv),
-- ^ Just enough information to reconstruct the top level environment in
-- the /original source/ code for this module. which
-- is NOT the same as mi_exports, nor mi_decls (which
@@ -226,36 +298,36 @@ data ModIface_ (phase :: ModIfacePhase)
-- 'HomeModInfo', but that leads to more plumbing.
-- Instance declarations and rules
- mi_insts :: [IfaceClsInst], -- ^ Sorted class instance
- mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances
- mi_rules :: [IfaceRule], -- ^ Sorted rules
+ mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance
+ mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances
+ mi_rules_ :: [IfaceRule], -- ^ Sorted rules
- mi_hpc :: !AnyHpcUsage,
+ mi_hpc_ :: !AnyHpcUsage,
-- ^ True if this program uses Hpc at any point in the program.
- mi_trust :: !IfaceTrustInfo,
+ mi_trust_ :: !IfaceTrustInfo,
-- ^ Safe Haskell Trust information for this module.
- mi_trust_pkg :: !Bool,
+ mi_trust_pkg_ :: !Bool,
-- ^ Do we require the package this module resides in be trusted
-- to trust this module? This is used for the situation where a
-- module is Safe (so doesn't require the package be trusted
-- itself) but imports some trustworthy modules from its own
-- package (which does require its own package be trusted).
-- See Note [Trust Own Package] in GHC.Rename.Names
- mi_complete_matches :: ![IfaceCompleteMatch],
+ mi_complete_matches_ :: ![IfaceCompleteMatch],
- mi_docs :: !(Maybe Docs),
+ mi_docs_ :: !(Maybe Docs),
-- ^ Docstrings and related data for use by haddock, the ghci
-- @:doc@ command, and other tools.
--
-- @Just _@ @<=>@ the module was built with @-haddock at .
- mi_final_exts :: !(IfaceBackendExts phase),
+ mi_final_exts_ :: !(IfaceBackendExts phase),
-- ^ Either `()` or `ModIfaceBackend` for
-- a fully instantiated interface.
- mi_ext_fields :: !ExtensibleFields,
+ mi_ext_fields_ :: !ExtensibleFields,
-- ^ Additional optional fields, where the Map key represents
-- the field name, resulting in a (size, serialized data) pair.
-- Because the data is intended to be serialized through the
@@ -264,8 +336,13 @@ data ModIface_ (phase :: ModIfacePhase)
-- chosen over `ByteString`s.
--
- mi_src_hash :: !Fingerprint
+ mi_src_hash_ :: !Fingerprint,
-- ^ Hash of the .hs source, used for recompilation checking.
+ mi_hi_bytes_ :: !(IfaceBinHandle phase)
+ -- ^ A serialised in-memory buffer of this 'ModIface'.
+ -- If this handle is given, we can avoid serialising the 'ModIface'
+ -- when writing this 'ModIface' to disk, and write this buffer to disk instead.
+ -- See Note [Sharing of ModIface].
}
-- Enough information to reconstruct the top level environment for a module
@@ -354,34 +431,40 @@ renameFreeHoles fhs insts =
-- See Note [Strictness in ModIface] about where we use lazyPut vs put
instance Binary ModIface where
- put_ bh (ModIface {
- mi_module = mod,
- mi_sig_of = sig_of,
- mi_hsc_src = hsc_src,
- mi_src_hash = _src_hash, -- Don't `put_` this in the instance
+ put_ bh (PrivateModIface {
+ mi_module_ = mod,
+ mi_sig_of_ = sig_of,
+ mi_hsc_src_ = hsc_src,
+ mi_src_hash_ = _src_hash, -- Don't `put_` this in the instance
-- because we are going to write it
-- out separately in the actual file
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_used_th = used_th,
- mi_fixities = fixities,
- mi_warns = warns,
- mi_anns = anns,
- mi_decls = decls,
- mi_extra_decls = extra_decls,
- mi_insts = insts,
- mi_fam_insts = fam_insts,
- mi_rules = rules,
- mi_hpc = hpc_info,
- mi_trust = trust,
- mi_trust_pkg = trust_pkg,
- mi_complete_matches = complete_matches,
- mi_docs = docs,
- mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we
+ mi_hi_bytes_ = _hi_bytes, -- We don't serialise the 'mi_hi_bytes_', as it itself
+ -- may contain an in-memory byte array buffer for this
+ -- 'ModIface'. If we used 'put_' on this 'ModIface', then
+ -- we likely have a good reason, and do not want to reuse
+ -- the byte array.
+ -- See Note [Private fields in ModIface]
+ mi_deps_ = deps,
+ mi_usages_ = usages,
+ mi_exports_ = exports,
+ mi_used_th_ = used_th,
+ mi_fixities_ = fixities,
+ mi_warns_ = warns,
+ mi_anns_ = anns,
+ mi_decls_ = decls,
+ mi_extra_decls_ = extra_decls,
+ mi_insts_ = insts,
+ mi_fam_insts_ = fam_insts,
+ mi_rules_ = rules,
+ mi_hpc_ = hpc_info,
+ mi_trust_ = trust,
+ mi_trust_pkg_ = trust_pkg,
+ mi_complete_matches_ = complete_matches,
+ mi_docs_ = docs,
+ mi_ext_fields_ = _ext_fields, -- Don't `put_` this in the instance so we
-- can deal with it's pointer in the header
-- when we write the actual file
- mi_final_exts = ModIfaceBackend {
+ mi_final_exts_ = ModIfaceBackend {
mi_iface_hash = iface_hash,
mi_mod_hash = mod_hash,
mi_flag_hash = flag_hash,
@@ -455,34 +538,39 @@ instance Binary ModIface where
trust_pkg <- get bh
complete_matches <- get bh
docs <- lazyGetMaybe bh
- return (ModIface {
- mi_module = mod,
- mi_sig_of = sig_of,
- mi_hsc_src = hsc_src,
- mi_src_hash = fingerprint0, -- placeholder because this is dealt
+ return (PrivateModIface {
+ mi_module_ = mod,
+ mi_sig_of_ = sig_of,
+ mi_hsc_src_ = hsc_src,
+ mi_src_hash_ = fingerprint0, -- placeholder because this is dealt
-- with specially when the file is read
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_used_th = used_th,
- mi_anns = anns,
- mi_fixities = fixities,
- mi_warns = warns,
- mi_decls = decls,
- mi_extra_decls = extra_decls,
- mi_top_env = Nothing,
- mi_insts = insts,
- mi_fam_insts = fam_insts,
- mi_rules = rules,
- mi_hpc = hpc_info,
- mi_trust = trust,
- mi_trust_pkg = trust_pkg,
+ mi_hi_bytes_ =
+ -- We can't populate this field here, as we are
+ -- missing the 'mi_ext_fields_' field, which is
+ -- handled in 'getIfaceWithExtFields'.
+ FullIfaceBinHandle Strict.Nothing,
+ mi_deps_ = deps,
+ mi_usages_ = usages,
+ mi_exports_ = exports,
+ mi_used_th_ = used_th,
+ mi_anns_ = anns,
+ mi_fixities_ = fixities,
+ mi_warns_ = warns,
+ mi_decls_ = decls,
+ mi_extra_decls_ = extra_decls,
+ mi_top_env_ = Nothing,
+ mi_insts_ = insts,
+ mi_fam_insts_ = fam_insts,
+ mi_rules_ = rules,
+ mi_hpc_ = hpc_info,
+ mi_trust_ = trust,
+ mi_trust_pkg_ = trust_pkg,
-- And build the cached values
- mi_complete_matches = complete_matches,
- mi_docs = docs,
- mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt
+ mi_complete_matches_ = complete_matches,
+ mi_docs_ = docs,
+ mi_ext_fields_ = emptyExtensibleFields, -- placeholder because this is dealt
-- with specially when the file is read
- mi_final_exts = ModIfaceBackend {
+ mi_final_exts_ = ModIfaceBackend {
mi_iface_hash = iface_hash,
mi_mod_hash = mod_hash,
mi_flag_hash = flag_hash,
@@ -499,42 +587,46 @@ instance Binary ModIface where
mi_hash_fn = mkIfaceHashCache decls
}})
+
-- | The original names declared of a certain module that are exported
type IfaceExport = AvailInfo
emptyPartialModIface :: Module -> PartialModIface
emptyPartialModIface mod
- = ModIface { mi_module = mod,
- mi_sig_of = Nothing,
- mi_hsc_src = HsSrcFile,
- mi_src_hash = fingerprint0,
- mi_deps = noDependencies,
- mi_usages = [],
- mi_exports = [],
- mi_used_th = False,
- mi_fixities = [],
- mi_warns = IfWarnSome [] [],
- mi_anns = [],
- mi_insts = [],
- mi_fam_insts = [],
- mi_rules = [],
- mi_decls = [],
- mi_extra_decls = Nothing,
- mi_top_env = Nothing,
- mi_hpc = False,
- mi_trust = noIfaceTrustInfo,
- mi_trust_pkg = False,
- mi_complete_matches = [],
- mi_docs = Nothing,
- mi_final_exts = (),
- mi_ext_fields = emptyExtensibleFields
- }
+ = PrivateModIface
+ { mi_module_ = mod,
+ mi_sig_of_ = Nothing,
+ mi_hsc_src_ = HsSrcFile,
+ mi_src_hash_ = fingerprint0,
+ mi_hi_bytes_ = PartialIfaceBinHandle,
+ mi_deps_ = noDependencies,
+ mi_usages_ = [],
+ mi_exports_ = [],
+ mi_used_th_ = False,
+ mi_fixities_ = [],
+ mi_warns_ = IfWarnSome [] [],
+ mi_anns_ = [],
+ mi_insts_ = [],
+ mi_fam_insts_ = [],
+ mi_rules_ = [],
+ mi_decls_ = [],
+ mi_extra_decls_ = Nothing,
+ mi_top_env_ = Nothing,
+ mi_hpc_ = False,
+ mi_trust_ = noIfaceTrustInfo,
+ mi_trust_pkg_ = False,
+ mi_complete_matches_ = [],
+ mi_docs_ = Nothing,
+ mi_final_exts_ = (),
+ mi_ext_fields_ = emptyExtensibleFields
+ }
emptyFullModIface :: Module -> ModIface
emptyFullModIface mod =
(emptyPartialModIface mod)
- { mi_decls = []
- , mi_final_exts = ModIfaceBackend
+ { mi_decls_ = []
+ , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing
+ , mi_final_exts_ = ModIfaceBackend
{ mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_hash = fingerprint0,
@@ -569,36 +661,38 @@ emptyIfaceHashCache _occ = Nothing
instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
, NFData (IfaceDeclExts (phase :: ModIfacePhase))
) => NFData (ModIface_ phase) where
- rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages
- , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns
- , mi_decls, mi_extra_decls, mi_top_env, mi_insts
- , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg
- , mi_complete_matches, mi_docs, mi_final_exts
- , mi_ext_fields, mi_src_hash })
- = rnf mi_module
- `seq` rnf mi_sig_of
- `seq` mi_hsc_src
- `seq` mi_deps
- `seq` mi_usages
- `seq` mi_exports
- `seq` rnf mi_used_th
- `seq` mi_fixities
- `seq` rnf mi_warns
- `seq` rnf mi_anns
- `seq` rnf mi_decls
- `seq` rnf mi_extra_decls
- `seq` rnf mi_top_env
- `seq` rnf mi_insts
- `seq` rnf mi_fam_insts
- `seq` rnf mi_rules
- `seq` rnf mi_hpc
- `seq` mi_trust
- `seq` rnf mi_trust_pkg
- `seq` rnf mi_complete_matches
- `seq` rnf mi_docs
- `seq` mi_final_exts
- `seq` mi_ext_fields
- `seq` rnf mi_src_hash
+ rnf (PrivateModIface
+ { mi_module_, mi_sig_of_, mi_hsc_src_, mi_hi_bytes_, mi_deps_, mi_usages_
+ , mi_exports_, mi_used_th_, mi_fixities_, mi_warns_, mi_anns_
+ , mi_decls_, mi_extra_decls_, mi_top_env_, mi_insts_
+ , mi_fam_insts_, mi_rules_, mi_hpc_, mi_trust_, mi_trust_pkg_
+ , mi_complete_matches_, mi_docs_, mi_final_exts_
+ , mi_ext_fields_, mi_src_hash_ })
+ = rnf mi_module_
+ `seq` rnf mi_sig_of_
+ `seq` mi_hsc_src_
+ `seq` mi_hi_bytes_
+ `seq` mi_deps_
+ `seq` mi_usages_
+ `seq` mi_exports_
+ `seq` rnf mi_used_th_
+ `seq` mi_fixities_
+ `seq` rnf mi_warns_
+ `seq` rnf mi_anns_
+ `seq` rnf mi_decls_
+ `seq` rnf mi_extra_decls_
+ `seq` rnf mi_top_env_
+ `seq` rnf mi_insts_
+ `seq` rnf mi_fam_insts_
+ `seq` rnf mi_rules_
+ `seq` rnf mi_hpc_
+ `seq` mi_trust_
+ `seq` rnf mi_trust_pkg_
+ `seq` rnf mi_complete_matches_
+ `seq` rnf mi_docs_
+ `seq` mi_final_exts_
+ `seq` mi_ext_fields_
+ `seq` rnf mi_src_hash_
`seq` ()
instance NFData (ModIfaceBackend) where
@@ -638,5 +732,286 @@ type WhetherHasOrphans = Bool
-- | Does this module define family instances?
type WhetherHasFamInst = Bool
+-- ----------------------------------------------------------------------------
+-- Modify a 'ModIface'.
+-- ----------------------------------------------------------------------------
+
+{-
+Note [Private fields in ModIface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The fields of 'ModIface' are private, e.g., not exported, to make the API
+impossible to misuse. A 'ModIface' can be "compressed" in-memory using
+'shareIface', which serialises the 'ModIface' to an in-memory buffer.
+This has the advantage of reducing memory usage of 'ModIface', reducing the
+overall memory usage of GHC.
+See Note [Sharing of ModIface].
+
+This in-memory buffer can be reused, if and only if the 'ModIface' is not
+modified after it has been "compressed"/shared via 'shareIface'. Instead of
+serialising 'ModIface', we simply write the in-memory buffer to disk directly.
+
+However, we can't rely that a 'ModIface' isn't modified after 'shareIface' has
+been called. Thus, we make all fields of 'ModIface' private and modification
+only happens via exported update functions, such as 'set_mi_decls'.
+These functions unconditionally clear any in-memory buffer if used, forcing us
+to serialise the 'ModIface' to disk again.
+-}
+
+-- | Given a 'PartialModIface', turn it into a 'ModIface' by completing
+-- missing fields.
+completePartialModIface :: PartialModIface
+ -> [(Fingerprint, IfaceDecl)]
+ -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
+ -> ModIfaceBackend
+ -> ModIface
+completePartialModIface partial decls extra_decls final_exts = partial
+ { mi_decls_ = decls
+ , mi_extra_decls_ = extra_decls
+ , mi_final_exts_ = final_exts
+ , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing
+ }
+
+-- | Add a source fingerprint to a 'ModIface_' without invalidating the byte array
+-- buffer 'mi_hi_bytes'.
+-- This is a variant of 'set_mi_src_hash' which does invalidate the buffer.
+--
+-- The 'mi_src_hash' is computed outside of 'ModIface_' based on the 'ModSummary'.
+addSourceFingerprint :: Fingerprint -> ModIface_ phase -> ModIface_ phase
+addSourceFingerprint val iface = iface { mi_src_hash_ = val }
+
+-- | Copy fields that aren't serialised to disk to the new 'ModIface_'.
+-- This includes especially hashes that are usually stored in the interface
+-- file header and 'mi_top_env'.
+--
+-- We need this function after calling 'shareIface', to make sure the
+-- 'ModIface_' doesn't lose any information. This function does not discard
+-- the in-memory byte array buffer 'mi_hi_bytes'.
+restoreFromOldModIface :: ModIface_ phase -> ModIface_ phase -> ModIface_ phase
+restoreFromOldModIface old new = new
+ { mi_top_env_ = mi_top_env_ old
+ , mi_hsc_src_ = mi_hsc_src_ old
+ , mi_src_hash_ = mi_src_hash_ old
+ }
+
+set_mi_module :: Module -> ModIface_ phase -> ModIface_ phase
+set_mi_module val iface = clear_mi_hi_bytes $ iface { mi_module_ = val }
+
+set_mi_sig_of :: Maybe Module -> ModIface_ phase -> ModIface_ phase
+set_mi_sig_of val iface = clear_mi_hi_bytes $ iface { mi_sig_of_ = val }
+
+set_mi_hsc_src :: HscSource -> ModIface_ phase -> ModIface_ phase
+set_mi_hsc_src val iface = clear_mi_hi_bytes $ iface { mi_hsc_src_ = val }
+
+set_mi_src_hash :: Fingerprint -> ModIface_ phase -> ModIface_ phase
+set_mi_src_hash val iface = clear_mi_hi_bytes $ iface { mi_src_hash_ = val }
+
+set_mi_hi_bytes :: IfaceBinHandle phase -> ModIface_ phase -> ModIface_ phase
+set_mi_hi_bytes val iface = iface { mi_hi_bytes_ = val }
+
+set_mi_deps :: Dependencies -> ModIface_ phase -> ModIface_ phase
+set_mi_deps val iface = clear_mi_hi_bytes $ iface { mi_deps_ = val }
+
+set_mi_usages :: [Usage] -> ModIface_ phase -> ModIface_ phase
+set_mi_usages val iface = clear_mi_hi_bytes $ iface { mi_usages_ = val }
+set_mi_exports :: [IfaceExport] -> ModIface_ phase -> ModIface_ phase
+set_mi_exports val iface = clear_mi_hi_bytes $ iface { mi_exports_ = val }
+
+set_mi_used_th :: Bool -> ModIface_ phase -> ModIface_ phase
+set_mi_used_th val iface = clear_mi_hi_bytes $ iface { mi_used_th_ = val }
+
+set_mi_fixities :: [(OccName, Fixity)] -> ModIface_ phase -> ModIface_ phase
+set_mi_fixities val iface = clear_mi_hi_bytes $ iface { mi_fixities_ = val }
+
+set_mi_warns :: IfaceWarnings -> ModIface_ phase -> ModIface_ phase
+set_mi_warns val iface = clear_mi_hi_bytes $ iface { mi_warns_ = val }
+
+set_mi_anns :: [IfaceAnnotation] -> ModIface_ phase -> ModIface_ phase
+set_mi_anns val iface = clear_mi_hi_bytes $ iface { mi_anns_ = val }
+
+set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase
+set_mi_insts val iface = clear_mi_hi_bytes $ iface { mi_insts_ = val }
+
+set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase
+set_mi_fam_insts val iface = clear_mi_hi_bytes $ iface { mi_fam_insts_ = val }
+
+set_mi_rules :: [IfaceRule] -> ModIface_ phase -> ModIface_ phase
+set_mi_rules val iface = clear_mi_hi_bytes $ iface { mi_rules_ = val }
+
+set_mi_decls :: [IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase
+set_mi_decls val iface = clear_mi_hi_bytes $ iface { mi_decls_ = val }
+
+set_mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> ModIface_ phase -> ModIface_ phase
+set_mi_extra_decls val iface = clear_mi_hi_bytes $ iface { mi_extra_decls_ = val }
+
+set_mi_top_env :: Maybe IfaceTopEnv -> ModIface_ phase -> ModIface_ phase
+set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val }
+
+set_mi_hpc :: AnyHpcUsage -> ModIface_ phase -> ModIface_ phase
+set_mi_hpc val iface = clear_mi_hi_bytes $ iface { mi_hpc_ = val }
+
+set_mi_trust :: IfaceTrustInfo -> ModIface_ phase -> ModIface_ phase
+set_mi_trust val iface = clear_mi_hi_bytes $ iface { mi_trust_ = val }
+
+set_mi_trust_pkg :: Bool -> ModIface_ phase -> ModIface_ phase
+set_mi_trust_pkg val iface = clear_mi_hi_bytes $ iface { mi_trust_pkg_ = val }
+
+set_mi_complete_matches :: [IfaceCompleteMatch] -> ModIface_ phase -> ModIface_ phase
+set_mi_complete_matches val iface = clear_mi_hi_bytes $ iface { mi_complete_matches_ = val }
+
+set_mi_docs :: Maybe Docs -> ModIface_ phase -> ModIface_ phase
+set_mi_docs val iface = clear_mi_hi_bytes $ iface { mi_docs_ = val }
+
+set_mi_final_exts :: IfaceBackendExts phase -> ModIface_ phase -> ModIface_ phase
+set_mi_final_exts val iface = clear_mi_hi_bytes $ iface { mi_final_exts_ = val }
+
+set_mi_ext_fields :: ExtensibleFields -> ModIface_ phase -> ModIface_ phase
+set_mi_ext_fields val iface = clear_mi_hi_bytes $ iface { mi_ext_fields_ = val }
+
+-- | Invalidate any byte array buffer we might have.
+clear_mi_hi_bytes :: ModIface_ phase -> ModIface_ phase
+clear_mi_hi_bytes iface = iface
+ { mi_hi_bytes_ = case mi_hi_bytes iface of
+ PartialIfaceBinHandle -> PartialIfaceBinHandle
+ FullIfaceBinHandle _ -> FullIfaceBinHandle Strict.Nothing
+ }
+
+-- ----------------------------------------------------------------------------
+-- 'ModIface' pattern synonyms to keep breakage low.
+-- ----------------------------------------------------------------------------
+
+{-
+Note [Inline Pattern synonym of ModIface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The introduction of the 'ModIface' pattern synonym originally caused an increase
+in allocated bytes in multiple performance tests.
+In some benchmarks, it was a 2~3% increase.
+
+Without {-# INLINE ModIface #-}, the generated core reveals the reason for this increase.
+We show the core for the 'mi_module' record selector:
+
+@
+ mi_module
+ = \ @phase iface -> $w$mModIface iface mi_module1
+
+ $w$mModIface
+ = \ @phase iface cont ->
+ case iface of
+ { PrivateModIface a b ... z ->
+ cont
+ a
+ b
+ ...
+ z
+ }
+
+ mi_module1
+ = \ @phase
+ a
+ _
+ ...
+ _ ->
+ a
+@
+
+Thus, we can see the '$w$mModIface' is not inlined, leading to an increase in
+the allocated bytes.
+
+However, with the pragma, the correct core is generated:
+
+@
+ mi_module = mi_module_
+@
+
+-}
+-- See Note [Inline Pattern synonym of ModIface] for why we have all these
+-- inline pragmas.
+{-# INLINE ModIface #-}
+{-# INLINE mi_module #-}
+{-# INLINE mi_sig_of #-}
+{-# INLINE mi_hsc_src #-}
+{-# INLINE mi_deps #-}
+{-# INLINE mi_usages #-}
+{-# INLINE mi_exports #-}
+{-# INLINE mi_used_th #-}
+{-# INLINE mi_fixities #-}
+{-# INLINE mi_warns #-}
+{-# INLINE mi_anns #-}
+{-# INLINE mi_decls #-}
+{-# INLINE mi_extra_decls #-}
+{-# INLINE mi_top_env #-}
+{-# INLINE mi_insts #-}
+{-# INLINE mi_fam_insts #-}
+{-# INLINE mi_rules #-}
+{-# INLINE mi_hpc #-}
+{-# INLINE mi_trust #-}
+{-# INLINE mi_trust_pkg #-}
+{-# INLINE mi_complete_matches #-}
+{-# INLINE mi_docs #-}
+{-# INLINE mi_final_exts #-}
+{-# INLINE mi_ext_fields #-}
+{-# INLINE mi_src_hash #-}
+{-# INLINE mi_hi_bytes #-}
+
+pattern ModIface ::
+ Module -> Maybe Module -> HscSource -> Dependencies -> [Usage] ->
+ [IfaceExport] -> Bool -> [(OccName, Fixity)] -> IfaceWarnings ->
+ [IfaceAnnotation] -> [IfaceDeclExts phase] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] ->
+ Maybe IfaceTopEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] ->
+ AnyHpcUsage -> IfaceTrustInfo -> Bool -> [IfaceCompleteMatch] -> Maybe Docs ->
+ IfaceBackendExts phase -> ExtensibleFields -> Fingerprint -> IfaceBinHandle phase ->
+ ModIface_ phase
+pattern ModIface
+ { mi_module
+ , mi_sig_of
+ , mi_hsc_src
+ , mi_deps
+ , mi_usages
+ , mi_exports
+ , mi_used_th
+ , mi_fixities
+ , mi_warns
+ , mi_anns
+ , mi_decls
+ , mi_extra_decls
+ , mi_top_env
+ , mi_insts
+ , mi_fam_insts
+ , mi_rules
+ , mi_hpc
+ , mi_trust
+ , mi_trust_pkg
+ , mi_complete_matches
+ , mi_docs
+ , mi_final_exts
+ , mi_ext_fields
+ , mi_src_hash
+ , mi_hi_bytes
+ } <- PrivateModIface
+ { mi_module_ = mi_module
+ , mi_sig_of_ = mi_sig_of
+ , mi_hsc_src_ = mi_hsc_src
+ , mi_deps_ = mi_deps
+ , mi_usages_ = mi_usages
+ , mi_exports_ = mi_exports
+ , mi_used_th_ = mi_used_th
+ , mi_fixities_ = mi_fixities
+ , mi_warns_ = mi_warns
+ , mi_anns_ = mi_anns
+ , mi_decls_ = mi_decls
+ , mi_extra_decls_ = mi_extra_decls
+ , mi_top_env_ = mi_top_env
+ , mi_insts_ = mi_insts
+ , mi_fam_insts_ = mi_fam_insts
+ , mi_rules_ = mi_rules
+ , mi_hpc_ = mi_hpc
+ , mi_trust_ = mi_trust
+ , mi_trust_pkg_ = mi_trust_pkg
+ , mi_complete_matches_ = mi_complete_matches
+ , mi_docs_ = mi_docs
+ , mi_final_exts_ = mi_final_exts
+ , mi_ext_fields_ = mi_ext_fields
+ , mi_src_hash_ = mi_src_hash
+ , mi_hi_bytes_ = mi_hi_bytes
+ }
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -19,7 +19,7 @@
-- http://www.cs.york.ac.uk/fp/nhc98/
module GHC.Utils.Binary
- ( {-type-} Bin,
+ ( {-type-} Bin, RelBin(..), getRelBin,
{-class-} Binary(..),
{-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
@@ -32,10 +32,14 @@ module GHC.Utils.Binary
seekBinWriter,
seekBinReader,
+ seekBinReaderRel,
tellBinReader,
tellBinWriter,
castBin,
withBinBuffer,
+ freezeWriteHandle,
+ shrinkBinBuffer,
+ thawReadHandle,
foldGet, foldGet',
@@ -44,7 +48,9 @@ module GHC.Utils.Binary
readBinMemN,
putAt, getAt,
+ putAtRel,
forwardPut, forwardPut_, forwardGet,
+ forwardPutRel, forwardPutRel_, forwardGetRel,
-- * For writing instances
putByte,
@@ -99,6 +105,8 @@ module GHC.Utils.Binary
BindingName(..),
simpleBindingNameWriter,
simpleBindingNameReader,
+ FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData,
+ BinArray,
) where
import GHC.Prelude
@@ -107,6 +115,7 @@ import Language.Haskell.Syntax.Module.Name (ModuleName(..))
import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
+import GHC.Data.TrieMap
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
@@ -115,7 +124,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
-import GHC.Utils.Misc ( HasCallStack, HasDebugCallStack )
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -123,7 +131,7 @@ import Foreign hiding (shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
-import Data.ByteString (ByteString)
+import Data.ByteString (ByteString, copy)
import Data.Coerce
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
@@ -152,8 +160,6 @@ import GHC.ForeignPtr ( unsafeWithForeignPtr )
import Unsafe.Coerce (unsafeCoerce)
-import GHC.Data.TrieMap
-
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -193,6 +199,62 @@ dataHandle (BinData size bin) = do
handleData :: WriteBinHandle -> IO BinData
handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+---------------------------------------------------------------
+-- FullBinData
+---------------------------------------------------------------
+
+-- | 'FullBinData' stores a slice to a 'BinArray'.
+--
+-- It requires less memory than 'ReadBinHandle', and can be constructed from
+-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a
+-- 'ReadBinHandle' using 'thawBinHandle'.
+-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra
+-- conversions via 'putFullBinData'.
+data FullBinData = FullBinData
+ { fbd_readerUserData :: ReaderUserData
+ -- ^ 'ReaderUserData' that can be used to resume reading.
+ , fbd_off_s :: {-# UNPACK #-} !Int
+ -- ^ start offset
+ , fbd_off_e :: {-# UNPACK #-} !Int
+ -- ^ end offset
+ , fbd_size :: {-# UNPACK #-} !Int
+ -- ^ total buffer size
+ , fbd_buffer :: {-# UNPACK #-} !BinArray
+ }
+
+-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things.
+instance Eq FullBinData where
+ (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1
+
+instance Ord FullBinData where
+ compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) =
+ compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1
+
+-- | Write the 'FullBinData' slice into the 'WriteBinHandle'.
+putFullBinData :: WriteBinHandle -> FullBinData -> IO ()
+putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do
+ let sz = o2 - o1
+ putPrim bh sz $ \dest ->
+ unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig ->
+ copyBytes dest orig sz
+
+-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'.
+--
+-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current
+-- offset of the 'ReadBinHandle'.
+freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData
+freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do
+ ix <- readFastMutInt ixr
+ pure (FullBinData user_data start ix sz binr)
+
+-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle'
+-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was
+-- obtained from 'freezeBinHandle'.
+thawBinHandle :: FullBinData -> IO ReadBinHandle
+thawBinHandle (FullBinData user_data ix _end sz ba) = do
+ ixr <- newFastMutInt ix
+ return $ ReadBinMem user_data ixr sz ba
+
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
@@ -286,9 +348,47 @@ unsafeUnpackBinBuffer (BS.BS arr len) = do
newtype Bin a = BinPtr Int
deriving (Eq, Ord, Show, Bounded)
+-- | Like a 'Bin' but is used to store relative offset pointers.
+-- Relative offset pointers store a relative location, but also contain an
+-- anchor that allow to obtain the absolute offset.
+data RelBin a = RelBin
+ { relBin_anchor :: {-# UNPACK #-} !(Bin a)
+ -- ^ Absolute position from where we read 'relBin_offset'.
+ , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a)
+ -- ^ Relative offset to 'relBin_anchor'.
+ -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@
+ }
+ deriving (Eq, Ord, Show, Bounded)
+
+-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer
+-- instead of an absolute offset.
+newtype RelBinPtr a = RelBinPtr (Bin a)
+ deriving (Eq, Ord, Show, Bounded)
+
castBin :: Bin a -> Bin b
castBin (BinPtr i) = BinPtr i
+-- | Read a relative offset location and wrap it in 'RelBin'.
+--
+-- The resulting 'RelBin' can be translated into an absolute offset location using
+-- 'makeAbsoluteBin'
+getRelBin :: ReadBinHandle -> IO (RelBin a)
+getRelBin bh = do
+ start <- tellBinReader bh
+ off <- get bh
+ pure $ RelBin start off
+
+makeAbsoluteBin :: RelBin a -> Bin a
+makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) =
+ BinPtr $ start + offset
+
+makeRelativeBin :: RelBin a -> RelBinPtr a
+makeRelativeBin (RelBin _ offset) = offset
+
+toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a
+toRelBin (BinPtr !start) (BinPtr !goal) =
+ RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start)
+
---------------------------------------------------------------
-- class Binary
---------------------------------------------------------------
@@ -309,6 +409,9 @@ class Binary a where
putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()
putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()
+putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO ()
+putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to)
+
getAt :: Binary a => ReadBinHandle -> Bin a -> IO a
getAt bh p = do seekBinReader bh p; get bh
@@ -327,6 +430,44 @@ openBinMem size
, wbm_arr_r = arr_r
}
+-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'.
+--
+-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'.
+freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle
+freezeWriteHandle wbm = do
+ rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm)
+ rbm_sz_r <- readFastMutInt (wbm_sz_r wbm)
+ rbm_arr_r <- readIORef (wbm_arr_r wbm)
+ pure $ ReadBinMem
+ { rbm_userData = noReaderUserData
+ , rbm_off_r = rbm_off_r
+ , rbm_sz_r = rbm_sz_r
+ , rbm_arr_r = rbm_arr_r
+ }
+
+-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size.
+-- This performs a copy of the underlying buffer.
+-- The buffer may be truncated if the offset is not at the end of the written
+-- output.
+--
+-- UserData is also discarded during the copy
+-- You should just use this when translating a Put handle into a Get handle.
+shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle
+shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do
+ unsafeUnpackBinBuffer (copy bs)
+
+thawReadHandle :: ReadBinHandle -> IO WriteBinHandle
+thawReadHandle rbm = do
+ wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm)
+ wbm_sz_r <- newFastMutInt (rbm_sz_r rbm)
+ wbm_arr_r <- newIORef (rbm_arr_r rbm)
+ pure $ WriteBinMem
+ { wbm_userData = noWriterUserData
+ , wbm_off_r = wbm_off_r
+ , wbm_sz_r = wbm_sz_r
+ , wbm_arr_r = wbm_arr_r
+ }
+
tellBinWriter :: WriteBinHandle -> IO (Bin a)
tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
@@ -358,6 +499,13 @@ seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do
then panic "seekBinReader: seek out of range"
else writeFastMutInt ix_r p
+seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO ()
+seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do
+ let (BinPtr !p) = makeAbsoluteBin relBin
+ if (p > sz_r)
+ then panic "seekBinReaderRel: 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
@@ -1078,12 +1226,17 @@ instance Binary (Bin a) where
put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)
get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))
+-- Instance uses fixed-width encoding to allow inserting
+-- Bin placeholders in the stream.
+instance Binary (RelBinPtr a) where
+ put_ bh (RelBinPtr i) = put_ bh i
+ get bh = RelBinPtr <$> get bh
-- -----------------------------------------------------------------------------
-- Forward reading/writing
--- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B
--- by using a forward reference
+-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B
+-- by using a forward reference.
forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut bh put_A put_B = do
-- write placeholder pointer to A
@@ -1106,6 +1259,8 @@ 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
+--
+-- The forward reference is expected to be an absolute offset.
forwardGet :: ReadBinHandle -> IO a -> IO a
forwardGet bh get_A = do
-- read forward reference
@@ -1118,6 +1273,48 @@ forwardGet bh get_A = do
seekBinReader bh p_a
pure r
+-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B
+-- by using a forward reference.
+--
+-- This forward reference is a relative offset that allows us to skip over the
+-- result of 'put_A'.
+forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
+forwardPutRel bh put_A put_B = do
+ -- write placeholder pointer to A
+ pre_a <- tellBinWriter bh
+ put_ bh pre_a
+
+ -- write B
+ r_b <- put_B
+
+ -- update A's pointer
+ a <- tellBinWriter bh
+ putAtRel bh pre_a a
+ seekBinNoExpandWriter bh a
+
+ -- write A
+ r_a <- put_A r_b
+ pure (r_a,r_b)
+
+-- | Like 'forwardGetRel', but discard the result.
+forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
+forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B
+
+-- | Read a value stored using a forward reference.
+--
+-- The forward reference is expected to be a relative offset.
+forwardGetRel :: ReadBinHandle -> IO a -> IO a
+forwardGetRel bh get_A = do
+ -- read forward reference
+ p <- getRelBin bh
+ -- store current position
+ p_a <- tellBinReader bh
+ -- go read the forward value, then seek back
+ seekBinReader bh $ makeAbsoluteBin p
+ r <- get_A
+ seekBinReader bh p_a
+ pure r
+
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
@@ -1127,19 +1324,19 @@ lazyPut = lazyPut' put_
lazyGet :: Binary a => ReadBinHandle -> IO a
lazyGet = lazyGet' get
-lazyPut' :: HasDebugCallStack => (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
+lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
lazyPut' f bh a = do
-- output the obj with a ptr to skip over it:
pre_a <- tellBinWriter bh
put_ bh pre_a -- save a slot for the ptr
f bh a -- dump the object
q <- tellBinWriter bh -- q = ptr to after object
- putAt bh pre_a q -- fill in slot before a with ptr to q
+ putAtRel bh pre_a q -- fill in slot before a with ptr to q
seekBinWriter bh q -- finally carry on writing at q
-lazyGet' :: HasDebugCallStack => (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
+lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
lazyGet' f bh = do
- p <- get bh -- a BinPtr
+ p <- getRelBin bh -- a BinPtr
p_a <- tellBinReader bh
a <- unsafeInterleaveIO $ do
-- NB: Use a fresh rbm_off_r variable in the child thread, for thread
@@ -1148,7 +1345,7 @@ lazyGet' f bh = do
let bh' = bh { rbm_off_r = off_r }
seekBinReader bh' p_a
f bh'
- seekBinReader bh p -- skip over the object for now
+ seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now
return a
-- | Serialize the constructor strictly but lazily serialize a value inside a
@@ -1284,7 +1481,7 @@ mkReader f = BinaryReader
-- | 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 :: forall a . 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)
@@ -1306,7 +1503,7 @@ findUserDataReader query bh =
-- | 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 :: forall a . 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)
@@ -1442,13 +1639,13 @@ putGenericSymbolTable gen_sym_tab serialiser bh = do
mapM_ (\n -> serialiser bh n) (reverse todo)
loop
snd <$>
- (forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
+ (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $
loop)
-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'.
getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
getGenericSymbolTable deserialiser bh = do
- sz <- forwardGet bh (get bh) :: IO Int
+ sz <- forwardGetRel bh (get bh) :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
forM_ [0..(sz-1)] $ \i -> do
f <- deserialiser bh
=====================================
hadrian/src/Settings/Builders/Configure.hs
=====================================
@@ -15,16 +15,23 @@ configureBuilderArgs = do
targetPlatform <- queryTarget targetPlatformTriple
buildPlatform <- queryBuild targetPlatformTriple
pure $ [ "--enable-shared=no"
- , "--with-pic=yes"
, "--host=" ++ targetPlatform -- GMP's host is our target
, "--build=" ++ buildPlatform ]
+ -- Disable FFT logic on wasm32, sacrifice
+ -- performance of multiplying very large operands
+ -- to save code size
+ <> [ "--disable-fft" | targetArch == "wasm32" ]
-- Disable GMP's alloca usage on wasm32, it may
-- cause stack overflow (#22602) due to the
-- rather small 64KB default stack size. See
-- https://gmplib.org/manual/Build-Options for
-- more detailed explanation of this configure
-- option.
- <> [ "--enable-alloca=malloc-reentrant" | targetArch == "wasm32" ]
+ <> [ "--enable-alloca=malloc-notreentrant" | targetArch == "wasm32" ]
+ -- Enable PIC unless target is wasm32, in which
+ -- case we don't want libgmp.a to be bloated due
+ -- to PIC overhead.
+ <> [ "--with-pic=yes" | targetArch /= "wasm32" ]
, builder (Configure libffiPath) ? do
top <- expr topDirectory
=====================================
testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
=====================================
@@ -64,9 +64,10 @@ metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan BlankEpAnnotation
interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadPlugin' [name, "interface"] iface
- = return $ iface { mi_exports = filter (availNotNamedAs name)
- (mi_exports iface)
- }
+ = return $ set_mi_exports (filter (availNotNamedAs name)
+ (mi_exports iface))
+ iface
+
interfaceLoadPlugin' _ iface = return iface
availNotNamedAs :: String -> AvailInfo -> Bool
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -56,7 +56,7 @@ import GHC.Types.Unique.FM
import GHC.Unit.State
import GHC.Utils.Binary
-import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import GHC.Iface.Type (IfaceType, putIfaceType)
import Haddock.Options (Visibility (..))
@@ -200,7 +200,7 @@ writeInterfaceFile filename iface = do
-- write the iface type pointer at the front of the file
ifacetype_p <- tellBinWriter bh
- putAt bh ifacetype_p_p ifacetype_p
+ putAtRel bh ifacetype_p_p ifacetype_p
seekBinWriter bh ifacetype_p
-- write the symbol table itself
@@ -208,7 +208,7 @@ writeInterfaceFile filename iface = do
-- write the symtab pointer at the front of the file
symtab_p <- tellBinWriter bh
- putAt bh symtab_p_p symtab_p
+ putAtRel bh symtab_p_p symtab_p
seekBinWriter bh symtab_p
-- write the symbol table itself
@@ -218,7 +218,7 @@ writeInterfaceFile filename iface = do
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBinWriter bh
- putAt bh dict_p_p dict_p
+ putAtRel bh dict_p_p dict_p
seekBinWriter bh dict_p
-- write the dictionary itself
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/534c895517a4a1390a815084ed540d87bc0e384e...6304030eacb0bd3acab5f8589dd25e3f286c65d9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/534c895517a4a1390a815084ed540d87bc0e384e...6304030eacb0bd3acab5f8589dd25e3f286c65d9
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/20240602/7859da7b/attachment-0001.html>
More information about the ghc-commits
mailing list