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)
  • Sebastian Graf's avatar
    CorePrep: Attach evaldUnfolding to floats to detect more values · e4a7f0b8
    Sebastian Graf authored
    See `Note [Pin evaluatedness on floats]`.
    e4a7f0b8
  • Sebastian Graf's avatar
    Make DataCon workers strict in strict fields (#20749) · a4713774
    Sebastian Graf authored
    
    This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand
    Analysis so that they exploit and maintain strictness of DataCon workers. See
    `Note [Strict fields in Core]` for details.
    
    Very little needed to change, and it puts field seq insertion done by Tag
    Inference into a new perspective: That of *implementing* strict field semantics.
    Before Tag Inference, DataCon workers are strict. Afterwards they are
    effectively lazy and field seqs happen around use sites. History has shown
    that there is no other way to guarantee taggedness and thus the STG Strict Field
    Invariant.
    
    Knock-on changes:
    
      * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments
        instead of recursing into `exprIsHNF`. That regressed the termination
        analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made
        it call `exprOkForSpeculation`, too.
    
      * There's a small regression in Demand Analysis, visible in the changed test
        output of T16859: Previously, a field seq on a variable would give that
        variable a "used exactly once" demand, now it's "used at least once",
        because `dmdTransformDataConSig` accounts for future uses of the field
        that actually all go through the case binder (and hence won't re-enter the
        potential thunk). The difference should hardly be observable.
    
      * The Simplifier's fast path for data constructors only applies to lazy
        data constructors now. I observed regressions involving Data.Binary.Put's
        `Pair` data type.
    
      * Unfortunately, T21392 does no longer reproduce after this patch, so I marked
        it as "not broken" in order to track whether we regress again in the future.
    
    Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas
    in #21497 and #22475).
    
    Co-Authored-By: default avatarJaro Reinders <jaro.reinders@gmail.com>
    a4713774
Showing
with 648 additions and 311 deletions
......@@ -640,6 +640,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri
-- See Note [Constructor tag allocation] and #14657
data_con = mkDataCon dc_name declared_infix prom_info
(map (const no_bang) arg_tys)
(map (const HsLazy) arg_tys)
(map (const NotMarkedStrict) arg_tys)
[] -- No labelled fields
tyvars ex_tyvars
conc_tyvars
......
......@@ -42,7 +42,7 @@ module GHC.Core (
foldBindersOfBindStrict, foldBindersOfBindsStrict,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectNBinders, collectNValBinders_maybe,
collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds,
collectFunSimple,
exprToType,
......@@ -1029,6 +1029,64 @@ tail position: A cast changes the type, but the type must be the same. But
operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for
ideas how to fix this.
Note [Strict fields in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Evaluating a data constructor worker evaluates its strict fields.
In other words, if `MkT` is strict in its first field and `xs` reduces to
`error "boom"`, then `MkT xs b` will throw that error.
Consequently, it is sound to seq the field before the call to the constructor,
e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`.
Let's call this transformation "field seq insertion".
Note in particular that the data constructor application `MkT xs b` above is
*not* a value, unless `xs` is!
This has pervasive effect on the Core pipeline:
* `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the
strict arguments of a DataCon worker are values/ok-for-spec themselves.
* `exprIsConApp_maybe` inserts field seqs in the `FloatBind`s it returns, so
that the Simplifier, Constant-folding, the pattern-match checker, etc.
all see the inserted field seqs when they match on strict workers. Often this
is just to emphasise strict semantics, but for case-of-known constructor
and case-to-let, field insertion is *vital*, otherwise these transformations
would lose field seqs that the user expects to happen, perhaps in order to
fix a space leak. For example,
case MkT xs b of MkT xs' b' -> b'
optimising this expression with case-of-known-con must leave behind the
field seq on `xs`, thus
case xs of xs' { __DEFAULT -> b }
* The demand signature of a data constructor is strict in strict field
position when otherwise it is lazy. Likewise the demand *transformer*
of a DataCon worker can stricten up demands on strict field args.
See Note [Demand transformer for data constructors].
* In the absence of `-fpedantic-bottoms`, it is still possible that some seqs
are ultimately dropped or delayed due to eta-expansion.
See Note [Dealing with bottom].
Strict field semantics is exploited in STG by Note [Tag Inference]:
It performs field seq insertion to statically guarantee *taggedness* of strict
fields, establishing the Note [STG Strict Field Invariant]. (Happily, most
of those seqs are immediately detected as redundant by tag inference and are
omitted.) From then on, DataCon worker semantics are actually lazy, hence it is
important that STG passes maintain the Strict Field Invariant.
Historical Note:
The delightfully simple description of strict field semantics is the result of
a long saga (#20749, the bits about strict data constructors in #21497, #22475),
where we tried a more lenient (but actually not) semantics first that would
allow both strict and lazy implementations of DataCon workers. This was favoured
because the "pervasive effect" throughout the compiler was deemed too large
(when it really turned out to be quite modest).
Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the
same way as above, otherwise the analysis would not be conservative wrt. the
lenient semantics (which includes the strict one). It is also much harder to
explain and maintain, as it turned out.
************************************************************************
* *
In/Out type synonyms
......@@ -2158,6 +2216,17 @@ collectArgs expr
go (App f a) as = go f (a:as)
go e as = (e, as)
-- | Takes a nested application expression and returns the function
-- being applied and the arguments to which it is applied
collectValArgs :: Expr b -> (Expr b, [Arg b])
collectValArgs expr
= go expr []
where
go (App f a) as
| isValArg a = go f (a:as)
| otherwise = go f as
go e as = (e, as)
-- | Takes a nested application expression and returns the function
-- being applied. Looking through casts and ticks to find it.
collectFunSimple :: Expr b -> Expr b
......
......@@ -49,18 +49,20 @@ module GHC.Core.DataCon (
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe,
dataConImplicitTyThings,
dataConRepStrictness, dataConImplBangs, dataConBoxer,
dataConRepStrictness,
dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon,
isLazyDataConRep,
isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,
isUnboxedSumDataCon, isCovertGadtDataCon,
isVanillaDataCon, isNewDataCon, isTypeDataCon,
classDataCon, dataConCannotMatch,
dataConUserTyVarsNeedWrapper, checkDataConTyVars,
isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,
isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,
specialPromotedDc,
-- ** Promotion related functions
......@@ -524,6 +526,18 @@ data DataCon
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
dcImplBangs :: [HsImplBang],
-- The actual decisions made (including failures)
-- about the original arguments; 1-1 with orig_arg_tys
-- See Note [Bangs on data constructor arguments]
dcStricts :: [StrictnessMark],
-- One mark for every field of the DataCon worker;
-- if it's empty, then all fields are lazy,
-- otherwise 1-1 with dataConRepArgTys.
-- See also Note [Strict fields in Core] in GHC.Core
-- for the effect on the strictness signature
dcFields :: [FieldLabel],
-- Field labels for this constructor, in the
-- same order as the dcOrigArgTys;
......@@ -826,13 +840,6 @@ data DataConRep
-- after unboxing and flattening,
-- and *including* all evidence args
, dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys
-- See also Note [Data-con worker strictness]
, dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures)
-- about the original arguments; 1-1 with orig_arg_tys
-- See Note [Bangs on data constructor arguments]
}
type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon
......@@ -901,43 +908,8 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty
instance Outputable EqSpec where
ppr (EqSpec tv ty) = ppr (tv, ty)
{- Note [Data-con worker strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we do *not* say the worker Id is strict even if the data
constructor is declared strict
e.g. data T = MkT ![Int] Bool
Even though most often the evals are done by the *wrapper* $WMkT, there are
situations in which tag inference will re-insert evals around the worker.
So for all intents and purposes the *worker* MkT is strict, too!
Unfortunately, if we exposed accurate strictness of DataCon workers, we'd
see the following transformation:
f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs
==> { drop-seq, binder swap on xs' }
f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs
==> { case-to-let }
f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs!
I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs`
and then doing case-to-let. The issue is that `exprIsHNF` currently says that
every DataCon worker app is a value. The implicit assumption is that surrounding
evals will have evaluated strict fields like `xs` before! But now that we had
just dropped the eval on `xs`, that assumption is no longer valid.
Long story short: By keeping the demand signature lazy, the Simplifier will not
drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others
remains sound.
Similarly, during demand analysis in dmdTransformDataConSig, we bump up the
field demand with `C_01`, *not* `C_11`, because the latter exposes too much
strictness that will drop the eval on `xs` above.
This issue is discussed at length in
"Failed idea: no wrappers for strict data constructors" in #21497 and #22475.
Note [Bangs on data constructor arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{- Note [Bangs on data constructor arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT !Int {-# UNPACK #-} !Int Bool
......@@ -963,8 +935,8 @@ Terminology:
the flag settings in the importing module.
Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make
* The dcr_bangs field of the dcRep field records the [HsImplBang]
If T was defined in this module, Without -O the dcr_bangs might be
* The dcImplBangs field records the [HsImplBang]
If T was defined in this module, Without -O the dcImplBangs might be
[HsStrict _, HsStrict _, HsLazy]
With -O it might be
[HsStrict _, HsUnpack _, HsLazy]
......@@ -973,6 +945,19 @@ Terminology:
With -XStrictData it might be
[HsStrict _, HsUnpack _, HsStrict _]
* Core passes will often need to know whether the DataCon worker or wrapper in
an application is strict in some (lifted) field or not. This is tracked in the
demand signature attached to a DataCon's worker resp. wrapper Id.
So if you've got a DataCon dc, you can get the demand signature by
`idDmdSig (dataConWorkId dc)` and make out strict args by testing with
`isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives
you the demand signature of the wrapper, if it exists.
These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId,
compute from the single source of truth `dataConRepStrictness`, which is
generated from `dcStricts`.
Note [Detecting useless UNPACK pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to issue a warning when there's an UNPACK pragma in the source code,
......@@ -1008,7 +993,6 @@ we consult HsImplBang:
The boolean flag is used only for this warning.
See #11270 for motivation.
************************************************************************
* *
\subsection{Instances}
......@@ -1110,6 +1094,11 @@ isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True
isBanged HsLazy = False
isUnpacked :: HsImplBang -> Bool
isUnpacked (HsUnpack {}) = True
isUnpacked (HsStrict {}) = False
isUnpacked HsLazy = False
isSrcStrict :: SrcStrictness -> Bool
isSrcStrict SrcStrict = True
isSrcStrict _ = False
......@@ -1135,13 +1124,15 @@ cbvFromStrictMark MarkedStrict = MarkedCbv
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> TyConRepName -- ^ TyConRepName for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyCoVar] -- ^ Existentials.
-> Bool -- ^ Is the constructor declared infix?
-> TyConRepName -- ^ TyConRepName for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler
-> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyCoVar] -- ^ Existentials.
-> ConcreteTyVars
-- ^ TyVars which must be instantiated with
-- concrete types
......@@ -1163,7 +1154,9 @@ mkDataCon :: Name
-- Can get the tag from the TyCon
mkDataCon name declared_infix prom_info
arg_stricts -- Must match orig_arg_tys 1-1
arg_stricts -- Must match orig_arg_tys 1-1
impl_bangs -- Must match orig_arg_tys 1-1
str_marks -- Must be empty or match dataConRepArgTys 1-1
fields
univ_tvs ex_tvs conc_tvs user_tvbs
eq_spec theta
......@@ -1180,6 +1173,8 @@ mkDataCon name declared_infix prom_info
= con
where
is_vanilla = null ex_tvs && null eq_spec && null theta
str_marks' | not $ any isMarkedStrict str_marks = []
| otherwise = str_marks
con = MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
......@@ -1192,7 +1187,8 @@ mkDataCon name declared_infix prom_info
dcStupidTheta = stupid_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcSrcBangs = arg_stricts,
dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs,
dcStricts = str_marks',
dcFields = fields, dcTag = tag, dcRepType = rep_ty,
dcWorkId = work_id,
dcRep = rep,
......@@ -1435,20 +1431,25 @@ isNullarySrcDataCon dc = dataConSourceArity dc == 0
isNullaryRepDataCon :: DataCon -> Bool
isNullaryRepDataCon dc = dataConRepArity dc == 0
isLazyDataConRep :: DataCon -> Bool
-- ^ True <==> All fields are lazy
isLazyDataConRep dc = null (dcStricts dc)
dataConRepStrictness :: DataCon -> [StrictnessMark]
-- ^ Give the demands on the arguments of a
-- Core constructor application (Con dc args)
dataConRepStrictness dc = case dcRep dc of
NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
DCR { dcr_stricts = strs } -> strs
-- ^ Give the demands on the runtime arguments of a Core DataCon worker
-- application.
-- The length of the list matches `dataConRepArgTys` (e.g., the number
-- of runtime arguments).
dataConRepStrictness dc
| isLazyDataConRep dc
= replicate (dataConRepArity dc) NotMarkedStrict
| otherwise
= dcStricts dc
dataConImplBangs :: DataCon -> [HsImplBang]
-- The implementation decisions about the strictness/unpack of each
-- source program argument to the data constructor
dataConImplBangs dc
= case dcRep dc of
NoDataConRep -> replicate (dcSourceArity dc) HsLazy
DCR { dcr_bangs = bangs } -> bangs
dataConImplBangs dc = dcImplBangs dc
dataConBoxer :: DataCon -> Maybe DataConBoxer
dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
......
......@@ -1533,7 +1533,7 @@ myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty
-- See Note [Eta expanding through dictionaries]
-- See Note [Eta expanding through CallStacks]
cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e
cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e
-- | A version of 'isCheapApp' that considers results from arity analysis.
-- See Note [Arity analysis] for what's in the signature environment and why
......
......@@ -209,7 +209,7 @@ cprAnal, cprAnal'
-> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'
cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
cprAnal' env e
cprAnal' env e
cprAnal' _ (Lit lit) = (topCprType, Lit lit)
cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact
......@@ -296,9 +296,16 @@ data TermFlag -- Better than using a Bool
-- See Note [Nested CPR]
exprTerminates :: CoreExpr -> TermFlag
-- ^ A /very/ simple termination analysis.
exprTerminates e
| exprIsHNF e = Terminates -- A /very/ simple termination analysis.
| otherwise = MightDiverge
| exprIsHNF e = Terminates
| exprOkForSpeculation e = Terminates
| otherwise = MightDiverge
-- Annoyingly, we have to check both for HNF and ok-for-spec.
-- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing!
-- * `lvl` is an HNF if its unfolding is evaluated
-- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never
-- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables].
cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr)
-- Main function that takes care of /nested/ CPR. See Note [Nested CPR]
......@@ -367,8 +374,8 @@ cprTransformDataConWork env con args
, wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]
, args `lengthIs` wkr_arity
, ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]
-- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True
= CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))
= -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $
CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))
| otherwise
= topCprType
where
......@@ -505,7 +512,8 @@ cprAnalBind env id rhs
| isDataStructure id -- Data structure => no code => no need to analyse rhs
= (id, rhs, env)
| otherwise
= (id `setIdCprSig` sig', rhs', env')
= -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig')
(id `setIdCprSig` sig', rhs', env')
where
(rhs_ty, rhs') = cprAnal env rhs
-- possibly trim thunk CPR info
......
......@@ -835,6 +835,10 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint
from 'topDiv' to 'conDiv', leading to bugs, performance regressions and
complexity that didn't justify the single fixed testcase T13380c.
You might think that we should check for side-effects rather than just for
precise exceptions. Right you are! See Note [Side-effects and strictness]
for why we unfortunately do not.
Note [Demand analysis for recursive data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
T11545 features a single-product, recursive data type
......
......@@ -8,14 +8,13 @@
module GHC.Core.Opt.Simplify.Env (
-- * The simplifier mode
SimplMode(..), updMode,
smPedanticBottoms, smPlatform,
SimplMode(..), updMode, smPlatform,
-- * Environments
SimplEnv(..), pprSimplEnv, -- Temp not abstract
seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,
seOptCoercionOpts, sePhase, sePlatform, sePreInline,
seRuleOpts, seRules, seUnfoldingOpts,
mkSimplEnv, extendIdSubst, extendCvIdSubst,
extendTvSubst, extendCvSubst,
......@@ -235,9 +234,6 @@ seNames env = sm_names (seMode env)
seOptCoercionOpts :: SimplEnv -> OptCoercionOpts
seOptCoercionOpts env = sm_co_opt_opts (seMode env)
sePedanticBottoms :: SimplEnv -> Bool
sePedanticBottoms env = smPedanticBottoms (seMode env)
sePhase :: SimplEnv -> CompilerPhase
sePhase env = sm_phase (seMode env)
......@@ -292,9 +288,6 @@ instance Outputable SimplMode where
where
pp_flag f s = ppUnless f (text "no") <+> s
smPedanticBottoms :: SimplMode -> Bool
smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts)
smPlatform :: SimplMode -> Platform
smPlatform opts = roPlatform (sm_rule_opts opts)
......
......@@ -2204,14 +2204,14 @@ zap the SubstEnv. This is VITAL. Consider
We'll clone the inner \x, adding x->x' in the id_subst Then when we
inline y, we must *not* replace x by x' in the inlined copy!!
Note [Fast path for data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Fast path for lazy data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For applications of a data constructor worker, the full glory of
rebuildCall is a waste of effort;
* They never inline, obviously
* They have no rewrite rules
* They are not strict (see Note [Data-con worker strictness]
in GHC.Core.DataCon)
* Though they might be strict (see Note [Strict fields in Core] in GHC.Core),
we will exploit that strictness through their demand signature
So it's fine to zoom straight to `rebuild` which just rebuilds the
call in a very straightforward way.
......@@ -2235,7 +2235,7 @@ simplVar env var
simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplIdF env var cont
| isDataConWorkId var -- See Note [Fast path for data constructors]
| isDataConWorkId var -- See Note [Fast path for lazy data constructors]
= rebuild env (Var var) cont
| otherwise
= case substId env var of
......@@ -3420,7 +3420,7 @@ a case pattern. This is *important*. Consider
We really must record that b is already evaluated so that we don't
go and re-evaluate it when constructing the result.
See Note [Data-con worker strictness] in GHC.Core.DataCon
See Note [Strict fields in Core] in GHC.Core.
NB: simplLamBndrs preserves this eval info
......
......@@ -1277,11 +1277,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec
-- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] }
-- simplifier produces case exp of a { DEFAULT -> exp[x/a] }
= let arg' = subst_expr subst arg
bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type)
float = FloatCase arg' bndr DEFAULT []
subst' = subst_extend_in_scope subst bndr
in go subst' (float:floats) fun (CC (Var bndr : args) mco)
, (subst', float, bndr) <- case_bind subst arg arg_type
= go subst' (float:floats) fun (CC (Var bndr : args) mco)
| otherwise
= go subst floats fun (CC (subst_expr subst arg : args) mco)
......@@ -1324,8 +1321,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
| Just con <- isDataConWorkId_maybe fun
, count isValArg args == idArity fun
= succeedWith in_scope floats $
pushCoDataCon con args mco
, (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args
-- mkFieldSeqFloats: See Note [Strict fields in Core]
= succeedWith in_scope' (seq_floats ++ floats) $
pushCoDataCon con args' mco
-- Look through data constructor wrappers: they inline late (See Note
-- [Activation for data constructor wrappers]) but we want to do
......@@ -1411,6 +1410,38 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
extend (Right s) v e = Right (extendSubst s v e)
case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id)
case_bind subst expr expr_ty = (subst', float, bndr)
where
bndr = setCaseBndrEvald MarkedStrict $
uniqAway (subst_in_scope subst) $
mkWildValBinder ManyTy expr_ty
subst' = subst_extend_in_scope subst bndr
expr' = subst_expr subst expr
float = FloatCase expr' bndr DEFAULT []
mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr])
-- See Note [Strict fields in Core] for what a field seq is and why we
-- insert them
mkFieldSeqFloats in_scope dc args
| isLazyDataConRep dc
= (in_scope, [], args)
| otherwise
= (in_scope', floats', ty_args ++ val_args')
where
(ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args
(in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args
str_marks = dataConRepStrictness dc
do_one (str, arg) (in_scope,floats,args)
| NotMarkedStrict <- str = no_seq
| exprIsHNF arg = no_seq
| otherwise = (in_scope', float:floats, Var bndr:args)
where
no_seq = (in_scope, floats, arg:args)
(in_scope', float, bndr) =
case case_bind (Left in_scope) arg (exprType arg) of
(Left in_scope', float, bndr) -> (in_scope', float, bndr)
(right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right)
-- See Note [exprIsConApp_maybe on literal strings]
dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion
......
......@@ -55,7 +55,7 @@ module GHC.Core.Type (
splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,
splitForAllTyCoVar_maybe, splitForAllTyCoVar,
splitForAllTyVar_maybe, splitForAllCoVar_maybe,
splitPiTy_maybe, splitPiTy, splitPiTys,
splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,
getRuntimeArgTys,
mkTyConBindersPreferAnon,
mkPiTy, mkPiTys,
......@@ -290,6 +290,7 @@ import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Maybe ( orElse, isJust, firstJust )
import GHC.List (build)
-- $type_classification
-- #type_classification#
......@@ -2031,6 +2032,18 @@ splitPiTys ty = split ty ty []
split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
split orig_ty _ bs = (reverse bs, orig_ty)
collectPiTyBinders :: Type -> [PiTyBinder]
collectPiTyBinders ty = build $ \c n ->
let
split (ForAllTy b res) = Named b `c` split res
split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })
= Anon (Scaled w arg) af `c` split res
split ty | Just ty' <- coreView ty = split ty'
split _ = n
in
split ty
{-# INLINE collectPiTyBinders #-}
-- | Extracts a list of run-time arguments from a function type,
-- looking through newtypes to the right of arrows.
--
......
......@@ -1493,18 +1493,23 @@ in this (which it previously was):
in \w. v True
-}
--------------------
exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree]
exprIsWorkFree e = exprIsCheapX isWorkFreeApp e
exprIsCheap :: CoreExpr -> Bool
exprIsCheap e = exprIsCheapX isCheapApp e
-------------------------------------
type CheapAppFun = Id -> Arity -> Bool
-- Is an application of this function to n *value* args
-- always cheap, assuming the arguments are cheap?
-- True mainly of data constructors, partial applications;
-- but with minor variations:
-- isWorkFreeApp
-- isCheapApp
-- isExpandableApp
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool
{-# INLINE exprIsCheapX #-}
-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable
-- instead of having an unknown call to ok_app
-- instead of having an unknown call to ok_app
-- expandable: Only True for exprIsExpandable, where Case and Let are never
-- expandable.
exprIsCheapX ok_app expandable e
= ok e
where
ok e = go 0 e
......@@ -1515,7 +1520,7 @@ exprIsCheapX ok_app e
go _ (Type {}) = True
go _ (Coercion {}) = True
go n (Cast e _) = go n e
go n (Case scrut _ _ alts) = ok scrut &&
go n (Case scrut _ _ alts) = not expandable && ok scrut &&
and [ go n rhs | Alt _ _ rhs <- alts ]
go n (Tick t e) | tickishCounts t = False
| otherwise = go n e
......@@ -1523,90 +1528,26 @@ exprIsCheapX ok_app e
| otherwise = go n e
go n (App f e) | isRuntimeArg e = go (n+1) f && ok e
| otherwise = go n f
go n (Let (NonRec _ r) e) = go n e && ok r
go n (Let (Rec prs) e) = go n e && all (ok . snd) prs
go n (Let (NonRec _ r) e) = not expandable && go n e && ok r
go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs
-- Case: see Note [Case expressions are work-free]
-- App, Let: see Note [Arguments and let-bindings exprIsCheapX]
--------------------
exprIsWorkFree :: CoreExpr -> Bool
-- See Note [exprIsWorkFree]
exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e
{- Note [exprIsExpandable]
~~~~~~~~~~~~~~~~~~~~~~~~~~
An expression is "expandable" if we are willing to duplicate it, if doing
so might make a RULE or case-of-constructor fire. Consider
let x = (a,b)
y = build g
in ....(case x of (p,q) -> rhs)....(foldr k z y)....
We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),
but we do want
* the case-expression to simplify
(via exprIsConApp_maybe, exprIsLiteral_maybe)
* the foldr/build RULE to fire
(by expanding the unfolding during rule matching)
So we classify the unfolding of a let-binding as "expandable" (via the
uf_expandable field) if we want to do this kind of on-the-fly
expansion. Specifically:
* True of constructor applications (K a b)
* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.
(NB: exprIsCheap might not be true of this)
* False of case-expressions. If we have
let x = case ... in ...(case x of ...)...
we won't simplify. We have to inline x. See #14688.
* False of let-expressions (same reason); and in any case we
float lets out of an RHS if doing so will reveal an expandable
application (see SimplEnv.doFloatFromRhs).
* Take care: exprIsExpandable should /not/ be true of primops. I
found this in test T5623a:
let q = /\a. Ptr a (a +# b)
in case q @ Float of Ptr v -> ...q...
q's inlining should not be expandable, else exprIsConApp_maybe will
say that (q @ Float) expands to (Ptr a (a +# b)), and that will
duplicate the (a +# b) primop, which we should not do lightly.
(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
-}
--------------------
exprIsCheap :: CoreExpr -> Bool
-- See Note [exprIsCheap]
exprIsCheap e = exprIsCheapX isCheapApp False e
-------------------------------------
--------------------
exprIsExpandable :: CoreExpr -> Bool
-- See Note [exprIsExpandable]
exprIsExpandable e
= ok e
where
ok e = go 0 e
-- n is the number of value arguments
go n (Var v) = isExpandableApp v n
go _ (Lit {}) = True
go _ (Type {}) = True
go _ (Coercion {}) = True
go n (Cast e _) = go n e
go n (Tick t e) | tickishCounts t = False
| otherwise = go n e
go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
| otherwise = go n e
go n (App f e) | isRuntimeArg e = go (n+1) f && ok e
| otherwise = go n f
go _ (Case {}) = False
go _ (Let {}) = False
-------------------------------------
type CheapAppFun = Id -> Arity -> Bool
-- Is an application of this function to n *value* args
-- always cheap, assuming the arguments are cheap?
-- True mainly of data constructors, partial applications;
-- but with minor variations:
-- isWorkFreeApp
-- isCheapApp
exprIsExpandable e = exprIsCheapX isExpandableApp True e
isWorkFreeApp :: CheapAppFun
isWorkFreeApp fn n_val_args
......@@ -1626,7 +1567,7 @@ isCheapApp fn n_val_args
| isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions]
| otherwise
= case idDetails fn of
DataConWorkId {} -> True -- Actually handled by isWorkFreeApp
-- DataConWorkId {} -> _ -- Handled by isWorkFreeApp
RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
ClassOpId {} -> n_val_args == 1
PrimOpId op _ -> primOpIsCheap op
......@@ -1641,6 +1582,7 @@ isExpandableApp fn n_val_args
| isWorkFreeApp fn n_val_args = True
| otherwise
= case idDetails fn of
-- DataConWorkId {} -> _ -- Handled by isWorkFreeApp
RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
ClassOpId {} -> n_val_args == 1
PrimOpId {} -> False
......@@ -1672,6 +1614,50 @@ isExpandableApp fn n_val_args
I'm not sure why we have a special case for bottoming
functions in isCheapApp. Maybe we don't need it.
Note [exprIsExpandable]
~~~~~~~~~~~~~~~~~~~~~~~
An expression is "expandable" if we are willing to duplicate it, if doing
so might make a RULE or case-of-constructor fire. Consider
let x = (a,b)
y = build g
in ....(case x of (p,q) -> rhs)....(foldr k z y)....
We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),
but we do want
* the case-expression to simplify
(via exprIsConApp_maybe, exprIsLiteral_maybe)
* the foldr/build RULE to fire
(by expanding the unfolding during rule matching)
So we classify the unfolding of a let-binding as "expandable" (via the
uf_expandable field) if we want to do this kind of on-the-fly
expansion. Specifically:
* True of constructor applications (K a b)
* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.
(NB: exprIsCheap might not be true of this)
* False of case-expressions. If we have
let x = case ... in ...(case x of ...)...
we won't simplify. We have to inline x. See #14688.
* False of let-expressions (same reason); and in any case we
float lets out of an RHS if doing so will reveal an expandable
application (see SimplEnv.doFloatFromRhs).
* Take care: exprIsExpandable should /not/ be true of primops. I
found this in test T5623a:
let q = /\a. Ptr a (a +# b)
in case q @ Float of Ptr v -> ...q...
q's inlining should not be expandable, else exprIsConApp_maybe will
say that (q @ Float) expands to (Ptr a (a +# b)), and that will
duplicate the (a +# b) primop, which we should not do lightly.
(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
Note [isExpandableApp: bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important that isExpandableApp does not respond True to bottoming
......@@ -1852,7 +1838,7 @@ expr_ok fun_ok primop_ok other_expr
_ -> False
-----------------------------
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool
app_ok fun_ok primop_ok fun args
| not (fun_ok fun)
= False -- This code path is only taken for Note [Speculative evaluation]
......@@ -1867,13 +1853,11 @@ app_ok fun_ok primop_ok fun args
-- DFuns terminate, unless the dict is implemented
-- with a newtype in which case they may not
DataConWorkId {} -> args_ok
-- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
-- Well, we thought so. But it's definitely wrong!
-- See #20749 and Note [How untagged pointers can
-- end up in strict fields] in GHC.Stg.InferTags
DataConWorkId dc
| isLazyDataConRep dc
-> args_ok
| otherwise
-> fields_ok (dataConRepStrictness dc)
ClassOpId _ is_terminating_result
| is_terminating_result -- See Note [exprOkForSpeculation and type classes]
......@@ -1923,7 +1907,7 @@ app_ok fun_ok primop_ok fun args
-- Even if a function call itself is OK, any unlifted
-- args are still evaluated eagerly and must be checked
args_ok = and (zipWith arg_ok arg_tys args)
args_ok = all2Prefix arg_ok arg_tys args
arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
arg_ok (Named _) _ = True -- A type argument
arg_ok (Anon ty _) arg -- A term argument
......@@ -1932,6 +1916,17 @@ app_ok fun_ok primop_ok fun args
| otherwise
= expr_ok fun_ok primop_ok arg
-- Used for DataCon worker arguments
fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args
field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool
field_ok (Named _) _ _ = True
field_ok (Anon ty _) str arg
| NotMarkedStrict <- str -- iff it's a lazy field
, definitelyLiftedType (scaledThing ty) -- and its type is lifted
= True -- then the worker app does not eval
| otherwise
= expr_ok fun_ok primop_ok arg
-----------------------------
altsAreExhaustive :: [Alt b] -> Bool
-- True <=> the case alternatives are definitely exhaustive
......@@ -2157,12 +2152,14 @@ exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
-- or PAPs.
--
exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike is_con is_con_unf = is_hnf_like
exprIsHNFlike is_con is_con_unf e
= -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $
is_hnf_like e
where
is_hnf_like (Var v) -- NB: There are no value args at this point
= id_app_is_value v 0 -- Catches nullary constructors,
-- so that [] and () are values, for example
-- and (e.g.) primops that don't have unfoldings
= id_app_is_value v [] -- Catches nullary constructors,
-- so that [] and () are values, for example
-- and (e.g.) primops that don't have unfoldings
|| is_con_unf (idUnfolding v)
-- Check the thing's unfolding; it might be bound to a value
-- or to a guaranteed-evaluated variable (isEvaldUnfolding)
......@@ -2186,7 +2183,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
-- See Note [exprIsHNF Tick]
is_hnf_like (Cast e _) = is_hnf_like e
is_hnf_like (App e a)
| isValArg a = app_is_value e 1
| isValArg a = app_is_value e [a]
| otherwise = is_hnf_like e
is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
is_hnf_like (Case e b _ as)
......@@ -2194,26 +2191,63 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
= is_hnf_like rhs
is_hnf_like _ = False
-- 'n' is the number of value args to which the expression is applied
-- And n>0: there is at least one value argument
app_is_value :: CoreExpr -> Int -> Bool
app_is_value (Var f) nva = id_app_is_value f nva
app_is_value (Tick _ f) nva = app_is_value f nva
app_is_value (Cast f _) nva = app_is_value f nva
app_is_value (App f a) nva
| isValArg a =
app_is_value f (nva + 1) &&
not (needsCaseBinding (exprType a) a)
-- For example f (x /# y) where f has arity two, and the first
-- argument is unboxed. This is not a value!
-- But f 34# is a value.
-- NB: Check app_is_value first, the arity check is cheaper
| otherwise = app_is_value f nva
app_is_value _ _ = False
id_app_is_value id n_val_args
= is_con id
|| idArity id > n_val_args
-- Collect arguments through Casts and Ticks and call id_app_is_value
app_is_value :: CoreExpr -> [CoreArg] -> Bool
app_is_value (Var f) as = id_app_is_value f as
app_is_value (Tick _ f) as = app_is_value f as
app_is_value (Cast f _) as = app_is_value f as
app_is_value (App f a) as | isValArg a = app_is_value f (a:as)
| otherwise = app_is_value f as
app_is_value _ _ = False
id_app_is_value id val_args =
case compare (idArity id) (length val_args) of
EQ | is_con id -> -- Saturated app of a DataCon/CONLIKE Id
case mb_str_marks id of
Just str_marks -> -- with strict fields
assert (val_args `equalLength` str_marks) $
fields_hnf str_marks
Nothing -> -- without strict fields: like PAP
args_hnf -- NB: CONLIKEs are lazy!
GT -> -- PAP: Check unlifted val_args
args_hnf
_ -> False
where
-- Saturated, Strict DataCon: Check unlifted val_args and strict fields
fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args
-- PAP: Check unlifted val_args
args_hnf = all2Prefix check_arg val_arg_tys val_args
fun_ty = idType id
val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty)
-- val_arg_tys = map exprType val_args, but much less costly.
-- The obvious definition regresses T16577 by 30% so we don't do it.
check_arg a_ty a
| mightBeUnliftedType a_ty = is_hnf_like a
| otherwise = True
-- Check unliftedness; for example f (x /# 12#) where f has arity two,
-- and the first argument is unboxed. This is not a value!
-- But f 34# is a value, so check args for HNFs.
-- NB: We check arity (and CONLIKEness) first because it's cheaper
-- and we reject quickly on saturated apps.
check_field a_ty str a
| isMarkedStrict str || mightBeUnliftedType a_ty = is_hnf_like a
| otherwise = True
-- isMarkedStrict: Respect Note [Strict fields in Core]
mb_str_marks id
| Just dc <- isDataConWorkId_maybe id
, not (isLazyDataConRep dc)
= Just (dataConRepStrictness dc)
| otherwise
= Nothing
{-# INLINE exprIsHNFlike #-}
{-
Note [exprIsHNF Tick]
......@@ -2775,7 +2809,7 @@ This means the seqs on x and y both become no-ops and compared to the first vers
The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated.
But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated
already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this.
already at the call site because of the Strict Field Invariant! See Note [STG Strict Field Invariant] for more in this.
This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.
We only apply this when we think there is a benefit in doing so however. There are a number of cases in which
......
......@@ -644,7 +644,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
| otherwise
= snocFloat floats new_float
new_float = mkNonRecFloat env is_unlifted bndr1 rhs1
(new_float, _bndr2) = mkNonRecFloat env is_unlifted bndr1 rhs1
; return (env2, floats1, Nothing) }
......@@ -729,9 +729,9 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkNonRecFloat env False v rhs2
; let (float, v') = mkNonRecFloat env False v rhs2
; return ( snocFloat floats2 float
, cpeEtaExpand arity (Var v)) })
, cpeEtaExpand arity (Var v')) })
-- Wrap floating ticks
; let (floats4, rhs4) = wrapTicks floats3 rhs3
......@@ -907,10 +907,10 @@ cpeRhsE env (Case scrut bndr ty alts)
; alts'' <- mapM (sat_alt env') alts'
; case alts'' of
[Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
| let is_unlifted = isUnliftedType (idType bndr2)
, let float = mkCaseFloat is_unlifted bndr2 scrut'
-> return (snocFloat floats float, rhs)
-- [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
-- | let is_unlifted = isUnliftedType (idType bndr2)
-- , let float = mkCaseFloat is_unlifted bndr2 scrut'
-- -> return (snocFloat floats float, rhs)
_ -> return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }
where
sat_alt env (Alt con bs rhs)
......@@ -1570,8 +1570,9 @@ cpeArg env dmd arg
; let arity = cpeArgArity env dec floats1 arg2
arg3 = cpeEtaExpand arity arg2
-- See Note [Eta expansion of arguments in CorePrep]
; let arg_float = mkNonRecFloat env is_unlifted v arg3
; return (snocFloat floats2 arg_float, varToCoreExpr v) }
; let (arg_float, v') = mkNonRecFloat env is_unlifted v arg3
---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2)
; return (snocFloat floats2 arg_float, varToCoreExpr v') }
}
cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity
......@@ -1793,10 +1794,10 @@ cpeEtaExpand arity expr
Note [Pin demand info on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pin demand info on floated lets, so that we can see the one-shot thunks.
We pin demand info on floated lets, so that we can see one-shot thunks.
For example,
f (g x)
where `f` uses its argument at least once, creates a Float for `y = g x` and we
where `f` uses its argument at most once, creates a Float for `y = g x` and we
should better pin appropriate demand info on `y`.
Note [Flatten case-binds]
......@@ -1807,7 +1808,7 @@ Suppose we have the following call, where f is strict:
`case` out because `f` is strict.)
In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`
Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl
Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl
with the call `f a`. When we wrap that `Float` we will get
......@@ -1826,8 +1827,8 @@ This is easy to avoid: turn that
into a FloatingBind of its own. This is easily done in the Case
equation for `cpsRhsE`. Then our example will generate /two/ floats:
Float (y = x) CaseBound top_lvl
Float (a = blah) CaseBound top_lvl
Float (y = x) CaseBound str-ctx
Float (a = blah) CaseBound top-lvl
and we'll end up with nested cases.
......@@ -1840,6 +1841,124 @@ Of course, the Simplifier never leaves us with an argument like this, but we
and the above footwork in cpsRhsE avoids generating a nested case.
Note [Pin evaluatedness on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a call to a CBV function, such as a DataCon worker with *strict* fields,
in a *lazy* context, such as in the arg of a lazy function call to `f`:
data Box a = Box !a
... f (Box e) ... -- f lazy, Box strict
(A live example of this is T24730, inspired by $walexGetByte.)
During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a
fresh binder `sat`, and binding `Box sat` as well to a fresh binder `sat2`.
We want to avoid allocating a thunk for `sat2` as often as possible, building
on the let floating mechanism in Case (2) of Note [wantFloatLocal].
Note that this mechanism requires `sat` to be detected as a value after
floating out any ok-for-spec floats, according to `exprIsHNF`. This means we
need an `evaldUnfolding` on `sat`, and `mkNonRecFloat` must do the pinning.
There are two interesting cases:
1. When `e = I# (x +# 1#)`, we decompose into
case x +# 1# of x' ->
---
I# x'
where everything above --- are floats and below --- is the residual RHS.
Here, `I# x'` is a value because `x'` is (NB: x' is a variable of unlifted type).
Following Case (2) of Note [wantFloatLocal], we want to float out the
ok-for-spec `x +# 1#` computation in order not to allocate a thunk for Box's
field, to get
case x +# 1# of x' ->
let sat = I# x' in
---
Box sat
And since we pin an `evaldUnfolding` on `sat`, we may even float out of
`f`'s lazy argument, again by Case (2) of Note [wantFloatLocal]
case x +# 1# of x' ->
let sat = I# x' in
let sat2 = Box sat in
f sat2
If `sat` didn't have the `evaldUnfolding`, we'd get a large thunk in f's arg:
let sat2 =
case x +# 1# of x' ->
let sat = I# x' in
Box sat in
f sat2
2.
Although `e` might not be a value, it might still decompose into floats that are
ok-for-spec and a value, for example
e = I# (x +# 1#)
decomposes into
Following Case (2) of Note [wantFloatLocal], we want to float out the
ok-for-spec `x +# 1#` computation in order not to allocate a thunk for Box's
field, to get
case x +# 1# of x' ->
let sat = I# x' in
Box sat
Nice! But now we want to do the same for the argument to `f`, to get
case x +# 1# of x' ->
let sat = I# x' in
let sat2 = Box sat in
f sat2
(NB: Since all floats are ok-for-spec, we may float out of the lazy argument.)
BUT, in order to do that in Case (2) of Note [wantFloatLocal], we must detect
`Box sat` as a value according to `exprIsHNF`; otherwise floating would be
unproductive. Crucially, this means we need `sat` to look evaluated, because
it ends up in a strict field.
We achieve this by attaching and `evaldUnfolding` to `sat` in `mkNonRecFloat`.
*When
1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible,
to top-level, even. It is important that we mark `sat` as evaluated (via
setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous
thunk to carry out the field seq on Box's field, because
`exprIsHNF sat == False`:
let sat = Just y in
let sat2 = case sat of x { __DEFAULT } -> Box x in
-- NONONO, want just `sat2 = Box x`
f sat2
This happened in $walexGetByte, where the thunk caused additional
allocation.
2. Similarly, when `e` is not a value, we still know that it is strictly
evaluated. Hence it is going to be case-bound, and we anticipate that `sat`
will be a case binder which is *always* evaluated.
Hence in this case, we also mark `sat` as evaluated via its unfolding.
This happened in GHC.Linker.Deps.$wgetLinkDeps, where without
`evaldUnfolding` we ended up with this:
Word64Map = ... | Bin ... ... !Word64Map !Word64Map
case ... of { Word64Map.Bin a b l r ->
case insert ... of sat { __DEFAULT ->
case Word64Map.Bin a b l sat of sat2 { __DEFAULT ->
f sat2
}}}
Note that *the DataCon app `Bin a b l sat` was case-bound*, because it was
not detected to be a value according to `exprIsHNF`.
That is because the strict field `sat` lacked the `evaldUnfolding`,
although it ended up being case-bound.
Small wrinkle:
It could be that `sat=insert ...` floats to top-level, where it is not
eagerly evaluated. In this case, we may not give `sat` an `evaldUnfolding`.
We detect this case by looking at the `FloatInfo` of `sat=insert ...`: If
it says `TopLvlFloatable`, we are conservative and will not give `sat` an
`evaldUnfolding`.
TLDR; when creating a new float `sat=e` in `mkNonRecFloat`, propagate `sat` with
an `evaldUnfolding` if either
1. `e` is a value, or
2. `sat=e` is case-bound, but won't float to top-level.
Note [Speculative evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since call-by-value is much cheaper than call-by-need, we case-bind arguments
......@@ -2123,15 +2242,16 @@ zipManyFloats = foldr zipFloats emptyFloats
mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind
mkCaseFloat is_unlifted bndr scrut
= Float (NonRec bndr scrut) bound info
= -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info)
-- -- <+> ppr is_lifted <+> ppr is_strict
-- -- <+> ppr ok_for_spec <+> ppr evald
-- $$ ppr scrut) $
Float (NonRec bndr scrut) bound info
where
(bound, info)
{-
Eventually we want the following code, when #20749 is fixed.
| is_lifted, is_hnf = (LetBound, TopLvlFloatable)
-- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
-- let-bind `StrictBox x'` after Note [Flatten case-binds].
-}
-- | is_lifted, is_hnf = (LetBound, TopLvlFloatable)
-- -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
-- -- let-bind `StrictBox x'` after Note [Flatten case-binds].
| exprIsTickedString scrut = (CaseBound, TopLvlFloatable)
-- String literals are unboxed (so must be case-bound) and float to
-- the top-level
......@@ -2141,15 +2261,16 @@ Eventually we want the following code, when #20749 is fixed.
_is_lifted = not is_unlifted
_is_hnf = exprIsHNF scrut
mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind
mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> (FloatingBind, Id)
mkNonRecFloat env is_unlifted bndr rhs
= -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)
-- <+> ppr is_lifted <+> ppr is_strict
-- <+> ppr ok_for_spec
-- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted"
-- <+> if ok_for_spec then text "ok-for-spec" else empty
-- <+> if evald then text "evald" else empty
-- $$ ppr rhs) $
Float (NonRec bndr rhs) bound info
(Float (NonRec bndr' rhs) bound info, bndr')
where
(bound, info)
!(bound, info)
| is_lifted, is_hnf = (LetBound, TopLvlFloatable)
-- is_lifted: We currently don't allow unlifted values at the
-- top-level or inside letrecs
......@@ -2180,6 +2301,11 @@ mkNonRecFloat env is_unlifted bndr rhs
is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
is_data_con = isJust . isDataConId_maybe
-- See Note [Pin evaluatedness on floats]
evald = is_hnf --- || (bound == CaseBound && info /= TopLvlFloatable)
bndr' | evald = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr
-- | Wrap floats around an expression
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds floats body
......@@ -2285,6 +2411,10 @@ data FloatDecision
= FloatNone
| FloatAll
instance Outputable FloatDecision where
ppr FloatNone = text "none"
ppr FloatAll = text "all"
executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
executeFloatDecision dec floats rhs
= case dec of
......@@ -2706,7 +2836,7 @@ cpeBigNatLit env i = assert (i >= 0) $ do
let
litAddrRhs = Lit (LitString words)
-- not "mkLitString"; that does UTF-8 encoding, which we don't want here
litAddrFloat = mkNonRecFloat env True litAddrId litAddrRhs
(litAddrFloat, litAddrId') = mkNonRecFloat env True litAddrId litAddrRhs
contentsLength = mkIntLit platform (toInteger (BS.length words))
......@@ -2719,7 +2849,7 @@ cpeBigNatLit env i = assert (i >= 0) $ do
copyContentsCall =
Var (primOpId CopyAddrToByteArrayOp)
`App` Type realWorldTy
`App` Var litAddrId
`App` Var litAddrId'
`App` Var mutableByteArrayId
`App` mkIntLit platform 0
`App` contentsLength
......
......@@ -64,8 +64,8 @@ With nofib being ~0.3% faster as well.
See Note [Tag inference passes] for how we proceed to generate and use this information.
Note [Strict Field Invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [STG Strict Field Invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As part of tag inference we introduce the Strict Field Invariant.
Which consists of us saying that:
......@@ -81,7 +81,7 @@ and will be tagged with `001` or `010` respectively.
It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").
NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.
This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].
This works analogous to how CBV functions work. See also Note [CBV Function Ids].
Why do we care? Because if we have code like:
......@@ -103,7 +103,7 @@ where we:
* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`
This is usually very beneficial but can cause regressions in rare edge cases where
we fail to proof that x is properly tagged, or where it simply isn't.
we fail to prove that x is properly tagged, or where it simply isn't.
See Note [How untagged pointers can end up in strict fields] for how the second case
can arise.
......@@ -124,15 +124,33 @@ Note that there are similar constraints around Note [CBV Function Ids].
Note [How untagged pointers can end up in strict fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since the resolution of #20749 where Core passes assume that DataCon workers
evaluate their strict fields, it is pretty simple to see how the Simplifier
might exploit that knowledge to drop evals. Example:
data T a = MkT !a
f :: [Int] -> T [Int]
f xs = xs `seq` MkT xs
in Core we will have
f = \xs -> MkT @[Int] xs
No eval left there.
Consider
data Set a = Tip | Bin !a (Set a) (Set a)
We make a wrapper for Bin that evaluates its arguments
$WBin x a b = case x of xv -> Bin xv a b
Here `xv` will always be evaluated and properly tagged, just as the
Strict Field Invariant requires.
Note [STG Strict Field Invariant] requires.
But alas, the Simplifier can destroy the invariant: see #15696.
Indeed, as Note [Strict fields in Core] explains, Core passes
assume that Data constructor workers evaluate their strict fields,
so the Simplifier will drop seqs freely.
But alas the Simplifier can destroy the invariant: see #15696.
We start with
thk = f ()
g x = ...(case thk of xv -> Bin xv Tip Tip)...
......@@ -153,7 +171,7 @@ Now you can see that the argument of Bin, namely thk, points to the
thunk, not to the value as it did before.
In short, although it may be rare, the output of optimisation passes
cannot guarantee to obey the Strict Field Invariant. For this reason
cannot guarantee to obey the Note [STG Strict Field Invariant]. For this reason
we run tag inference. See Note [Tag inference passes].
Note [Tag inference passes]
......@@ -163,7 +181,7 @@ Tag inference proceeds in two passes:
The result is then attached to /binders/.
This is implemented by `inferTagsAnal` in GHC.Stg.InferTags
* The second pass walks over the AST checking if the Strict Field Invariant is upheld.
See Note [Strict Field Invariant].
See Note [STG Strict Field Invariant].
If required this pass modifies the program to uphold this invariant.
Tag information is also moved from /binders/ to /occurrences/ during this pass.
This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.
......
......@@ -57,7 +57,7 @@ The work of this pass is simple:
* For any strict field we check if the argument is known to be properly tagged.
* If it's not known to be properly tagged, we wrap the whole thing in a case,
which will force the argument before allocation.
This is described in detail in Note [Strict Field Invariant].
This is described in detail in Note [STG Strict Field Invariant].
The only slight complication is that we have to make sure not to invalidate free
variable analysis in the process.
......@@ -210,7 +210,7 @@ When compiling bytecode we call myCoreToStg to get STG code first.
myCoreToStg in turn calls out to stg2stg which runs the STG to STG
passes followed by free variables analysis and the tag inference pass including
its rewriting phase at the end.
Running tag inference is important as it upholds Note [Strict Field Invariant].
Running tag inference is important as it upholds Note [STG Strict Field Invariant].
While code executed by GHCi doesn't take advantage of the SFI it can call into
compiled code which does. So it must still make sure that the SFI is upheld.
See also #21083 and #22042.
......
......@@ -884,7 +884,7 @@ mostly relating to under what circumstances it evaluates its argument.
Today, that story is simple: A dataToTag primop always evaluates its
argument, unless tag inference determines the argument was already
evaluated and correctly tagged. Getting here was a long journey, with
many similarities to the story behind Note [Strict Field Invariant] in
many similarities to the story behind Note [STG Strict Field Invariant] in
GHC.Stg.InferTags. See also #15696.
-}
......
......@@ -183,14 +183,15 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
tag = lookupNameEnv_NF tag_map src_name
-- See Note [Constructor tag allocation], fixes #14657
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
src_bangs impl_bangs str_marks field_lbls
univ_tvs ex_tvs
noConcreteTyVars
user_tvbs eq_spec ctxt
arg_tys res_ty NoPromInfo rep_tycon tag
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
(dc_rep, impl_bangs, str_marks) =
initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
......
......@@ -1391,33 +1391,16 @@ arguments. That is the job of dmdTransformDataConSig. More precisely,
* it returns the demands on the arguments;
in the above example that is [SL, A]
Nasty wrinkle. Consider this code (#22475 has more realistic examples but
assume this is what the demand analyser sees)
data T = MkT !Int Bool
get :: T -> Bool
get (MkT _ b) = b
foo = let v::Int = I# 7
t::T = MkT v True
in get t
Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand,
else we'll drop the binding and replace it with an error thunk.
Then the code generator (more specifically GHC.Stg.InferTags.Rewrite)
will add an extra eval of MkT's argument to give
foo = let v::Int = error "absent"
t::T = case v of v' -> MkT v' True
in get t
Boo! Because of this extra eval (added in STG-land), the truth is that `MkT`
may (or may not) evaluate its arguments (as established in #21497). Hence the
use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The
`C_01` says "may or may not evaluate" which is absolutely faithful to what
InferTags.Rewrite does.
In particular it is very important /not/ to make that a `C_11` eval,
see Note [Data-con worker strictness].
When the data constructor worker has strict fields, an additional seq
will be inserted for each field (Note [Strict fields in Core]).
Hence we add an additional `seqDmd` for each strict field to emulate
field seq insertion.
For example, consider `data SP a b = MkSP !a !b` and expression `MkSP x y`,
with the same sub-demand P(SL,A).
The strict fields bump up the strictness; we'd get [SL,1!A] for the field
demands. Note that the first demand was unaffected by the seq, whereas
the second, previously absent demand became `seqDmd` exactly.
-}
{- *********************************************************************
......@@ -1617,6 +1600,29 @@ a bad fit because
expression may not throw a precise exception (increasing precision of the
analysis), but that's just a favourable guess.
Note [Side-effects and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Due to historic reasons and the continued effort not to cause performance
regressions downstream, Strictness Analysis is currently prone to discarding
observable side-effects (other than precise exceptions, see
Note [Precise exceptions and strictness analysis]) in some cases. For example,
f :: MVar () -> Int -> IO Int
f mv x = putMVar mv () >> (x `seq` return x)
The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis
currently concludes that `f` is strict in `x` and uses call-by-value.
That means `f mv (error "boom")` will error out with the imprecise exception
rather performing the side-effect.
This is a conscious violation of the semantics described in the paper
"a semantics for imprecise exceptions"; so it would be great if we could
identify the offending primops and extend the idea in
Note [Which scrutinees may throw precise exceptions] to general side-effects.
Unfortunately, the existing has-side-effects classification for primops is
too conservative, listing `writeMutVar#` and even `readMutVar#` as
side-effecting. That is due to #3207. A possible way forward is described in
#17900, but no effort has been so far towards a resolution.
Note [Exceptions and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to smart about catching exceptions, but we aren't anymore.
......@@ -2333,7 +2339,8 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)
bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)
| otherwise = multDmd n dmd
str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]
str_field_dmd = seqDmd -- See the bit about strict fields
-- in Note [Demand transformer for data constructors]
-- | A special 'DmdTransformer' for dictionary selectors that feeds the demand
-- on the result into the indicated dictionary component (if saturated).
......
......@@ -260,7 +260,7 @@ The invariants around the arguments of call by value function like Ids are then:
* Any `WorkerLikeId`
* Some `JoinId` bindings.
This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant].
This works analogous to the Strict Field Invariant. See also Note [STG Strict Field Invariant].
To make this work what we do is:
* During W/W and SpecConstr any worker/specialized binding we introduce
......
......@@ -58,7 +58,7 @@ import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Make
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType )
import GHC.Core.Utils ( exprType, mkCast, coreAltsType )
import GHC.Core.Unfold.Make
import GHC.Core.SimpleOpt
import GHC.Core.TyCon
......@@ -597,8 +597,12 @@ mkDataConWorkId wkr_name data_con
= mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info
where
tycon = dataConTyCon data_con -- The representation TyCon
wkr_ty = dataConRepType data_con
tycon = dataConTyCon data_con -- The representation TyCon
wkr_ty = dataConRepType data_con
univ_tvs = dataConUnivTyVars data_con
ex_tcvs = dataConExTyCoVars data_con
arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys
str_marks = dataConRepStrictness data_con
----------- Workers for data types --------------
alg_wkr_info = noCafIdInfo
......@@ -606,12 +610,19 @@ mkDataConWorkId wkr_name data_con
`setInlinePragInfo` wkr_inline_prag
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setDmdSigInfo` wkr_sig
-- Workers eval their strict fields
-- See Note [Strict fields in Core]
`setLFInfo` wkr_lf_info
-- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon
wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike }
wkr_arity = dataConRepArity data_con
wkr_sig = mkClosedDmdSig wkr_dmds topDiv
wkr_dmds = map mk_dmd str_marks
mk_dmd MarkedStrict = evalDmd
mk_dmd NotMarkedStrict = topDmd
-- See Note [LFInfo of DataCon workers and wrappers]
wkr_lf_info
| wkr_arity == 0 = LFCon data_con
......@@ -619,9 +630,6 @@ mkDataConWorkId wkr_name data_con
-- LFInfo stores post-unarisation arity
----------- Workers for newtypes --------------
univ_tvs = dataConUnivTyVars data_con
ex_tcvs = dataConExTyCoVars data_con
arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setInlinePragInfo` dataConWrapperInlinePragma
......@@ -789,10 +797,10 @@ mkDataConRep :: DataConBangOpts
-> FamInstEnvs
-> Name
-> DataCon
-> UniqSM DataConRep
-> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
mkDataConRep dc_bang_opts fam_envs wrap_name data_con
| not wrapper_reqd
= return NoDataConRep
= return (NoDataConRep, arg_ibangs, rep_strs)
| otherwise
= do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys
......@@ -856,11 +864,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
; return (DCR { dcr_wrap_id = wrap_id
, dcr_boxer = mk_boxer boxers
, dcr_arg_tys = rep_tys
, dcr_stricts = rep_strs
-- For newtypes, dcr_bangs is always [HsLazy].
-- See Note [HsImplBangs for newtypes].
, dcr_bangs = arg_ibangs }) }
, dcr_arg_tys = rep_tys }
, arg_ibangs, rep_strs) }
where
(univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
......@@ -918,8 +923,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- (Most) newtypes have only a worker, with the exception
-- of some newtypes written with GADT syntax.
-- See dataConUserTyVarsNeedWrapper below.
&& (any isBanged (ev_ibangs ++ arg_ibangs)))
-- Some forcing/unboxing (includes eq_spec)
&& (any isUnpacked (ev_ibangs ++ arg_ibangs)))
-- Some unboxing (includes eq_spec)
|| isFamInstTyCon tycon -- Cast result
......@@ -1185,7 +1190,7 @@ dataConArgRep arg_ty HsLazy
= ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep arg_ty (HsStrict _)
= ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
= ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG
dataConArgRep arg_ty (HsUnpack Nothing)
= dataConArgUnpack arg_ty
......@@ -1215,9 +1220,6 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty
; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
------------------------
seqUnboxer :: Unboxer
seqUnboxer v = return ([v], mkDefaultCase (Var v) v)
unitUnboxer :: Unboxer
unitUnboxer v = return ([v], \e -> e)
......
......@@ -23,7 +23,7 @@ module GHC.Utils.Misc (
dropWhileEndLE, spanEnd, last2, lastMaybe, onJust,
List.foldl1', foldl2, count, countWhile, all2,
List.foldl1', foldl2, count, countWhile, all2, all2Prefix, all3Prefix,
lengthExceeds, lengthIs, lengthIsNot,
lengthAtLeast, lengthAtMost, lengthLessThan,
......@@ -652,6 +652,30 @@ all2 _ [] [] = True
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
all2 _ _ _ = False
all2Prefix :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`.
-- So if one list is shorter than the other, `p` is assumed to be `True` for the
-- suffix.
all2Prefix p = foldr k z
where
k x go ys' = case ys' of
(y:ys'') -> p x y && go ys''
_ -> True
z _ = True
{-# INLINE all2Prefix #-}
all3Prefix :: (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool
-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`.
-- So if one list is shorter than the others, `p` is assumed to be `True` for
-- the suffix.
all3Prefix p = foldr k z
where
k x go ys' zs' = case (ys',zs') of
(y:ys'',z:zs'') -> p x y z && go ys'' zs''
_ -> False
z _ _ = True
{-# INLINE all3Prefix #-}
-- Count the number of times a predicate is true
count :: (a -> Bool) -> [a] -> Int
......