Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • ghc/ghc
  • bgamari/ghc
  • syd/ghc
  • ggreif/ghc
  • watashi/ghc
  • RolandSenn/ghc
  • mpickering/ghc
  • DavidEichmann/ghc
  • carter/ghc
  • harpocrates/ghc
  • ethercrow/ghc
  • mijicd/ghc
  • adamse/ghc
  • alexbiehl/ghc
  • gridaphobe/ghc
  • trofi/ghc
  • supersven/ghc
  • ppk/ghc
  • ulysses4ever/ghc
  • AndreasK/ghc
  • ghuntley/ghc
  • shayne-fletcher-da/ghc
  • fgaz/ghc
  • yav/ghc
  • osa1/ghc
  • mbbx6spp/ghc
  • JulianLeviston/ghc
  • reactormonk/ghc
  • rae/ghc
  • takenobu-hs/ghc
  • michalt/ghc
  • andrewthad/ghc
  • hsyl20/ghc
  • scottgw/ghc
  • sjakobi/ghc
  • angerman/ghc
  • RyanGlScott/ghc
  • hvr/ghc
  • howtonotwin/ghc
  • chessai/ghc
  • m-renaud/ghc
  • brprice/ghc
  • stevehartdata/ghc
  • sighingnow/ghc
  • kgardas/ghc
  • ckoparkar/ghc
  • alp/ghc
  • smaeul/ghc
  • kakkun61/ghc
  • sykloid/ghc
  • newhoggy/ghc
  • toonn/ghc
  • nineonine/ghc
  • Phyx/ghc
  • ezyang/ghc
  • tweag/ghc
  • langston/ghc
  • ndmitchell/ghc
  • rockbmb/ghc
  • artempyanykh/ghc
  • mniip/ghc
  • mynguyenbmc/ghc
  • alexfmpe/ghc
  • crockeea/ghc
  • nh2/ghc
  • vaibhavsagar/ghc
  • phadej/ghc
  • Haskell-mouse/ghc
  • lolotp/ghc
  • spacekitteh/ghc
  • michaelpj/ghc
  • mgsloan/ghc
  • HPCohen/ghc
  • tmobile/ghc
  • radrow/ghc
  • simonmar/ghc
  • _deepfire/ghc
  • Ericson2314/ghc
  • leitao/ghc
  • fumieval/ghc
  • trac-isovector/ghc
  • cblp/ghc
  • xich/ghc
  • ciil/ghc
  • erthalion/ghc
  • xldenis/ghc
  • autotaker/ghc
  • haskell-wasm/ghc
  • kcsongor/ghc
  • agander/ghc
  • Baranowski/ghc
  • trac-dredozubov/ghc
  • 23Skidoo/ghc
  • iustin/ghc
  • ningning/ghc
  • josefs/ghc
  • kabuhr/ghc
  • gallais/ghc
  • dten/ghc
  • expipiplus1/ghc
  • Pluralia/ghc
  • rohanjr/ghc
  • intricate/ghc
  • kirelagin/ghc
  • Javran/ghc
  • DanielG/ghc
  • trac-mizunashi_mana/ghc
  • pparkkin/ghc
  • bollu/ghc
  • ntc2/ghc
  • jaspervdj/ghc
  • JoshMeredith/ghc
  • wz1000/ghc
  • zkourouma/ghc
  • code5hot/ghc
  • jdprice/ghc
  • tdammers/ghc
  • J-mie6/ghc
  • trac-lantti/ghc
  • ch1bo/ghc
  • cgohla/ghc
  • lucamolteni/ghc
  • acairncross/ghc
  • amerocu/ghc
  • chreekat/ghc
  • txsmith/ghc
  • trupill/ghc
  • typetetris/ghc
  • sergv/ghc
  • fryguybob/ghc
  • erikd/ghc
  • trac-roland/ghc
  • setupminimal/ghc
  • Friede80/ghc
  • SkyWriter/ghc
  • xplorld/ghc
  • abrar/ghc
  • obsidiansystems/ghc
  • Icelandjack/ghc
  • adinapoli/ghc
  • trac-matthewbauer/ghc
  • heatsink/ghc
  • dwijnand/ghc
  • Cmdv/ghc
  • alinab/ghc
  • pepeiborra/ghc
  • fommil/ghc
  • luochen1990/ghc
  • rlupton20/ghc
  • applePrincess/ghc
  • lehins/ghc
  • ronmrdechai/ghc
  • leeadam/ghc
  • harendra/ghc
  • mightymosquito1991/ghc
  • trac-gershomb/ghc
  • lucajulian/ghc
  • Rizary/ghc
  • VictorCMiraldo/ghc
  • jamesbrock/ghc
  • andrewdmeier/ghc
  • luke/ghc
  • pranaysashank/ghc
  • cocreature/ghc
  • hithroc/ghc
  • obreitwi/ghc
  • slrtbtfs/ghc
  • kaol/ghc
  • yairchu/ghc
  • Mathemagician98/ghc
  • trac-taylorfausak/ghc
  • leungbk/ghc
  • MichaWiedenmann/ghc
  • chris-martin/ghc
  • TDecki/ghc
  • adithyaov/ghc
  • trac-gelisam/ghc
  • Lysxia/ghc
  • complyue/ghc
  • bwignall/ghc
  • sternmull/ghc
  • sonika/ghc
  • leif/ghc
  • broadwaylamb/ghc
  • myszon/ghc
  • danbroooks/ghc
  • Mechachleopteryx/ghc
  • zardyh/ghc
  • trac-vdukhovni/ghc
  • OmarKhaledAbdo/ghc
  • arrowd/ghc
  • Bodigrim/ghc
  • matheus23/ghc
  • cardenaso11/ghc
  • trac-Athas/ghc
  • mb720/ghc
  • DylanZA/ghc
  • liff/ghc
  • typedrat/ghc
  • trac-claude/ghc
  • jbm/ghc
  • Gertjan423/ghc
  • PHO/ghc
  • JKTKops/ghc
  • kockahonza/ghc
  • msakai/ghc
  • Sir4ur0n/ghc
  • barambani/ghc
  • vishnu.c/ghc
  • dcoutts/ghc
  • trac-runeks/ghc
  • trac-MaxGabriel/ghc
  • lexi.lambda/ghc
  • strake/ghc
  • spavikevik/ghc
  • JakobBruenker/ghc
  • rmanne/ghc
  • gdziadkiewicz/ghc
  • ani/ghc
  • iliastsi/ghc
  • smunix/ghc
  • judah/ghc
  • blackgnezdo/ghc
  • emilypi/ghc
  • trac-bpfoley/ghc
  • muesli4/ghc
  • trac-gkaracha/ghc
  • Kleidukos/ghc
  • nek0/ghc
  • TristanCacqueray/ghc
  • dwulive/ghc
  • mbakke/ghc
  • arybczak/ghc
  • Yang123321/ghc
  • maksbotan/ghc
  • QuietMisdreavus/ghc
  • trac-olshanskydr/ghc
  • emekoi/ghc
  • samuela/ghc
  • josephcsible/ghc
  • dramforever/ghc
  • lpsmith/ghc
  • DenisFrezzato/ghc
  • michivi/ghc
  • jneira/ghc
  • jeffhappily/ghc
  • Ivan-Yudin/ghc
  • nakaji-dayo/ghc
  • gdevanla/ghc
  • galen/ghc
  • fendor/ghc
  • yaitskov/ghc
  • rcythr/ghc
  • awpr/ghc
  • jeremyschlatter/ghc
  • Aver1y/ghc
  • mitchellvitez/ghc
  • merijn/ghc
  • tomjaguarpaw1/ghc
  • trac-NoidedSuper/ghc
  • erewok/ghc
  • trac-junji.hashimoto/ghc
  • adamwespiser/ghc
  • bjaress/ghc
  • jhrcek/ghc
  • leonschoorl/ghc
  • lukasz-golebiewski/ghc
  • sheaf/ghc
  • last-g/ghc
  • carassius1014/ghc
  • eschwartz/ghc
  • dwincort/ghc
  • felixwiemuth/ghc
  • TimWSpence/ghc
  • marcusmonteirodesouza/ghc
  • WJWH/ghc
  • vtols/ghc
  • theobat/ghc
  • BinderDavid/ghc
  • ckoparkar0/ghc
  • alexander-kjeldaas/ghc
  • dme2/ghc
  • philderbeast/ghc
  • aaronallen8455/ghc
  • rayshih/ghc
  • benkard/ghc
  • mpardalos/ghc
  • saidelman/ghc
  • leiftw/ghc
  • ca333/ghc
  • bwroga/ghc
  • nmichael44/ghc
  • trac-crobbins/ghc
  • felixonmars/ghc
  • adityagupta1089/ghc
  • hgsipiere/ghc
  • treeowl/ghc
  • alexpeits/ghc
  • CraigFe/ghc
  • dnlkrgr/ghc
  • kerckhove_ts/ghc
  • cptwunderlich/ghc
  • eiais/ghc
  • hahohihu/ghc
  • sanchayan/ghc
  • lemmih/ghc
  • sehqlr/ghc
  • trac-dbeacham/ghc
  • luite/ghc
  • trac-f-a/ghc
  • vados/ghc
  • luntain/ghc
  • fatho/ghc
  • alexbiehl-gc/ghc
  • dcbdan/ghc
  • tvh/ghc
  • liam-ly/ghc
  • timbobbarnes/ghc
  • GovanifY/ghc
  • shanth2600/ghc
  • gliboc/ghc
  • duog/ghc
  • moxonsghost/ghc
  • zander/ghc
  • masaeedu/ghc
  • georgefst/ghc
  • guibou/ghc
  • nicuveo/ghc
  • mdebruijne/ghc
  • stjordanis/ghc
  • emiflake/ghc
  • wygulmage/ghc
  • frasertweedale/ghc
  • coot/ghc
  • aratamizuki/ghc
  • tsandstr/ghc
  • mrBliss/ghc
  • Anton-Latukha/ghc
  • tadfisher/ghc
  • vapourismo/ghc
  • Sorokin-Anton/ghc
  • basile-henry/ghc
  • trac-mightybyte/ghc
  • AbsoluteNikola/ghc
  • cobrien99/ghc
  • songzh/ghc
  • blamario/ghc
  • aj4ayushjain/ghc
  • trac-utdemir/ghc
  • tangcl/ghc
  • hdgarrood/ghc
  • maerwald/ghc
  • arjun/ghc
  • ratherforky/ghc
  • haskieLambda/ghc
  • EmilGedda/ghc
  • Bogicevic/ghc
  • eddiejessup/ghc
  • kozross/ghc
  • AlistairB/ghc
  • 3Rafal/ghc
  • christiaanb/ghc
  • trac-bit/ghc
  • matsumonkie/ghc
  • trac-parsonsmatt/ghc
  • chisui/ghc
  • jaro/ghc
  • trac-kmiyazato/ghc
  • davidsd/ghc
  • Tritlo/ghc
  • I-B-3/ghc
  • lykahb/ghc
  • AriFordsham/ghc
  • turion1/ghc
  • berberman/ghc
  • christiantakle/ghc
  • zyklotomic/ghc
  • trac-ocramz/ghc
  • CSEdd/ghc
  • doyougnu/ghc
  • mmhat/ghc
  • why-not-try-calmer/ghc
  • plutotulp/ghc
  • kjekac/ghc
  • Manvi07/ghc
  • teo/ghc
  • cactus/ghc
  • CarrieMY/ghc
  • abel/ghc
  • yihming/ghc
  • tsakki/ghc
  • jessicah/ghc
  • oliverbunting/ghc
  • meld/ghc
  • friedbrice/ghc
  • Joald/ghc
  • abarbu/ghc
  • DigitalBrains1/ghc
  • sterni/ghc
  • alexDarcy/ghc
  • hexchain/ghc
  • minimario/ghc
  • zliu41/ghc
  • tommd/ghc
  • jazcarate/ghc
  • peterbecich/ghc
  • alirezaghey/ghc
  • solomon/ghc
  • mikael.urankar/ghc
  • davjam/ghc
  • int-index/ghc
  • MorrowM/ghc
  • nrnrnr/ghc
  • Sonfamm/ghc-test-only
  • afzt1/ghc
  • nguyenhaibinh-tpc/ghc
  • trac-lierdakil/ghc
  • MichaWiedenmann1/ghc
  • jmorag/ghc
  • Ziharrk/ghc
  • trac-MitchellSalad/ghc
  • juampe/ghc
  • jwaldmann/ghc
  • snowleopard/ghc
  • juhp/ghc
  • normalcoder/ghc
  • ksqsf/ghc
  • trac-jberryman/ghc
  • roberth/ghc
  • 1ntEgr8/ghc
  • epworth/ghc
  • MrAdityaAlok/ghc
  • JunmingZhao42/ghc
  • jappeace/ghc
  • trac-Gabriel439/ghc
  • alt-romes/ghc
  • HugoPeters1024/ghc
  • 10ne1/ghc-fork
  • agentultra/ghc
  • Garfield1002/ghc
  • ChickenProp/ghc
  • clyring/ghc
  • MaxHearnden/ghc
  • jumper149/ghc
  • vem/ghc
  • ketzacoatl/ghc
  • Rosuavio/ghc
  • jackohughes/ghc
  • p4l1ly/ghc
  • konsumlamm/ghc
  • shlevy/ghc
  • torsten.schmits/ghc
  • andremarianiello/ghc
  • amesgen/ghc
  • googleson78/ghc
  • InfiniteVerma/ghc
  • uhbif19/ghc
  • yiyunliu/ghc
  • raehik/ghc
  • mrkun/ghc
  • telser/ghc
  • 1Jajen1/ghc
  • slotThe/ghc
  • WinstonHartnett/ghc
  • mpilgrem/ghc
  • dreamsmasher/ghc
  • schuelermine/ghc
  • trac-Viwor/ghc
  • undergroundquizscene/ghc
  • evertedsphere/ghc
  • coltenwebb/ghc
  • oberblastmeister/ghc
  • agrue/ghc
  • lf-/ghc
  • zacwood9/ghc
  • steshaw/ghc
  • high-cloud/ghc
  • SkamDart/ghc
  • PiDelport/ghc
  • maoif/ghc
  • RossPaterson/ghc
  • CharlesTaylor7/ghc
  • ribosomerocker/ghc
  • trac-ramirez7/ghc
  • daig/ghc
  • NicolasT/ghc
  • FinleyMcIlwaine/ghc
  • lawtonnichols/ghc
  • jmtd/ghc
  • ozkutuk/ghc
  • wildsebastian/ghc
  • nikshalark/ghc
  • lrzlin/ghc
  • tobias/ghc
  • fw/ghc
  • hawkinsw/ghc
  • type-dance/ghc
  • rui314/ghc
  • ocharles/ghc
  • wavewave/ghc
  • TheKK/ghc
  • nomeata/ghc
  • trac-csabahruska/ghc
  • jonathanjameswatson/ghc
  • L-as/ghc
  • Axman6/ghc
  • barracuda156/ghc
  • trac-jship/ghc
  • jake-87/ghc
  • meooow/ghc
  • rebeccat/ghc
  • hamana55/ghc
  • Enigmage/ghc
  • kokobd/ghc
  • agevelt/ghc
  • gshen42/ghc
  • chrismwendt/ghc
  • MangoIV/ghc
  • teto/ghc
  • Sookr1/ghc
  • trac-thomasjm/ghc
  • barci2/ghc-dev
  • trac-m4dc4p/ghc
  • dixonary/ghc
  • breakerzirconia/ghc
  • alexsio27444/ghc
  • glocq/ghc
  • sourabhxyz/ghc
  • ryantrinkle/ghc
  • Jade/ghc
  • scedfaliako/ghc
  • martijnbastiaan/ghc
  • trac-george.colpitts/ghc
  • ammarbinfaisal/ghc
  • mimi.vx/ghc
  • lortabac/ghc
  • trac-zyla/ghc
  • benbellick/ghc
  • aadaa-fgtaa/ghc
  • jvanbruegge/ghc
  • archbung/ghc
  • gilmi/ghc
  • mfonism/ghc
  • alex-mckenna/ghc
  • Ei30metry/ghc
  • DiegoDiverio/ghc
  • jorgecunhamendes/ghc
  • liesnikov/ghc
  • akrmn/ghc
  • trac-simplifierticks/ghc
  • jacco/ghc
  • rhendric/ghc
  • damhiya/ghc
  • ryndubei/ghc
  • DaveBarton/ghc
  • trac-Profpatsch/ghc
  • GZGavinZhao/ghc
  • ncfavier/ghc
  • jameshaydon/ghc
  • ajccosta/ghc
  • dschrempf/ghc
  • cydparser/ghc
  • LinuxUserGD/ghc
  • elodielander/ghc
  • facundominguez/ghc
  • psilospore/ghc
  • lachrimae/ghc
  • dylan-thinnes/ghc-type-errors-plugin
  • hamishmack/ghc
  • Leary/ghc
  • lzszt/ghc
  • lyokha/ghc
  • trac-glaubitz/ghc
  • Rewbert/ghc
  • andreabedini/ghc
  • Jasagredo/ghc
  • sol/ghc
  • OlegAlexander/ghc
  • trac-sthibaul/ghc
  • avdv/ghc
  • Wendaolee/ghc
  • ur4t/ghc
  • daylily/ghc
  • boltzmannrain/ghc
  • mmzk1526/ghc
  • trac-fizzixnerd/ghc
  • soulomoon/ghc
  • rwmjones/ghc
  • j14i/ghc
  • tracsis/ghc
  • gesh/ghc
  • flip101/ghc
  • eldritch-cookie/ghc
  • LemonjamesD/ghc
  • pgujjula/ghc
  • skeuchel/ghc
  • noteed/ghc
  • gulin.serge/ghc
  • Torrekie/ghc
  • jlwoodwa/ghc
  • ayanamists/ghc
  • husong998/ghc
  • trac-edmundnoble/ghc
  • josephf/ghc
  • contrun/ghc
  • baulig/ghc
  • edsko/ghc
  • mzschr/ghc-issue-24732
  • ulidtko/ghc
  • Arsen/ghc
  • trac-sjoerd_visscher/ghc
  • crumbtoo/ghc
  • L0neGamer/ghc
  • DrewFenwick/ghc
  • benz0li/ghc
  • MaciejWas/ghc
  • jordanrule/ghc
  • trac-qqwy/ghc
  • LiamGoodacre/ghc
  • isomorpheme/ghc
  • trac-danidiaz/ghc
  • Kariim/ghc
  • MTaimoorZaeem/ghc
  • hololeap/ghc
  • ticat-fp/ghc
  • meritamen/ghc
  • criskell/ghc
  • trac-kraai/ghc
  • aergus/ghc
  • jdral/ghc
  • SamB/ghc
  • Tristian/ghc
  • ywgrit/ghc
  • KatsuPatrick/ghc
  • OsePedro/ghc
  • mpscholten/ghc
  • fp/ghc
  • zaquest/ghc
638 results
Show changes
Commits on Source (2)
  • Hannes Siebenhandl's avatar
    Refactor the Binary serialisation interface · c6e1bbf1
    Hannes Siebenhandl authored
    The end goal is to dynamically add deduplication tables for `ModIface`
    interface serialisation.
    
    We identify two main points of interest that make this difficult:
    
    1. UserData hardcodes what `Binary` instances can have deduplication
       tables. Moreover, it heavily uses partial functions.
    2. GHC.Iface.Binary hardcodes the deduplication tables for 'Name' and
       'FastString', making it difficult to add more deduplication.
    
    Instead of having a single `UserData` record with fields for all the
    types that can have deduplication tables, we allow to provide custom
    serialisers for any `Typeable`.
    These are wrapped in existentials and stored in a `Map` indexed by their
    respective `TypeRep`.
    The `Binary` instance of the type to deduplicate still needs to
    explicitly look up the decoder via `findUserDataReader` and
    `findUserDataWriter`, which is no worse than the status-quo.
    
    `Map` was chosen as microbenchmarks indicate it is the fastest for a
    small number of keys (< 10).
    
    To generalise the deduplication table serialisation mechanism, we
    introduce the types `ReaderTable` and `WriterTable` which provide a
    simple interface that is sufficient to implement a general purpose
    deduplication mechanism for `writeBinIface` and `readBinIface`.
    
    This allows us to provide a list of deduplication tables for
    serialisation that can be extended more easily, for example for
    `IfaceTyCon`, see the issue #24540
    for more motivation.
    
    In addition to ths refactoring, we split `UserData` into `ReaderUserData`
    and `WriterUserData`, to avoid partial functions.
    
    Bump haddock submodule to accomodate for `UserData` split.
    
    -------------------------
    Metric Increase:
        MultiLayerModulesTH_Make
        MultiLayerModulesRecomp
        T21839c
    -------------------------
    c6e1bbf1
  • Hannes Siebenhandl's avatar
    Split `BinHandle` into `ReadBinHandle` and `WriteBinHandle` · 6df52a0a
    Hannes Siebenhandl authored
    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.
    6df52a0a
......@@ -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
}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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 =
......@@ -81,7 +81,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
......@@ -99,7 +99,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@DynFlags{..} nameio =
let
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -1010,7 +1010,7 @@ data TupleSort
= BoxedTuple
| UnboxedTuple
| ConstraintTuple
deriving( Eq, Data )
deriving( Eq, Data, Ord )
instance Outputable TupleSort where
ppr ts = text $
......
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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
......
......@@ -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)
......
Subproject commit 504d4c1842db93704b4c5e158ecc3af7050ba9fe
Subproject commit edf742131e272fc29c6d6eae549b0fe37eea11b9