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 (6)
  • Hannes Siebenhandl's avatar
    Add Eq and Ord instance to `IfaceType` · 1b2f0ff0
    Hannes Siebenhandl authored
    We add an `Ord` instance so that we can store `IfaceType` in a
    `Data.Map` container.
    This is required to deduplicate `IfaceType` while writing `.hi` files to
    disk. Deduplication has many beneficial consequences to both file size
    and memory usage, as the deduplication enables implicit sharing of
    values.
    See issue #24540 for more motivation.
    
    The `Ord` instance would be unnecessary if we used a `TrieMap` instead
    of `Data.Map` for the deduplication process. While in theory this is
    clerarly the better option, experiments on the agda code base showed
    that a `TrieMap` implementation has worse run-time performance
    characteristics.
    
    To the change itself, we mostly derive `Eq` and `Ord`. This requires us
    to change occurrences of `FastString` with `LexicalFastString`, since
    `FastString` has no `Ord` instance.
    We change the definition of `IfLclName` to a newtype of
    `LexicalFastString`, to make such changes in the future easier.
    
    Bump haddock submodule for IfLclName changes
    1b2f0ff0
  • Hannes Siebenhandl's avatar
    Break cyclic module dependency · dd01fcb4
    Hannes Siebenhandl authored
    dd01fcb4
  • Hannes Siebenhandl's avatar
    Add deduplication table for `IfaceType` · 7e5a678d
    Hannes Siebenhandl authored
    The type `IfaceType` is a highly redundant, tree-like data structure.
    While benchmarking, we realised that the high redundancy of `IfaceType`
    causes high memory consumption in GHCi sessions when byte code is
    embedded into the `.hi` file via `-fwrite-if-simplified-core` or
    `-fbyte-code-and-object-code`.
    Loading such `.hi` files from disk introduces many duplicates of
    memory expensive values in `IfaceType`, such as `IfaceTyCon`,
    `IfaceTyConApp`, `IA_Arg` and many more.
    
    We improve the memory behaviour of GHCi by adding an additional
    deduplication table for `IfaceType` to the serialisation of `ModIface`,
    similar to how we deduplicate `Name`s and `FastString`s.
    When reading the interface file back, the table allows us to automatically
    share identical values of `IfaceType`.
    
    To provide some numbers, we evaluated this patch on the agda code base.
    We loaded the full library from the `.hi` files, which contained the
    embedded core expressions (`-fwrite-if-simplified-core`).
    
    Before this patch:
    
    * Load time: 11.7 s, 2.5 GB maximum residency.
    
    After this patch:
    
    * Load time:  7.3 s, 1.7 GB maximum residency.
    
    This deduplication has the beneficial side effect to additionally reduce
    the size of the on-disk interface files tremendously.
    
    For example, on agda, we reduce the size of `.hi` files (with
    `-fwrite-if-simplified-core`):
    
    * Before: 101 MB on disk
    * Now:     24 MB on disk
    
    This has even a beneficial side effect on the cabal store. We reduce the
    size of the store on disk:
    
    * Before: 341 MB on disk
    * Now:    310 MB on disk
    
    Note, none of the dependencies have been compiled with
    `-fwrite-if-simplified-core`, but `IfaceType` occurs in multiple
    locations in a `ModIface`.
    
    We also add IfaceType deduplication table to .hie serialisation and
    refactor .hie file serialisation to use the same infrastrucutre as
    `putWithTables`.
    
    Bump haddock submodule to accomodate for changes to the deduplication
    table layout and binary interface.
    7e5a678d
  • Matthew Pickering's avatar
    Add run-time configurability of .hi file compression · a98ae613
    Matthew Pickering authored and Hannes Siebenhandl's avatar Hannes Siebenhandl committed
    Introduce the flag `-fwrite-if-compression=<n>` which allows to
    configure the compression level of writing .hi files.
    
    The motivation is that some deduplication operations are too expensive
    for the average use case. Hence, we introduce multiple compression
    levels that have a minimal impact on performance, but still reduce the
    memory residency and `.hi` file size on disk considerably.
    
    We introduce three compression levels:
    
    * `1`: `Normal` mode. This is the least amount of compression.
        It deduplicates only `Name` and `FastString`s, and is naturally the
        fastest compression mode.
    * `2`: `Safe` mode. It has a noticeable impact on .hi file size and is
      marginally slower than `Normal` mode. In general, it should be safe to
      always use `Safe` mode.
    * `3`: `Full` deduplication mode. Deduplicate as much as we can,
      resulting in minimal .hi files, but at the cost of additional
      compilation time.
    
    Reading .hi files doesn't need to know the initial compression level,
    and can always deserialise a `ModIface`.
    This allows users to experiment with different compression levels for
    packages, without recompilation of dependencies.
    
    Note, the deduplication also has an additional side effect of reduced
    memory consumption to implicit sharing of deduplicated elements.
    See #24540 for example where
    that matters.
    
    -------------------------
    Metric Decrease:
        T21839c
        T24471
    -------------------------
    a98ae613
  • Matthew Pickering's avatar
    Introduce regression tests for `.hi` file sizes · 45e812de
    Matthew Pickering authored and Hannes Siebenhandl's avatar Hannes Siebenhandl committed
    Add regression tests to track how `-fwrite-if-compression` levels affect
    the size of `.hi` files.
    45e812de
  • Hannes Siebenhandl's avatar
    Implement TrieMap for IfaceType · f6d5a5c2
    Hannes Siebenhandl authored
    f6d5a5c2
Showing
with 644 additions and 233 deletions
......@@ -40,6 +40,7 @@ import GHC.Utils.Outputable
import qualified Data.Map as Map
import GHC.Types.Name.Env
import Control.Monad( (>=>) )
import GHC.Types.Literal (Literal)
{-
This module implements TrieMaps over Core related data structures
......@@ -128,6 +129,8 @@ instance TrieMap CoreMap where
-- inside another 'TrieMap', this is the type you want.
type CoreMapG = GenMap CoreMapX
type LiteralMap a = Map.Map Literal a
-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
-- the 'GenMap' optimization.
data CoreMapX a
......
......@@ -952,13 +952,13 @@ data CoSel -- See Note [SelCo]
| SelForAll -- Decomposes (forall a. co)
deriving( Eq, Data.Data )
deriving( Eq, Data.Data, Ord )
data FunSel -- See Note [SelCo]
= SelMult -- Multiplicity
| SelArg -- Argument of function
| SelRes -- Result of function
deriving( Eq, Data.Data )
deriving( Eq, Data.Data, Ord )
type CoercionN = Coercion -- always nominal
type CoercionR = Coercion -- always representational
......
......@@ -121,7 +121,7 @@ toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))
, toIfaceTypeX fr (tyVarKind tyvar)
)
......@@ -133,7 +133,7 @@ toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)
, occNameFS (getOccName covar)
, mkIfLclName (occNameFS (getOccName covar))
, toIfaceTypeX fr (varType covar)
)
......@@ -218,11 +218,11 @@ toIfaceTypeX fr (TyConApp tc tys)
arity = tyConArity tc
n_tys = length tys
toIfaceTyVar :: TyVar -> FastString
toIfaceTyVar = occNameFS . getOccName
toIfaceTyVar :: TyVar -> IfLclName
toIfaceTyVar = mkIfLclName . occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> IfLclName
toIfaceCoVar = mkIfLclName . occNameFS . getOccName
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
......@@ -264,7 +264,7 @@ toIfaceTyCon_name n = IfaceTyCon n info
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x)
toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
----------------
......@@ -296,7 +296,7 @@ toIfaceCoercionX fr co
go (InstCo co arg) = IfaceInstCo (go co) (go arg)
go (KindCo c) = IfaceKindCo (go c)
go (SubCo co) = IfaceSubCo (go co)
go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (mkIfLclName (coaxrName co)) (map go cs)
go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r
(toIfaceTypeX fr t1)
......@@ -433,7 +433,7 @@ toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
(idJoinPointHood id)
......@@ -444,7 +444,7 @@ toIfaceTopBndr :: Id -> IfaceTopBndrInfo
toIfaceTopBndr id
= if isExternalName name
then IfGblTopBndr name
else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id))
else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id))
(toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))
where
name = getName id
......@@ -555,7 +555,7 @@ toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfac
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
| otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
| otherwise = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
......@@ -610,7 +610,7 @@ toIfaceTopBind b =
---------------------
toIfaceAlt :: CoreAlt -> IfaceAlt
toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)
toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)
---------------------
toIfaceCon :: AltCon -> IfaceConAlt
......@@ -655,7 +655,7 @@ toIfaceVar v
-- Foreign calls have special syntax
| isExternalName name = IfaceExt name
| otherwise = IfaceLcl (occNameFS $ nameOccName name)
| otherwise = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name))
where
name = idName v
ty = idType v
......
......@@ -283,13 +283,16 @@ instance Ord NonDetFastString where
-- `lexicalCompareFS` (i.e. which compares FastStrings on their String
-- representation). Hence it is deterministic from one run to the other.
newtype LexicalFastString
= LexicalFastString FastString
= LexicalFastString { getLexicalFastString :: FastString }
deriving newtype (Eq, Show)
deriving stock Data
instance Ord LexicalFastString where
compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2
instance NFData LexicalFastString where
rnf (LexicalFastString f) = rnf f
-- -----------------------------------------------------------------------------
-- Construction
......
......@@ -13,8 +13,6 @@ module GHC.Data.TrieMap(
MaybeMap,
-- * Maps over 'List' values
ListMap,
-- * Maps over 'Literal's
LiteralMap,
-- * 'TrieMap' class
TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
......@@ -30,7 +28,6 @@ module GHC.Data.TrieMap(
import GHC.Prelude
import GHC.Types.Literal
import GHC.Types.Unique.DFM
import GHC.Types.Unique( Uniquable )
......@@ -39,6 +36,8 @@ import qualified Data.IntMap as IntMap
import GHC.Utils.Outputable
import Control.Monad( (>=>) )
import Data.Kind( Type )
import Data.Functor.Compose
import Data.Functor.Product
import qualified Data.Semigroup as S
......@@ -343,15 +342,94 @@ ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
ftList f (LM { lm_nil = mnil, lm_cons = mcons })
= LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }
{-
************************************************************************
* *
Basic maps
Composition
* *
************************************************************************
-}
type LiteralMap a = Map.Map Literal a
instance (TrieMap m, TrieMap n) => TrieMap (Compose m n) where
type Key (Compose m n) = (Key m, Key n)
emptyTM = Compose emptyTM
lookupTM = lkCompose lookupTM lookupTM
{-# INLINE lookupTM #-}
alterTM = xtCompose alterTM alterTM
{-# INLINE alterTM #-}
foldTM = fdCompose
{-# INLINE foldTM #-}
filterTM = ftCompose
{-# INLINE filterTM #-}
lkCompose :: Monad m => (t1 -> f (g a1) -> m a2) -> (t2 -> a2 -> m b) -> (t1, t2) -> Compose f g a1 -> m b
lkCompose f g (a, b) (Compose m) = f a m >>= g b
{-# INLINE lkCompose #-}
xtCompose ::
(TrieMap m, TrieMap n)
=> (forall a . Key m -> XT a -> m a -> m a)
-> (forall a . Key n -> XT a -> n a -> n a)
-> Key (Compose m n)
-> XT a
-> Compose m n a
-> Compose m n a
xtCompose f g (a, b) xt (Compose m) = Compose ((f a |>> g b xt) m)
{-# INLINE xtCompose #-}
fdCompose :: (TrieMap m1, TrieMap m2) => (a -> b -> b) -> Compose m1 m2 a -> b -> b
fdCompose f (Compose m) = foldTM (foldTM f) m
{-# INLINE fdCompose #-}
ftCompose :: (TrieMap n, Functor m) => (a -> Bool) -> Compose m n a -> Compose m n a
ftCompose f (Compose m) = Compose (fmap (filterTM f) m)
{-# INLINE ftCompose #-}
{- Product -}
instance (TrieMap m, TrieMap n) => TrieMap (Product m n) where
type Key (Product m n) = Either (Key m) (Key n)
emptyTM = Pair emptyTM emptyTM
lookupTM = lkProduct
{-# INLINE lookupTM #-}
alterTM = xtProduct
{-# INLINE alterTM #-}
foldTM = fdProduct
{-# INLINE foldTM #-}
filterTM = ftProduct
{-# INLINE filterTM #-}
lkProduct :: (TrieMap m1, TrieMap m2) => Either (Key m1) (Key m2) -> Product m1 m2 b -> Maybe b
lkProduct k (Pair am bm) =
case k of
Left a -> lookupTM a am
Right b -> lookupTM b bm
{-# INLINE lkProduct #-}
xtProduct :: (TrieMap f, TrieMap g) => Either (Key f) (Key g) -> XT a -> Product f g a -> Product f g a
xtProduct k xt (Pair am bm) =
case k of
Left a -> Pair (alterTM a xt am) bm
Right b -> Pair am (alterTM b xt bm)
{-# INLINE xtProduct #-}
fdProduct :: (TrieMap f, TrieMap g) => (a -> c -> c) -> Product f g a -> c -> c
fdProduct f (Pair am bm) = foldTM f am . foldTM f bm
{-# INLINE fdProduct #-}
ftProduct :: (TrieMap f, TrieMap g) => (a -> Bool) -> Product f g a -> Product f g a
ftProduct f (Pair am bm) = Pair (filterTM f am) (filterTM f bm)
{-# INLINE ftProduct #-}
{-
************************************************************************
......
......@@ -207,6 +207,7 @@ data DynFlags = DynFlags {
dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an
-- Unboxed demand on returned products with at most
-- this number of fields
ifCompression :: Int,
specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types
......@@ -546,6 +547,7 @@ defaultDynFlags mySettings =
maxPmCheckModels = 30,
simplTickFactor = 100,
dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple
ifCompression = 2, -- Default: Apply safe compressions
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
specConstrRecursive = 3,
......
......@@ -163,7 +163,7 @@ import GHC.JS.Syntax
import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings )
import GHC.Iface.Load ( ifaceStats, writeIface )
import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression )
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
......@@ -612,7 +612,7 @@ extract_renamed_stuff mod_summary tc_result = do
-- enables the option which keeps the renamed source.
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
liftIO $ writeHieFile (flagsToIfCompression dflags) out_file hieFile
liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
-- Validate HIE files
......@@ -1207,7 +1207,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
withTiming logger
(text "WriteIface"<+>brackets (text iface_name))
(const ())
(writeIface logger profile iface_name iface)
(writeIface logger profile (flagsToIfCompression dflags) iface_name iface)
if (write_interface || force_write_interface) then do
......
......@@ -1695,6 +1695,9 @@ dynamic_flags_deps = [
, make_ord_flag defFlag "fno-refinement-level-hole-fits"
(noArg (\d -> d { refLevelHoleFits = Nothing }))
, make_ord_flag defFlag "fwrite-if-compression"
(intSuffix (\n d -> d { ifCompression = n }))
, make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"
(noArg id)
"vectors registers are now passed in registers by default."
......
......@@ -14,6 +14,7 @@ module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIfaceHeader,
CompressionIFace(..),
getSymtabName,
CheckHiWay(..),
TraceBinIFace(..),
......@@ -25,6 +26,8 @@ module GHC.Iface.Binary (
putName,
putSymbolTable,
BinSymbolTable(..),
initWriteIfaceType, initReadIfaceTypeTable,
putAllTables,
) where
import GHC.Prelude
......@@ -46,14 +49,19 @@ import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Settings.Constants
import GHC.Utils.Fingerprint
import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte)
import Control.Monad
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.Word
import Data.IORef
import Control.Monad
import Data.Map.Strict (Map)
import Data.Word
import System.IO.Unsafe
import Data.Typeable (Typeable)
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
......@@ -66,6 +74,21 @@ data TraceBinIFace
= TraceBinIFace (SDoc -> IO ())
| QuietBinIFace
data CompressionIFace
= NormalCompression
-- ^ Perform the normal compression operations,
-- such as deduplicating 'Name's and 'FastString's
| SafeExtraCompression
-- ^ Perform some extra compression steps that have minimal impact
-- on the run-time of 'ghc'.
--
-- This reduces the size of '.hi' files significantly in some cases
-- and reduces overall memory usage in certain scenarios.
| MaximalCompression
-- ^ Try to compress as much as possible.
--
-- Yields the smallest '.hi' files but at the cost of additional run-time.
-- | Read an interface file header, checking the magic number, version, and
-- way. Returns the hash of the source file and a BinHandle which points at the
-- start of the rest of the interface file data.
......@@ -158,30 +181,42 @@ getWithUserData name_cache bh = do
-- Reading names has the side effect of adding them into the given NameCache.
getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables name_cache bh = do
bhRef <- newIORef (error "used too soon")
-- It is important this is passed to 'getTable'
ud <- unsafeInterleaveIO (readIORef bhRef)
fsReaderTable <- initFastStringReaderTable
nameReaderTable <- initNameReaderTable name_cache
-- 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
nameTable <- Binary.forwardGet bh (getTable nameReaderTable bhFs)
let
nameReader = mkReaderFromTable nameReaderTable nameTable
bhName = addReaderToUserData (mkSomeBinaryReader nameReader) bhFs
pure bhName
ifaceTypeReaderTable <- initReadIfaceTypeTable ud
let -- For any 'ReaderTable', we decode the table that is found at the location
-- the forward reference points to.
-- After decoding the table, we create a 'BinaryReader' and immediately
-- 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)
let binaryReader = mkReaderFromTable tbl table
pure $ addReaderToUserData binaryReader bh0
-- Decode all the tables and populate the 'ReaderUserData'.
bhFinal <- foldM (\bh0 act -> act bh0) bh
-- The order of these deserialisation matters!
--
-- See Note [Order of deduplication tables during iface binary serialisation] for details.
[ decodeReaderTable fsReaderTable
, decodeReaderTable nameReaderTable
, decodeReaderTable ifaceTypeReaderTable
]
writeIORef bhRef (getReaderUserData bhFinal)
pure bhFinal
-- | 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
writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO ()
writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do
bh <- openBinMem initBinMemSize
let platform = profilePlatform profile
put_ bh (binaryInterfaceMagic platform)
......@@ -195,7 +230,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
extFields_p_p <- tellBinWriter bh
put_ bh extFields_p_p
putWithUserData traceBinIface bh mod_iface
putWithUserData traceBinIface compressionLevel bh mod_iface
extFields_p <- tellBinWriter bh
putAt bh extFields_p_p extFields_p
......@@ -209,9 +244,9 @@ 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 -> WriteBinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
(name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
putWithUserData traceBinIface compressionLevel bh payload = do
(name_count, fs_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload)
case traceBinIface of
QuietBinIFace -> return ()
......@@ -234,11 +269,12 @@ putWithUserData traceBinIface bh payload = do
-- It returns (number of names, number of FastStrings, payload write result)
--
-- See Note [Order of deduplication tables during iface binary serialisation]
putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
putWithTables bh' put_payload = do
putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
putWithTables compressionLevel bh' put_payload = do
-- Initialise deduplicating tables.
(fast_wt, fsWriter) <- initFastStringWriterTable
(name_wt, nameWriter) <- initNameWriterTable
(ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel
-- Initialise the 'WriterUserData'.
let writerUserData = mkWriterUserData
......@@ -250,6 +286,7 @@ putWithTables bh' put_payload = do
--
-- See Note [Binary UserData]
, mkSomeBinaryWriter @BindingName $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name))
, mkSomeBinaryWriter @IfaceType ifaceTypeWriter
]
let bh = setWriterUserData bh' writerUserData
......@@ -257,18 +294,24 @@ putWithTables bh' put_payload = do
-- 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
putAllTables bh [fast_wt, name_wt, ifaceType_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)
-- | Write all deduplication tables to disk after serialising the
-- main payload.
--
-- Writes forward pointers to the deduplication tables before writing the payload
-- to allow deserialisation *before* the payload is read again.
putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
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)
-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
......@@ -450,6 +493,42 @@ Here, a visualisation of the table structure we currently have (ignoring 'Extens
-- The symbol table
--
initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
initReadIfaceTypeTable ud = do
pure $
ReaderTable
{ getTable = getGenericSymbolTable (\bh -> lazyGet' getIfaceType (setReaderUserData bh ud))
, mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
}
initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)
initWriteIfaceType compressionLevel = do
sym_tab <- initGenericSymbolTable @(Map IfaceType)
pure
( WriterTable
{ putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
}
, mkWriter $ ifaceWriter sym_tab
)
where
ifaceWriter sym_tab = case compressionLevel of
NormalCompression -> literalIfaceTypeSerialiser
SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab
MaximalCompression -> fullIfaceTypeSerialiser sym_tab
ifaceTyConAppSerialiser sym_tab bh ty = case ty of
IfaceTyConApp {} -> do
put_ bh ifaceTypeSharedByte
putGenericSymTab sym_tab bh ty
_ -> putIfaceType bh ty
fullIfaceTypeSerialiser sym_tab bh ty = do
put_ bh ifaceTypeSharedByte
putGenericSymTab sym_tab bh ty
literalIfaceTypeSerialiser = putIfaceType
initNameReaderTable :: NameCache -> IO (ReaderTable Name)
initNameReaderTable cache = do
......
......@@ -45,7 +45,6 @@ import GHC.Types.SrcLoc
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.BooleanFormula
......@@ -147,7 +146,7 @@ tyConToIfaceDecl env tycon
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getName tycon,
ifResVar = if_res_var,
ifResVar = mkIfLclName <$> if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
ifBinders = if_binders,
ifResKind = if_res_kind,
......@@ -288,7 +287,7 @@ classToIfaceDecl env clas
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = toIfaceBooleanFormula $ fmap getOccFS (classMinimalDef clas)
ifMinDef = toIfaceBooleanFormula $ fmap (mkIfLclName . getOccFS) (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
......@@ -334,7 +333,7 @@ tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> FastString
tidyTyVar :: TidyEnv -> TyVar -> IfLclName
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
......
......@@ -34,7 +34,6 @@ import GHC.Runtime.Context
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Types.Var
......@@ -190,10 +189,10 @@ setNameModule (Just m) n =
************************************************************************
-}
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId :: IfLclName -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
; case lookupFsEnv (if_id_env lcl) occ of
; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of
Just ty_var -> return ty_var
Nothing -> failIfM $
vcat
......@@ -209,10 +208,10 @@ extendIfaceIdEnv ids
in env { if_id_env = id_env' }
tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar :: IfLclName -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
; case lookupFsEnv (if_tv_env lcl) occ of
; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
......@@ -220,15 +219,15 @@ tcIfaceTyVar occ
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar (occ, _)
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_tv_env lcl) occ) }
; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (_, occ, _))
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_id_env lcl) occ) }
; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_tv_env lcl) occ) }
; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars
......
......@@ -38,22 +38,21 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Word ( Word8, Word32 )
import Control.Monad ( replicateM, when, forM_ )
import Control.Monad ( replicateM, when, forM_, foldM )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
import GHC.Iface.Binary (initWriteIfaceType, putAllTables, initReadIfaceTypeTable, CompressionIFace)
import GHC.Iface.Type (IfaceType)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified GHC.Utils.Binary as Binary
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName)))
}
data HieDictionary = HieDictionary
{ hie_dict_next :: !FastMutInt -- The next index to use
, hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
}
initBinMemSize :: Int
initBinMemSize = 1024*1024
......@@ -74,8 +73,8 @@ putBinLine bh xs = do
-- | Write a `HieFile` to the given `FilePath`, with a proper header and
-- symbol tables for `Name`s and `FastString`s
writeHieFile :: FilePath -> HieFile -> IO ()
writeHieFile hie_file_path hiefile = do
writeHieFile :: CompressionIFace -> FilePath -> HieFile -> IO ()
writeHieFile compression hie_file_path hiefile = do
bh0 <- openBinMem initBinMemSize
-- Write the header: hieHeader followed by the
......@@ -84,58 +83,58 @@ writeHieFile hie_file_path hiefile = do
putBinLine bh0 $ BSC.pack $ show hieVersion
putBinLine bh0 $ ghcVersion
-- remember where the dictionary pointer will go
dict_p_p <- tellBinWriter bh0
put_ bh0 dict_p_p
(fs_tbl, fs_w) <- initFastStringWriterTable
(name_tbl, name_w) <- initWriteNameTable
(iface_tbl, iface_w) <- initWriteIfaceType compression
-- remember where the symbol table pointer will go
symtab_p_p <- tellBinWriter bh0
put_ bh0 symtab_p_p
let bh = setWriterUserData bh0 $ mkWriterUserData
[ mkSomeBinaryWriter @IfaceType iface_w
, mkSomeBinaryWriter @Name name_w
, mkSomeBinaryWriter @BindingName (simpleBindingNameWriter name_w)
, mkSomeBinaryWriter @FastString fs_w
]
-- Make some initial state
symtab_next <- newFastMutInt 0
symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
let hie_symtab = HieSymbolTable {
hie_symtab_next = symtab_next,
hie_symtab_map = symtab_map }
dict_next_ref <- newFastMutInt 0
dict_map_ref <- newIORef emptyUFM
let hie_dict = HieDictionary {
hie_dict_next = dict_next_ref,
hie_dict_map = dict_map_ref }
-- put the main thing
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 <- tellBinWriter bh
putAt bh symtab_p_p symtab_p
seekBinWriter bh symtab_p
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the front of the file
dict_p <- tellBinWriter bh
putAt bh dict_p_p dict_p
seekBinWriter bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt dict_next_ref
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
-- Discard number of written elements
-- Order matters! See Note [Order of deduplication tables during iface binary serialisation]
_ <- putAllTables bh [fs_tbl, name_tbl, iface_tbl] $ do
put_ bh hiefile
-- and send the result to the file
createDirectoryIfMissing True (takeDirectory hie_file_path)
writeBinMem bh hie_file_path
return ()
initWriteNameTable :: IO (WriterTable, BinaryWriter Name)
initWriteNameTable = do
symtab_next <- newFastMutInt 0
symtab_map <- newIORef emptyUFM
let bin_symtab =
HieSymbolTable
{ hie_symtab_next = symtab_next
, hie_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
)
initReadNameTable :: NameCache -> IO (ReaderTable Name)
initReadNameTable cache = do
return $
ReaderTable
{ getTable = \bh -> getSymbolTable bh cache
, mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl)
}
data HieFileResult
= HieFileResult
{ hie_file_result_version :: Integer
......@@ -216,50 +215,32 @@ readHieFileHeader file bh0 = do
readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile
readHieFileContents bh0 name_cache = do
dict <- get_dictionary bh0
bhRef <- newIORef (error "used too soon")
-- It is important this is passed to 'getTable'
ud <- unsafeInterleaveIO (readIORef bhRef)
fsReaderTable <- initFastStringReaderTable
nameReaderTable <- initReadNameTable name_cache
ifaceTypeReaderTable <- initReadIfaceTypeTable ud
-- read the symbol table so we are capable of reading the actual data
bh1 <- do
let bh1 = setReaderUserData bh0
$ newReadState (error "getSymtabName")
(getDictFastString dict)
symtab <- get_symbol_table bh1
let bh1' = setReaderUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return bh1'
bh1 <-
foldM (\bh tblReader -> tblReader bh) bh0
[ get_dictionary fsReaderTable
, get_dictionary nameReaderTable
, get_dictionary ifaceTypeReaderTable
]
-- load the actual data
get bh1
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
data_p <- tellBinReader bin_handle
seekBinReader bin_handle dict_p
dict <- getDictionary bin_handle
seekBinReader bin_handle data_p
return dict
get_symbol_table bh1 = do
symtab_p <- get bh1
data_p' <- tellBinReader bh1
seekBinReader bh1 symtab_p
symtab <- getSymbolTable bh1 name_cache
seekBinReader bh1 data_p'
return symtab
putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
out <- readIORef out_r
let !unique = getUnique f
case lookupUFM_Directly out unique of
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out unique (j, f)
get_dictionary tbl bin_handle = do
fsTable <- Binary.forwardGet bin_handle (getTable tbl bin_handle)
let
fsReader = mkReaderFromTable tbl fsTable
bhFs = addReaderToUserData fsReader bin_handle
pure bhFs
putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
......
......@@ -162,15 +162,15 @@ getEvidenceTree refmap var = go emptyNameSet var
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
where
go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))
go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b
go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b
go (HCastTy a) = a
go HCoercionTy = IfaceTyVar "<coercion type>"
go HCoercionTy = IfaceTyVar (mkIfLclName "<coercion type>")
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
-- This isn't fully faithful - we can't produce the 'Inferred' case
......
......@@ -26,6 +26,7 @@ module GHC.Iface.Load (
loadInterface,
loadSysInterface, loadUserInterface, loadPluginInterface,
findAndReadIface, readIface, writeIface,
flagsToIfCompression,
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
......@@ -965,11 +966,18 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do
-- | Write interface file
writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()
writeIface logger profile hi_file_path new_iface
writeIface :: Logger -> Profile -> CompressionIFace -> FilePath -> ModIface -> IO ()
writeIface logger profile compression_level hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
let printer = TraceBinIFace (debugTraceMsg logger 3)
writeBinIface profile printer hi_file_path new_iface
writeBinIface profile printer compression_level hi_file_path new_iface
flagsToIfCompression :: DynFlags -> CompressionIFace
flagsToIfCompression dflags = case ifCompression dflags of
0 -> NormalCompression
1 -> NormalCompression
2 -> SafeExtraCompression
_ -> MaximalCompression
-- | @readIface@ tries just the one file.
--
......
......@@ -1216,8 +1216,8 @@ addFingerprints hsc_env iface0
getOcc (IfLclTopBndr fs _ _ details) =
case details of
IfRecSelId { ifRecSelFirstCon = first_con }
-> mkRecFieldOccFS (getOccFS first_con) fs
_ -> mkVarOccFS fs
-> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs)
_ -> mkVarOccFS (ifLclNameFS fs)
binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)
......
......@@ -14,6 +14,7 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
import GHC.Iface.Type (putIfaceType)
fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
......@@ -34,8 +35,12 @@ computeFingerprint put_nonbinding_name a = do
put_ bh a
fingerprintBinMem bh
where
set_user_data bh =
setWriterUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
set_user_data bh = setWriterUserData bh $ mkWriterUserData
[ mkSomeBinaryWriter $ mkWriter putIfaceType
, mkSomeBinaryWriter $ mkWriter put_nonbinding_name
, mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally
, mkSomeBinaryWriter $ mkWriter putFS
]
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
......
......@@ -632,6 +632,7 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
| IfaceSCC CostCentre Bool Bool -- from ProfNote
......@@ -1026,7 +1027,7 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
text "{-# MINIMAL" <+>
pprBooleanFormula
(\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
(\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>
text "#-}"
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
......
......@@ -10,7 +10,8 @@ This module defines interface types and binders
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Iface.Type (
IfExtName, IfLclName,
IfExtName,
IfLclName(..), mkIfLclName, ifLclNameFS,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceMCoercion(..),
......@@ -32,6 +33,8 @@ module GHC.Iface.Type (
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
ifTyConBinderVar, ifTyConBinderName,
-- Binary utilities
putIfaceType, getIfaceType, ifaceTypeSharedByte,
-- Equality testing
isIfaceLiftedTypeKind,
......@@ -89,10 +92,13 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
import Data.Maybe (isJust)
import Data.Proxy
import qualified Data.Semigroup as Semi
import Data.Word (Word8)
import Control.Arrow (first)
import Control.DeepSeq
import Control.Monad ((<$!>))
import qualified Data.Semigroup as Semi
import Data.Maybe( isJust )
{-
************************************************************************
......@@ -102,7 +108,20 @@ import Data.Maybe( isJust )
************************************************************************
-}
type IfLclName = FastString -- A local name in iface syntax
-- | A local name in iface syntax
newtype IfLclName = IfLclName
{ getIfLclName :: LexicalFastString
} deriving (Eq, Ord, Show)
instance Uniquable IfLclName where
getUnique = getUnique . ifLclNameFS
ifLclNameFS :: IfLclName -> FastString
ifLclNameFS = getLexicalFastString . getIfLclName
mkIfLclName :: FastString -> IfLclName
mkIfLclName = IfLclName . LexicalFastString
type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax
-- (However Internal or System Names never should)
......@@ -110,6 +129,8 @@ type IfExtName = Name -- An External or WiredIn Name can appear in Iface synta
data IfaceBndr -- Local (non-top-level) binders
= IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
| IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
deriving (Eq, Ord)
type IfaceIdBndr = (IfaceType, IfLclName, IfaceType)
type IfaceTvBndr = (IfLclName, IfaceKind)
......@@ -178,6 +199,7 @@ data IfaceType
-- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression
-- in interface file size (in GHC's boot libraries).
-- See !3987.
deriving (Eq, Ord)
type IfaceMult = IfaceType
......@@ -186,9 +208,9 @@ type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
| IfaceStrTyLit LexicalFastString
| IfaceCharTyLit Char
deriving (Eq)
deriving (Eq, Ord)
type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag
......@@ -230,6 +252,7 @@ data IfaceAppArgs
-- arguments in @{...}.
IfaceAppArgs -- The rest of the arguments
deriving (Eq, Ord)
instance Semi.Semigroup IfaceAppArgs where
IA_Nil <> xs = xs
......@@ -256,7 +279,7 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
-- See Note [Sharing IfaceTyConInfo] for why
-- sharing is so important for 'IfaceTyConInfo'.
}
deriving (Eq)
deriving (Eq, Ord)
-- | The various types of TyCons which have special, built-in syntax.
data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
......@@ -276,7 +299,7 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
-- that is actually being applied to two types
-- of the same kind. This affects pretty-printing
-- only: see Note [Equality predicates in IfaceType]
deriving (Eq)
deriving (Eq, Ord)
instance Outputable IfaceTyConSort where
ppr IfaceNormalTyCon = text "normal"
......@@ -370,7 +393,7 @@ data IfaceTyConInfo -- Used only to guide pretty-printing
-- should be printed as 'D to distinguish it from
-- an existing type constructor D.
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
deriving (Eq, Ord)
-- | This smart constructor allows sharing of the two most common
-- cases. See Note [Sharing IfaceTyConInfo]
......@@ -420,7 +443,7 @@ This one change leads to an 15% reduction in residency for GHC when embedding
data IfaceMCoercion
= IfaceMRefl
| IfaceMCo IfaceCoercion
| IfaceMCo IfaceCoercion deriving (Eq, Ord)
data IfaceCoercion
= IfaceReflCo IfaceType
......@@ -445,11 +468,13 @@ data IfaceCoercion
| IfaceSubCo IfaceCoercion
| IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType]
| IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
deriving (Eq, Ord)
data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
deriving (Eq, Ord)
{- Note [Holes in IfaceCoercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -621,11 +646,11 @@ type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType]
mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
-- See Note [Substitution on IfaceType]
mkIfaceTySubst eq_spec = mkFsEnv eq_spec
mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec)
inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
-- See Note [Substitution on IfaceType]
inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs))
substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
-- See Note [Substitution on IfaceType]
......@@ -681,7 +706,7 @@ substIfaceAppArgs env args
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
| Just ty <- lookupFsEnv env tv = ty
| Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty
| otherwise = IfaceTyVar tv
......@@ -1190,7 +1215,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
| isInvisibleForAllTyFlag argf -- Don't default *visible* quantification
-- or we get the mess in #13963
, Just substituted_ty <- check_substitution var_kind
= let subs' = extendFsEnv subs var substituted_ty
= let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty
-- Record that we should replace it with LiftedRep/Lifted/Many,
-- and recurse, discarding the forall
in go subs' True ty
......@@ -1198,7 +1223,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
go subs rank1 (IfaceForAllTy bndr ty)
= IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty)
go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of
go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of
Just s -> s
Nothing -> ty
......@@ -1626,7 +1651,7 @@ pprTyTcApp ctxt_prec tc tys =
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
Required (IA_Arg ty Required IA_Nil) <- tys
-> maybeParen ctxt_prec funPrec
$ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
$ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not debug
......@@ -2014,6 +2039,9 @@ pprIfaceUnivCoProv (IfacePluginProv s)
= text "plugin" <+> doubleQuotes (text s)
-------------------
instance Outputable IfLclName where
ppr = ppr . ifLclNameFS
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
......@@ -2171,38 +2199,70 @@ ppr_parend_preds :: [IfacePredType] -> SDoc
ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
put_ _ (IfaceFreeTyVar tv)
= pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
put_ bh ty =
case findUserDataWriter Proxy bh of
tbl -> putEntry tbl bh ty
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 0
put_ bh aa
put_ bh ab
put_ bh (IfaceTyVar ad) = do
putByte bh 1
put_ bh ad
put_ bh (IfaceAppTy ae af) = do
putByte bh 2
put_ bh ae
put_ bh af
put_ bh (IfaceFunTy af aw ag ah) = do
putByte bh 3
put_ bh af
put_ bh aw
put_ bh ag
put_ bh ah
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceCastTy a b)
= do { putByte bh 6; put_ bh a; put_ bh b }
put_ bh (IfaceCoercionTy a)
= do { putByte bh 7; put_ bh a }
put_ bh (IfaceTupleTy s i tys)
= do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
put_ bh (IfaceLitTy n)
= do { putByte bh 9; put_ bh n }
get bh = getIfaceTypeShared bh
get bh = do
-- | This is the byte tag we expect to read when the next
-- value is not an 'IfaceType' value, but an offset into a
-- lookup value.
--
-- Must not overlap with any byte tag in 'getIfaceType'.
ifaceTypeSharedByte :: Word8
ifaceTypeSharedByte = 99
-- | Like 'getIfaceType' but checks for a specific byte tag
-- that indicates that we won't be able to read a 'IfaceType' value
-- but rather an offset into a lookup table. Consequentially,
-- we look up the value for the 'IfaceType' in the look up table.
--
-- See Note [Deduplication during iface binary serialisation]
-- for details.
getIfaceTypeShared :: ReadBinHandle -> IO IfaceType
getIfaceTypeShared bh = do
start <- tellBinReader bh
tag <- getByte bh
if ifaceTypeSharedByte == tag
then case findUserDataReader Proxy bh of
tbl -> getEntry tbl bh
else seekBinReader bh start >> getIfaceType bh
putIfaceType :: WriteBinHandle -> IfaceType -> IO ()
putIfaceType _ (IfaceFreeTyVar tv)
= pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
putIfaceType bh (IfaceForAllTy aa ab) = do
putByte bh 0
put_ bh aa
put_ bh ab
putIfaceType bh (IfaceTyVar ad) = do
putByte bh 1
put_ bh ad
putIfaceType bh (IfaceAppTy ae af) = do
putByte bh 2
put_ bh ae
put_ bh af
putIfaceType bh (IfaceFunTy af aw ag ah) = do
putByte bh 3
put_ bh af
put_ bh aw
put_ bh ag
put_ bh ah
putIfaceType bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
putIfaceType bh (IfaceCastTy a b)
= do { putByte bh 6; put_ bh a; put_ bh b }
putIfaceType bh (IfaceCoercionTy a)
= do { putByte bh 7; put_ bh a }
putIfaceType bh (IfaceTupleTy s i tys)
= do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
putIfaceType bh (IfaceLitTy n)
= do { putByte bh 9; put_ bh n }
getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType
getIfaceType bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
......@@ -2230,6 +2290,13 @@ instance Binary IfaceType where
_ -> do n <- get bh
return (IfaceLitTy n)
instance Binary IfLclName where
put_ bh = put_ bh . ifLclNameFS
get bh = do
fs <- get bh
pure $ IfLclName $ LexicalFastString fs
instance Binary IfaceMCoercion where
put_ bh IfaceMRefl =
putByte bh 1
......@@ -2475,6 +2542,9 @@ instance NFData IfaceTyConSort where
IfaceSumTyCon arity -> rnf arity
IfaceEqualityTyCon -> ()
instance NFData IfLclName where
rnf (IfLclName lfs) = rnf lfs
instance NFData IfaceTyConInfo where
rnf (IfaceTyConInfo f s) = f `seq` rnf s
......
{-# LANGUAGE TypeFamilies #-}
module GHC.Iface.Type.Map where
import GHC.Prelude
import GHC.Data.TrieMap
import GHC.Iface.Type
import qualified Data.Map as Map
import Data.Functor.Compose
import GHC.Types.Basic
import Control.Monad ((>=>))
import GHC.Types.Unique.DFM
import Data.Functor.Product
import GHC.Types.Var (VarBndr(..))
newtype IfaceTypeMap a = IfaceTypeMap (IfaceTypeMapG a)
instance Functor IfaceTypeMap where
fmap f (IfaceTypeMap m) = IfaceTypeMap (fmap f m)
instance TrieMap IfaceTypeMap where
type Key IfaceTypeMap = IfaceType
emptyTM = IfaceTypeMap emptyTM
lookupTM k (IfaceTypeMap m) = lookupTM k m
alterTM k f (IfaceTypeMap m) = IfaceTypeMap (alterTM k f m)
filterTM f (IfaceTypeMap m) = IfaceTypeMap (filterTM f m)
foldTM f (IfaceTypeMap m) = foldTM f m
type IfaceTypeMapG = GenMap IfaceTypeMapX
data IfaceTypeMapX a
= IFM { ifm_lit :: IfaceLiteralMap a
, ifm_var :: UniqDFM IfLclName a
, ifm_app :: IfaceTypeMapG (IfaceAppArgsMap a)
, ifm_fun_ty :: FunTyFlagMap (IfaceTypeMapG (IfaceTypeMapG (IfaceTypeMapG a)))
, ifm_ty_con_app :: IfaceTyConMap (IfaceAppArgsMap a)
, ifm_forall_ty :: IfaceForAllBndrMap (IfaceTypeMapG a)
, ifm_cast_ty :: IfaceTypeMapG (IfaceCoercionMap a)
, ifm_coercion_ty :: IfaceCoercionMap a
, ifm_tuple_ty :: TupleSortMap (PromotionFlagMap (IfaceAppArgsMap a)) }
type IfaceLiteralMap = Map.Map IfaceTyLit
type FunTyFlagMap = Map.Map FunTyFlag
type IfaceTyConMap = Map.Map IfaceTyCon
type ForAllTyFlagMap = Map.Map ForAllTyFlag
type IfaceCoercionMap = Map.Map IfaceCoercion
type TupleSortMap = Map.Map TupleSort
type PromotionFlagMap = Map.Map PromotionFlag
type IfaceForAllBndrMap = Compose IfaceBndrMap ForAllTyFlagMap
type IfaceIdBndrMap = Compose IfaceTypeMapG (Compose (UniqDFM IfLclName) IfaceTypeMapG)
type IfaceTvBndrMap = Compose (UniqDFM IfLclName) IfaceTypeMapG
type IfaceBndrMap = Product IfaceIdBndrMap IfaceTvBndrMap
type IfaceAppArgsMap a = ListMap (Compose IfaceTypeMapG ForAllTyFlagMap) a
emptyE :: IfaceTypeMapX a
emptyE = IFM { ifm_lit = emptyTM
, ifm_var = emptyTM
, ifm_app = emptyTM
, ifm_fun_ty = emptyTM
, ifm_ty_con_app = emptyTM
, ifm_forall_ty = emptyTM
, ifm_cast_ty = emptyTM
, ifm_coercion_ty = emptyTM
, ifm_tuple_ty = emptyTM }
instance Functor IfaceTypeMapX where
fmap f IFM { ifm_lit = ilit
, ifm_var = ivar
, ifm_app = iapp
, ifm_fun_ty = ift
, ifm_ty_con_app = itc
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
, ifm_tuple_ty = itup }
= IFM { ifm_lit = fmap f ilit
, ifm_var = fmap f ivar
, ifm_app = fmap (fmap f) iapp
, ifm_fun_ty = fmap (fmap (fmap (fmap f))) ift
, ifm_ty_con_app = fmap (fmap f) itc
, ifm_forall_ty = fmap (fmap f) ifal
, ifm_cast_ty = fmap (fmap f) icast
, ifm_coercion_ty = fmap f ico
, ifm_tuple_ty = fmap (fmap (fmap f)) itup }
instance TrieMap IfaceTypeMapX where
type Key IfaceTypeMapX = IfaceType
emptyTM = emptyE
lookupTM = lkE
alterTM = xtE
foldTM = fdE
filterTM = ftE
{-# INLINE lookupTM #-}
{-# INLINE alterTM #-}
{-# INLINE ftE #-}
ftE :: (a -> Bool) -> IfaceTypeMapX a -> IfaceTypeMapX a
ftE f IFM { ifm_lit = ilit
, ifm_var = ivar
, ifm_app = iapp
, ifm_fun_ty = ift
, ifm_ty_con_app = itc
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
, ifm_tuple_ty = itup }
= IFM { ifm_lit = filterTM f ilit
, ifm_var = filterTM f ivar
, ifm_app = fmap (filterTM f) iapp
, ifm_fun_ty = fmap (fmap (fmap (filterTM f))) ift
, ifm_ty_con_app = fmap (filterTM f) itc
, ifm_forall_ty = fmap (filterTM f) ifal
, ifm_cast_ty = fmap (filterTM f) icast
, ifm_coercion_ty = filterTM f ico
, ifm_tuple_ty = fmap (fmap (filterTM f)) itup }
{-# INLINE fdE #-}
fdE :: (a -> b -> b) -> IfaceTypeMapX a -> b -> b
fdE f IFM { ifm_lit = ilit
, ifm_var = ivar
, ifm_app = iapp
, ifm_fun_ty = ift
, ifm_ty_con_app = itc
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
, ifm_tuple_ty = itup }
= foldTM f ilit . foldTM f ivar . foldTM (foldTM f) iapp
. foldTM (foldTM (foldTM (foldTM f))) ift
. foldTM (foldTM f) itc
. foldTM (foldTM f) ifal
. foldTM (foldTM f) icast
. foldTM f ico
. foldTM (foldTM (foldTM f)) itup
bndrToKey :: IfaceBndr -> Either (IfaceType, (IfLclName, IfaceType)) IfaceTvBndr
bndrToKey (IfaceIdBndr (a,b,c)) = Left (a, (b,c))
bndrToKey (IfaceTvBndr k) = Right k
{-# INLINE lkE #-}
lkE :: IfaceType -> IfaceTypeMapX a -> Maybe a
lkE it ifm = go it ifm
where
go (IfaceFreeTyVar {}) = error "ftv"
go (IfaceTyVar var) = ifm_var >.> lookupTM var
go (IfaceLitTy l) = ifm_lit >.> lookupTM l
go (IfaceAppTy ift args) = ifm_app >.> lkG ift >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
go (IfaceFunTy ft t1 t2 t3) = ifm_fun_ty >.> lookupTM ft >=> lkG t1 >=> lkG t2 >=> lkG t3
go (IfaceForAllTy (Bndr a b) t) = ifm_forall_ty >.> lookupTM (bndrToKey a,b) >=> lkG t
go (IfaceTyConApp tc args) = ifm_ty_con_app >.> lookupTM tc >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
go (IfaceCastTy ty co) = ifm_cast_ty >.> lkG ty >=> lookupTM co
go (IfaceCoercionTy co) = ifm_coercion_ty >.> lookupTM co
go (IfaceTupleTy sort prom args) = ifm_tuple_ty >.> lookupTM sort >=> lookupTM prom >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
{-# INLINE xtE #-}
xtE :: IfaceType -> XT a -> IfaceTypeMapX a -> IfaceTypeMapX a
xtE (IfaceFreeTyVar {}) _ _ = error "ftv"
xtE (IfaceTyVar var) f m = m { ifm_var = ifm_var m |> alterTM var f }
xtE (IfaceLitTy l) f m = m { ifm_lit = ifm_lit m |> alterTM l f }
xtE (IfaceAppTy ift args) f m = m { ifm_app = ifm_app m |> xtG ift |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
xtE (IfaceFunTy ft t1 t2 t3) f m = m { ifm_fun_ty = ifm_fun_ty m |> alterTM ft |>> xtG t1 |>> xtG t2 |>> xtG t3 f }
xtE (IfaceForAllTy (Bndr a b) t) f m = m { ifm_forall_ty = ifm_forall_ty m |> alterTM (bndrToKey a,b) |>> xtG t f }
xtE (IfaceTyConApp tc args) f m = m { ifm_ty_con_app = ifm_ty_con_app m |> alterTM tc |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
xtE (IfaceCastTy ty co) f m = m { ifm_cast_ty = ifm_cast_ty m |> xtG ty |>> alterTM co f }
xtE (IfaceCoercionTy co) f m = m { ifm_coercion_ty = ifm_coercion_ty m |> alterTM co f }
xtE (IfaceTupleTy sort prom args) f m = m { ifm_tuple_ty = ifm_tuple_ty m |> alterTM sort |>> alterTM prom |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
......@@ -733,7 +733,7 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
{ res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res
; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
; return (ATyCon tycon) }
where
......@@ -782,7 +782,7 @@ tc_iface_decl _parent ignore_prags
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
; let mindef_occ = fromIfaceBooleanFormula if_mindef
; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
......@@ -936,8 +936,8 @@ mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
; let occ = case details' of
RecSelId { sel_tycon = parent }
-> let con_fs = getOccFS $ recSelFirstConName parent
in mkRecFieldOccFS con_fs raw_name
_ -> mkVarOccFS raw_name
in mkRecFieldOccFS con_fs (ifLclNameFS raw_name)
_ -> mkVarOccFS (ifLclNameFS raw_name)
; name <- newIfaceName occ }
info' <- tcIdInfo False TopLevel name ty info
let new_id = mkGlobalId details' name ty info'
......@@ -1443,7 +1443,7 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
-----------------------------------------
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit (getLexicalFastString n))
tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
{-
......@@ -1487,7 +1487,7 @@ tcIfaceCo = go
go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
go_var :: FastString -> IfL CoVar
go_var :: IfLclName -> IfL CoVar
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
......@@ -1563,7 +1563,7 @@ tcIfaceExpr (IfaceECase scrut ty)
tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr))
let
scrut_ty = exprType scrut'
case_mult = ManyTy
......@@ -1582,7 +1582,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
= do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel name ty' info
......@@ -1600,7 +1600,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
; return (Let (Rec pairs') body') } }
where
tc_rec_bndr (IfLetBndr fs ty _ ji)
= do { name <- newIfaceName (mkVarOccFS fs)
= do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
tc_pair (IfLetBndr _ _ info _, rhs) id
......@@ -1657,12 +1657,12 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt mult con inst_tys arg_strs rhs }
tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr
tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr
-> IfL CoreAlt
tcIfaceDataAlt mult con inst_tys arg_strs rhs
= do { uniqs <- getUniquesM
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs mult con inst_tys
= dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
; rhs' <- extendIfaceEnvs ex_tvs $
extendIfaceIdEnv arg_ids $
......@@ -2033,7 +2033,7 @@ tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
-- - axioms for type-level literals (Nat and Symbol),
-- enumerated in typeNatCoAxiomRules
tcIfaceCoAxiomRule n
| Just ax <- lookupUFM typeNatCoAxiomRules n
| Just ax <- lookupUFM typeNatCoAxiomRules (ifLclNameFS n)
= return ax
| otherwise
= pprPanic "tcIfaceCoAxiomRule" (ppr n)
......@@ -2077,7 +2077,7 @@ tcIfaceImplicit n = do
bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceId (w, fs, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS fs)
= do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; w' <- tcIfaceType w
; let id = mkLocalIdOrCoVar name w' ty'
......@@ -2120,7 +2120,7 @@ bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
= do { name <- newIfaceName (mkTyVarOccFS (ifLclNameFS occ))
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
......