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 (72)
Showing
with 626 additions and 303 deletions
......@@ -26,12 +26,28 @@ stages:
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
# Note [The CI Story]
# ~~~~~~~~~~~~~~~~~~~
#
# There are two different types of pipelines:
#
# - marge-bot merges to `master`. Here we perform an exhaustive validation
# across all of the platforms which we support. In addition, we push
# performance metric notes upstream, providing a persistent record of the
# performance characteristics of the compiler.
#
# - merge requests. Here we perform a slightly less exhaustive battery of
# testing. Namely we omit some configurations (e.g. the unregisterised job).
# These use the merge request's base commit for performance metric
# comparisons.
#
workflow:
# N.B.Don't run on wip/ branches, instead on run on merge requests.
# N.B. Don't run on wip/ branches, instead on run on merge requests.
rules:
- if: $CI_MERGE_REQUEST_ID
- if: $CI_COMMIT_TAG
- if: '$CI_COMMIT_BRANCH == "master"'
- if: '$CI_COMMIT_BRANCH == "wip/marge_bot_batch_merge_job"'
- if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
- if: '$CI_PIPELINE_SOURCE == "web"'
......@@ -190,6 +206,7 @@ lint-release-changelogs:
key: hadrian
paths:
- cabal-cache
dependencies: []
artifacts:
reports:
junit: junit.xml
......@@ -292,8 +309,8 @@ hadrian-ghc-in-ghci:
# porting guide [1].
# [1] https://www.freebsd.org/doc/en/books/porters-handbook/using-iconv.html)
CONFIGURE_ARGS: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
GHC_VERSION: 8.10.1
CABAL_INSTALL_VERSION: 3.2.0.0
GHC_VERSION: "8.10.1"
CABAL_INSTALL_VERSION: "3.2.0.0"
BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-portbld-freebsd.tar.xz"
TEST_ENV: "x86_64-freebsd"
BUILD_FLAVOUR: "validate"
......@@ -367,7 +384,7 @@ validate-x86_64-darwin:
tags:
- x86_64-darwin
variables:
GHC_VERSION: 8.8.3
GHC_VERSION: 8.8.4
CABAL_INSTALL_VERSION: 3.0.0.0
BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-apple-darwin.tar.xz"
MACOSX_DEPLOYMENT_TARGET: "10.7"
......@@ -395,7 +412,7 @@ validate-x86_64-darwin:
tags:
- x86_64-darwin
variables:
GHC_VERSION: 8.8.3
GHC_VERSION: 8.8.4
MACOSX_DEPLOYMENT_TARGET: "10.7"
ac_cv_func_clock_gettime: "no"
LANG: "en_US.UTF-8"
......@@ -776,8 +793,8 @@ validate-x86_64-linux-fedora27:
#FORCE_SYMLINKS: 1
LANG: "en_US.UTF-8"
SPHINXBUILD: "/mingw64/bin/sphinx-build.exe"
CABAL_INSTALL_VERSION: 3.0.0.0
GHC_VERSION: "8.8.3"
CABAL_INSTALL_VERSION: "3.0.0.0"
GHC_VERSION: "8.8.4"
cache:
paths:
- cabal-cache
......@@ -817,15 +834,6 @@ validate-x86_64-windows-hadrian:
cache:
key: "x86_64-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
nightly-i386-windows-hadrian:
<<: *nightly
extends: .build-windows-hadrian
variables:
MSYSTEM: MINGW32
TEST_ENV: "i386-windows-hadrian"
cache:
key: "i386-windows-hadrian-$WINDOWS_TOOLCHAIN_VERSION"
.build-windows-make:
extends: .build-windows
stage: full-build
......@@ -882,34 +890,6 @@ release-x86_64-windows-integer-simple:
BIGNUM_BACKEND: native
BUILD_FLAVOUR: "perf"
.build-i386-windows-make:
extends: .build-windows-make
variables:
MSYSTEM: MINGW32
# Due to #15934
BUILD_PROF_LIBS: "NO"
TEST_ENV: "i386-windows"
# Due to #17736
allow_failure: true
cache:
key: "i386-windows-$WINDOWS_TOOLCHAIN_VERSION"
validate-i386-windows:
extends: .build-i386-windows-make
variables:
BUILD_FLAVOUR: "perf"
release-i386-windows:
<<: *release
extends: .build-i386-windows-make
variables:
BUILD_FLAVOUR: "perf"
nightly-i386-windows:
<<: *nightly
extends: .build-i386-windows-make
############################################################
# Cleanup
############################################################
......
......@@ -363,6 +363,13 @@ function push_perf_notes() {
"$TOP/.gitlab/test-metrics.sh" push
}
# Figure out which commit should be used by the testsuite driver as a
# performance baseline. See Note [The CI Story].
function determine_metric_baseline() {
export PERF_BASELINE_COMMIT="$(git merge-base $CI_MERGE_REQUEST_TARGET_BRANCH_NAME HEAD)"
info "Using $PERF_BASELINE_COMMIT for performance metric baseline..."
}
function test_make() {
run "$MAKE" test_bindist TEST_PREP=YES
run "$MAKE" V=0 test \
......
......@@ -81,6 +81,10 @@ function push() {
echo ""
echo "Failed to push git notes. Fetching, appending, and retrying... $MAX_RETRY retries left."
done
# Be sure to kill agent before we terminate since otherwise the Windows CI
# job won't finish.
ssh-agent -k
}
case $1 in
......@@ -88,3 +92,4 @@ case $1 in
pull) pull ;;
*) fail "Invalid mode $1" ;;
esac
......@@ -49,3 +49,18 @@
/utils/gen-dll/ @Phyx
/utils/fs/ @Phyx
# WinIO related code
/libraries/base/GHC/Event/Windows/ @Phyx
/libraries/base/GHC/IO/Windows/ @Phyx
/rts/win32/ @Phyx
/libraries/base/GHC/IO/Handle/Lock/Windows.hsc @Phyx
/libraries/base/GHC/Event/Windows.hsc @Phyx
/libraries/base/GHC/Conc/WinIO.hs @Phyx
/libraries/base/GHC/Conc/Windows.hs @Phyx
/libraries/base/GHC/IO/Handle/Windows.hs @Phyx
/libraries/base/GHC/IO/StdHandles.hs @Phyx
/libraries/base/GHC/Windows.hs @Phyx
/libraries/base/cbits/IOutils.c @Phyx
/libraries/base/cbits/Win32Utils.c @Phyx
/libraries/base/cbits/consUtils.c @Phyx
/libraries/base/include/winio_structs.h @Phyx
......@@ -3,6 +3,15 @@
# To be a good autoconf citizen, names of local macros have prefixed with FP_ to
# ensure we don't clash with any pre-supplied autoconf ones.
# FPTOOLS_WRITE_FILE
# ------------------
# Write $2 to the file named $1.
AC_DEFUN([FPTOOLS_WRITE_FILE],
[
cat >$1 <<ACEOF
$2
ACEOF
])
AC_DEFUN([GHC_SELECT_FILE_EXTENSIONS],
[
......@@ -2471,7 +2480,6 @@ AC_DEFUN([FIND_LD],[
# Make sure the user didn't specify LD manually.
if test "z$LD" != "z"; then
AC_CHECK_TARGET_TOOL([LD], [ld])
LD_NO_GOLD=$LD
return
fi
......@@ -2484,7 +2492,6 @@ AC_DEFUN([FIND_LD],[
if test "x$TmpLd" = "x"; then continue; fi
out=`$TmpLd --version`
LD_NO_GOLD=$TmpLd
case $out in
"GNU ld"*)
FP_CC_LINKER_FLAG_TRY(bfd, $2) ;;
......@@ -2492,8 +2499,6 @@ AC_DEFUN([FIND_LD],[
FP_CC_LINKER_FLAG_TRY(gold, $2)
if test "$cross_compiling" = "yes"; then
AC_MSG_NOTICE([Using ld.gold and assuming that it is not affected by binutils issue 22266]);
else
LD_NO_GOLD=ld;
fi
;;
"LLD"*)
......@@ -2514,21 +2519,141 @@ AC_DEFUN([FIND_LD],[
# Fallback
AC_CHECK_TARGET_TOOL([LD], [ld])
# This isn't entirely safe since $LD may have been discovered to be
# ld.gold, but what else can we do?
if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
}
if test "x$enable_ld_override" = "xyes"; then
find_ld
else
AC_CHECK_TARGET_TOOL([LD], [ld])
if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
fi
CHECK_LD_COPY_BUG([$1])
])
# CHECK_FOR_GOLD_T22266
# ----------------------
#
# Test for binutils #22266. This bug manifested as GHC bug #14328 (see also:
# #14675, #14291).
# Uses test from
# https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=033bfb739b525703bfe23f151d09e9beee3a2afe
#
# $1 = linker to test
# Sets $result to 0 if not affected, 1 otherwise
AC_DEFUN([CHECK_FOR_GOLD_T22266],[
AC_MSG_CHECKING([for ld.gold object merging bug (binutils 22266)])
if ! $1 --version | grep -q "GNU gold"; then
# Not gold
result=0
elif test "$cross_compiling" = "yes"; then
AC_MSG_RESULT([cross-compiling, assuming LD can merge objects correctly.])
result=0
else
FPTOOLS_WRITE_FILE([conftest.a.c], [
__attribute__((section(".data.a")))
static int int_from_a_1 = 0x11223344;
__attribute__((section(".data.rel.ro.a")))
int *p_int_from_a_2 = &int_from_a_1;
const char *hello (void);
const char *
hello (void)
{
return "XXXHello, world!" + 3;
}
])
FPTOOLS_WRITE_FILE([conftest.main.c], [
#include <stdlib.h>
#include <string.h>
extern int *p_int_from_a_2;
extern const char *hello (void);
int main (void) {
if (*p_int_from_a_2 != 0x11223344)
abort ();
if (strcmp(hello(), "Hello, world!") != 0)
abort ();
return 0;
}
])
FPTOOLS_WRITE_FILE([conftest.t], [
SECTIONS
{
.text : {
*(.text*)
}
.rodata :
{
*(.rodata .rodata.* .gnu.linkonce.r.*)
}
.data.rel.ro : {
*(.data.rel.ro*)
}
.data : {
*(.data*)
}
.bss : {
*(.bss*)
}
}
])
$CC -c -o conftest.a.o conftest.a.c || AC_MSG_ERROR([Failed to compile test])
$SettingsMergeObjectsCommand $SettingsMergeObjectsFlags -T conftest.t conftest.a.o -o conftest.ar.o || AC_MSG_ERROR([Failed to merge test object])
$CC -c -o conftest.main.o conftest.main.c || AC_MSG_ERROR([Failed to compile test driver])
$CC conftest.ar.o conftest.main.o -o conftest || AC_MSG_ERROR([Failed to link test driver])
if ./conftest; then
AC_MSG_RESULT([not affected])
result=0
else
AC_MSG_RESULT([affected])
result=1
fi
rm -f conftest.a.o conftest.a.c conttest.ar.o conftest.main.c conftest.main.o conftest
fi
])
# FIND_MERGE_OBJECTS
# ------------------
# Find which linker to use to merge object files.
#
AC_DEFUN([FIND_MERGE_OBJECTS],[
AC_REQUIRE([FIND_LD])
if test -z "$SettingsMergeObjectsCommand"; then
SettingsMergeObjectsCommand="$LD"
fi
if test -z "$SettingsMergeObjectsFlags"; then
SettingsMergeObjectsFlags="-r"
fi
CHECK_FOR_GOLD_T22266($SettingsMergeObjectsCommand)
if test "$result" = "1"; then
AC_MSG_NOTICE([$SettingsMergeObjectsCommand is broken due to binutils 22266, looking for another linker...])
SettingsMergeObjectsCommand=""
AC_CHECK_TARGET_TOOL([SettingsMergeObjectsCommand], [ld])
CHECK_FOR_GOLD_T22266($SettingsMergeObjectsCommand)
if test "$result" = "1"; then
AC_MSG_ERROR([Linker is affected by binutils 22266 but couldn't find another unaffected linker. Please set the SettingsMergeObjectsCommand variable to a functional linker.])
fi
fi
if test "$windows" = YES -a "$EnableDistroToolchain" = "NO" -a "$WORD_SIZE" = 64; then
SettingsMergeObjectsFlags="$SettingsMergeObjectsFlags --oformat=pe-bigobj-x86-64"
fi
AC_SUBST(SettingsMergeObjectsCommand)
AC_SUBST(SettingsMergeObjectsFlags)
])
# FIND_PYTHON
# -----------
# Find the version of `python` to use (for the testsuite driver)
......
......@@ -248,7 +248,7 @@ module GHC (
srcSpanStartCol, srcSpanEndCol,
-- ** Located
GenLocated(..), Located,
GenLocated(..), Located, RealLocated,
-- *** Constructing Located
noLoc, mkGeneralLocated,
......@@ -274,7 +274,7 @@ module GHC (
parser,
-- * API Annotations
ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
......
......@@ -1255,7 +1255,7 @@ pprCLabel dflags = \case
where
platform = targetPlatform dflags
useNCG = platformMisc_ghcWithNativeCodeGen (platformMisc dflags)
useNCG = hscTarget dflags == HscAsm
maybe_underscore :: SDoc -> SDoc
maybe_underscore doc =
......
......@@ -6,6 +6,7 @@
--
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
module GHC.Cmm.Lint (
cmmLint, cmmLintGraph
......@@ -14,6 +15,7 @@ module GHC.Cmm.Lint (
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Regs (callerSaves)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
......@@ -26,7 +28,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Utils.Outputable
import GHC.Driver.Session
import Control.Monad (ap)
import Control.Monad (ap, unless)
-- Things to check:
-- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
......@@ -160,7 +162,13 @@ lintCmmMiddle node = case node of
CmmUnsafeForeignCall target _formals actuals -> do
lintTarget target
mapM_ lintCmmExpr actuals
let lintArg expr = do
-- Arguments can't mention caller-saved
-- registers. See Note [Register parameter passing].
mayNotMentionCallerSavedRegs (text "foreign call argument") expr
lintCmmExpr expr
mapM_ lintArg actuals
lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
......@@ -188,18 +196,40 @@ lintCmmLast labels node = case node of
CmmForeignCall tgt _ args succ _ _ _ -> do
lintTarget tgt
mapM_ lintCmmExpr args
let lintArg expr = do
-- Arguments can't mention caller-saved
-- registers. See Note [Register
-- parameter passing].
-- N.B. This won't catch local registers
-- which the NCG's register allocator later
-- places in caller-saved registers.
mayNotMentionCallerSavedRegs (text "foreign call argument") expr
lintCmmExpr expr
mapM_ lintArg args
checkTarget succ
where
checkTarget id
| setMember id labels = return ()
| otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: ForeignTarget -> CmmLint ()
lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget (ForeignTarget e _) = do
mayNotMentionCallerSavedRegs (text "foreign target") e
_ <- lintCmmExpr e
return ()
lintTarget (PrimTarget {}) = return ()
-- | As noted in Note [Register parameter passing], the arguments and
-- 'ForeignTarget' of a foreign call mustn't mention
-- caller-saved registers.
mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)
=> SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs what thing = do
dflags <- getDynFlags
let badRegs = filter (callerSaves (targetPlatform dflags))
$ foldRegsUsed dflags (flip (:)) [] thing
unless (null badRegs)
$ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)
checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
......
......@@ -45,6 +45,9 @@ native code generators to handle.
Most operations are parameterised by the 'Width' that they operate on.
Some operations have separate signed and unsigned versions, and float
and integer versions.
Note that there are variety of places in the native code generator where we
assume that the code produced for a MachOp does not introduce new blocks.
-}
data MachOp
......
......@@ -93,7 +93,7 @@ data CmmNode e x where
--
-- Invariant: the arguments and the ForeignTarget must not
-- mention any registers for which GHC.Platform.callerSaves
-- is True. See Note [Register Parameter Passing].
-- is True. See Note [Register parameter passing].
CmmBranch :: ULabel -> CmmNode O C
-- Goto another block in the same procedure
......@@ -223,11 +223,12 @@ convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
argument passing. These are registers R3-R6, which our generated
code may also be using; as a result, it's necessary to save these
values before doing a foreign call. This is done during initial
code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils. However,
one result of doing this is that the contents of these registers
may mysteriously change if referenced inside the arguments. This
is dangerous, so you'll need to disable inlining much in the same
way is done in GHC.Cmm.Opt currently. We should fix this!
code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.
However, one result of doing this is that the contents of these registers may
mysteriously change if referenced inside the arguments. This is dangerous, so
you'll need to disable inlining much in the same way is done in GHC.Cmm.Sink
currently. We should fix this!
-}
---------------------------------------------
......
......@@ -772,6 +772,7 @@ regAddr _ _ _ _ = AnyMem
{-
Note [Inline GlobalRegs?]
~~~~~~~~~~~~~~~~~~~~~~~~~
Should we freely inline GlobalRegs?
......
......@@ -287,11 +287,11 @@ we construct as a separate data type and the actual control flow graph in the co
Instead we now return the new basic block if a statement causes a change
in the current block and use the block for all following statements.
For this reason genCCall is also split into two parts.
One for calls which *won't* change the basic blocks in
which successive instructions will be placed.
A different one for calls which *are* known to change the
basic block.
For this reason genCCall is also split into two parts. One for calls which
*won't* change the basic blocks in which successive instructions will be
placed (since they only evaluate CmmExpr, which can only contain MachOps, which
cannot introduce basic blocks in their lowerings). A different one for calls
which *are* known to change the basic block.
-}
......@@ -1028,6 +1028,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
tmp. This is likely to be better, because the reg alloc can
eliminate this reg->reg move here (it won't eliminate the other one,
because the move is into the fixed %ecx).
* in the case of C calls the use of ecx here can interfere with arguments.
We avoid this with the hack described in Note [Evaluate C-call
arguments before placing in destination registers]
-}
shift_code width instr x y{-amount-} = do
x_code <- getAnyReg x
......@@ -2022,6 +2025,7 @@ genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop))
arg <- getNewRegNat format
arg_code <- getAnyReg n
platform <- ncgPlatform <$> getConfig
let dst_r = getRegisterReg platform (CmmLocal dst)
(code, lbl) <- op_code dst_r arg amode
return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)
......@@ -2667,9 +2671,12 @@ genCCall' _ is32Bit target dest_regs args bid = do
return code
_ -> panic "genCCall: Wrong number of arguments/results for imul2"
_ -> if is32Bit
then genCCall32' target dest_regs args
else genCCall64' target dest_regs args
_ -> do
(instrs0, args') <- evalArgs bid args
instrs1 <- if is32Bit
then genCCall32' target dest_regs args'
else genCCall64' target dest_regs args'
return (instrs0 `appOL` instrs1)
where divOp1 platform signed width results [arg_x, arg_y]
= divOp platform signed width results Nothing arg_x arg_y
......@@ -2732,6 +2739,83 @@ genCCall' _ is32Bit target dest_regs args bid = do
addSubIntC _ _ _ _ _ _ _ _
= panic "genCCall: Wrong number of arguments/results for addSubIntC"
{-
Note [Evaluate C-call arguments before placing in destination registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When producing code for C calls we must take care when placing arguments
in their final registers. Specifically, we must ensure that temporary register
usage due to evaluation of one argument does not clobber a register in which we
already placed a previous argument (e.g. as the code generation logic for
MO_Shl can clobber %rcx due to x86 instruction limitations).
This is precisely what happened in #18527. Consider this C--:
(result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));
Here we are calling the C function `doSomething` with three arguments, the last
involving a non-trivial expression involving MO_Shl. In this case the NCG could
naively generate the following assembly (where $tmp denotes some temporary
register and $argN denotes the register for argument N, as dictated by the
platform's calling convention):
mov _s2hp, $arg1 # place first argument
mov _s2hq, $arg2 # place second argument
# Compute 1 << _s2hz
mov _s2hz, %rcx
shl %cl, $tmp
# Compute (_s2hw | (1 << _s2hz))
mov _s2hw, $arg3
or $tmp, $arg3
# Perform the call
call func
This code is outright broken on Windows which assigns $arg1 to %rcx. This means
that the evaluation of the last argument clobbers the first argument.
To avoid this we use a rather awful hack: when producing code for a C call with
at least one non-trivial argument, we first evaluate all of the arguments into
local registers before moving them into their final calling-convention-defined
homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an
expression which might contain a MachOp since these are the only cases which
might clobber registers. Furthermore, we use a conservative approximation of
this condition (only looking at the top-level of CmmExprs) to avoid spending
too much effort trying to decide whether we want to take the fast path.
Note that this hack *also* applies to calls to out-of-line PrimTargets (which
are lowered via a C call) since outOfLineCmmOp produces the call via
(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up
back in genCCall{32,64}.
-}
-- | See Note [Evaluate C-call arguments before placing in destination registers]
evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
evalArgs bid actuals
| any mightContainMachOp actuals = do
regs_blks <- mapM evalArg actuals
return (concatOL $ map fst regs_blks, map snd regs_blks)
| otherwise = return (nilOL, actuals)
where
mightContainMachOp (CmmReg _) = False
mightContainMachOp (CmmRegOff _ _) = False
mightContainMachOp (CmmLit _) = False
mightContainMachOp _ = True
evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
evalArg actual = do
platform <- getPlatform
lreg <- newLocalReg $ cmmExprType platform actual
(instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
-- The above assignment shouldn't change the current block
MASSERT(isNothing bid1)
return (instrs, CmmReg $ CmmLocal lreg)
newLocalReg :: CmmType -> NatM LocalReg
newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty
-- Note [DIV/IDIV for bytes]
--
-- IDIV reminder:
......
......@@ -1891,7 +1891,9 @@ substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
--
-- For the inverse operation, see 'liftCoMatch'
ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
ty_co_subst lc role ty
ty_co_subst !lc role ty
-- !lc: making this function strict in lc allows callers to
-- pass its two components separately, rather than boxing them
= go role ty
where
go :: Role -> Type -> Coercion
......@@ -2864,9 +2866,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-- need a coercion (kind_co :: old_kind ~ new_kind).
--
-- The bangs here have been observed to improve performance
-- significantly in optimized builds.
let kind_co = mkSymCo $
liftCoSubst Nominal lc (tyCoBinderType binder)
-- significantly in optimized builds; see #18502
let !kind_co = mkSymCo $
liftCoSubst Nominal lc (tyCoBinderType binder)
!casted_xi = xi `mkCastTy` kind_co
casted_co = mkCoherenceLeftCo role xi kind_co co
......
......@@ -1453,11 +1453,14 @@ dataConRepArgTys (MkData { dcRep = rep
dataConIdentity :: DataCon -> ByteString
-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
[ BSB.byteString $ bytesFS (unitFS (moduleUnit mod))
[ BSB.shortByteString $ fastStringToShortByteString $
unitFS $ moduleUnit mod
, BSB.int8 $ fromIntegral (ord ':')
, BSB.byteString $ bytesFS (moduleNameFS (moduleName mod))
, BSB.shortByteString $ fastStringToShortByteString $
moduleNameFS $ moduleName mod
, BSB.int8 $ fromIntegral (ord '.')
, BSB.byteString $ bytesFS (occNameFS (nameOccName name))
, BSB.shortByteString $ fastStringToShortByteString $
occNameFS $ nameOccName name
]
where name = dataConName dc
mod = ASSERT( isExternalName name ) nameModule name
......
......@@ -729,8 +729,6 @@ lintJoinLams join_arity enforce rhs
where
go 0 expr = lintCoreExpr expr
go n (Lam var body) = lintLambda var $ go (n-1) body
-- N.B. join points can be cast. e.g. we consider ((\x -> ...) `cast` ...)
-- to be a join point at join arity 1.
go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas
= failWithL $ mkBadJoinArityMsg bndr join_arity n rhs
| otherwise -- Future join point, not yet eta-expanded
......@@ -779,36 +777,26 @@ hurts us here.
Note [Linting of runRW#]
~~~~~~~~~~~~~~~~~~~~~~~~
runRW# has some very peculiar behavior (see Note [runRW magic] in
GHC.CoreToStg.Prep) which CoreLint must accommodate.
runRW# has some very special behavior (see Note [runRW magic] in
GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing
join points in its argument. For example, this is fine:
As described in Note [Casts and lambdas] in
GHC.Core.Opt.Simplify.Utils, the simplifier pushes casts out of
lambdas. Concretely, the simplifier will transform
join j x = ...
in runRW# (\s. case v of
A -> j 3
B -> j 4)
runRW# @r @ty (\s -> expr `cast` co)
Usually those calls to the join point 'j' would not be valid tail calls,
because they occur in a function argument. But in the case of runRW#
they are fine, because runRW# (\s.e) behaves operationally just like e.
(runRW# is ultimately inlined in GHC.CoreToStg.Prep.)
into
runRW# @r @ty ((\s -> expr) `cast` co)
Consequently we need to handle the case that the continuation is a
cast of a lambda. See Note [Casts and lambdas] in
GHC.Core.Opt.Simplify.Utils.
In the event that the continuation is headed by a lambda (which
will bind the State# token) we can safely allow calls to join
points since CorePrep is going to apply the continuation to
RealWorld.
In the case that the continuation is not a lambda we lint the
continuation disallowing join points, to rule out things like,
In the case that the continuation is /not/ a lambda we simply disable this
special behaviour. For example, this is /not/ fine:
join j = ...
in runRW# @r @ty (
let x = jump j
in x
)
in runRW# @r @ty (jump j)
************************************************************************
......@@ -929,10 +917,6 @@ lintCoreExpr e@(App _ _)
; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2
-- See Note [Linting of runRW#]
; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
lintRunRWCont (Cast expr co) = do
(ty, ue) <- lintRunRWCont expr
new_ty <- lintCastExpr expr ty co
return (new_ty, ue)
lintRunRWCont expr@(Lam _ _) = do
lintJoinLams 1 (Just fun) expr
lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other
......@@ -941,10 +925,6 @@ lintCoreExpr e@(App _ _)
; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3
; lintCoreArgs app_ty rest }
| Var fun <- fun
, fun `hasKey` runRWKey
= failWithL (text "Invalid runRW# application")
| otherwise
= do { pair <- lintCoreFun fun (length args)
; lintCoreArgs pair args }
......
......@@ -832,7 +832,7 @@ occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
certainly_inline -- See Note [Cascading inlines]
= case occ of
OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }
OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
-> active && not_stable
_ -> False
......@@ -2563,7 +2563,7 @@ mkOneOcc id int_cxt arity
= emptyDetails
where
occ_info = OneOcc { occ_in_lam = NotInsideLam
, occ_one_br = InOneBranch
, occ_n_br = oneBranch
, occ_int_cxt = int_cxt
, occ_tail = AlwaysTailCalled arity }
......@@ -2967,11 +2967,15 @@ addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
-- (orOccInfo orig new) is used
-- when combining occurrence info from branches of a case
orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1
, occ_tail = tail1 })
(OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2
, occ_tail = tail2 })
= OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches
orOccInfo (OneOcc { occ_in_lam = in_lam1
, occ_n_br = nbr1
, occ_int_cxt = int_cxt1
, occ_tail = tail1 })
(OneOcc { occ_in_lam = in_lam2
, occ_n_br = nbr2
, occ_int_cxt = int_cxt2
, occ_tail = tail2 })
= OneOcc { occ_n_br = nbr1 + nbr2
, occ_in_lam = in_lam1 `mappend` in_lam2
, occ_int_cxt = int_cxt1 `mappend` int_cxt2
, occ_tail = tail1 `andTailCallInfo` tail2 }
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE CPP #-}
module GHC.Core.Opt.Driver ( core2core, simplifyExpr ) where
module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where
#include "HsVersions.h"
......
......@@ -658,8 +658,8 @@ lvlMFE env strict_ctxt e@(_, AnnCase {})
lvlMFE env strict_ctxt ann_expr
| floatTopLvlOnly env && not (isTopLvl dest_lvl)
-- Only floating to the top level is allowed.
|| anyDVarSet isJoinId fvs -- If there is a free join, don't float
-- See Note [Free join points]
|| hasFreeJoin env fvs -- If there is a free join, don't float
-- See Note [Free join points]
|| isExprLevPoly expr
-- We can't let-bind levity polymorphic expressions
-- See Note [Levity polymorphism invariants] in GHC.Core
......@@ -755,6 +755,14 @@ lvlMFE env strict_ctxt ann_expr
&& floatConsts env
&& (not strict_ctxt || is_bot || exprIsHNF expr)
hasFreeJoin :: LevelEnv -> DVarSet -> Bool
-- Has a free join point which is not being floated to top level.
-- (In the latter case it won't be a join point any more.)
-- Not treating top-level ones specially had a massive effect
-- on nofib/minimax/Prog.prog
hasFreeJoin env fvs
= not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
isBottomThunk :: Maybe (Arity, s) -> Bool
-- See Note [Bottoming floats] (2)
isBottomThunk (Just (0, _)) = True -- Zero arity
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where
#include "HsVersions.h"
......@@ -39,8 +39,8 @@ import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey )
import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, botDiv )
import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, seqDmd, botDiv )
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Types.Unique ( hasKey )
......@@ -68,7 +68,7 @@ import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
{-
The guts of the simplifier is in this module, but the driver loop for
the simplifier is in GHC.Core.Opt.Driver
the simplifier is in GHC.Core.Opt.Pipeline
Note [The big picture]
~~~~~~~~~~~~~~~~~~~~~~
......@@ -598,7 +598,7 @@ prepareRhs mode top_lvl occ rhs0
= do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
; case is_exp of
False -> return (False, emptyLetFloats, App fun arg)
True -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg
True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg
; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }
go n_val_args (Var fun)
= return (is_exp, emptyLetFloats, Var fun)
......@@ -628,32 +628,34 @@ prepareRhs mode top_lvl occ rhs0
= return (False, emptyLetFloats, other)
makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg mode arg@(ValArg { as_arg = e })
= do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd })
= do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e
; return (floats, arg { as_arg = e' }) }
makeTrivialArg _ arg
= return (emptyLetFloats, arg) -- CastBy, TyArg
makeTrivial :: SimplMode -> TopLevelFlag
makeTrivial :: SimplMode -> TopLevelFlag -> Demand
-> FastString -- ^ A "friendly name" to build the new binder from
-> OutExpr -- ^ This expression satisfies the let/app invariant
-> SimplM (LetFloats, OutExpr)
-- Binds the expression to a variable, if it's not trivial, returning the variable
makeTrivial mode top_lvl occ_fs expr
-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]
makeTrivial mode top_lvl dmd occ_fs expr
| exprIsTrivial expr -- Already trivial
|| not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise
-- See Note [Cannot trivialise]
= return (emptyLetFloats, expr)
| Cast expr' co <- expr
= do { (floats, triv_expr) <- makeTrivial mode top_lvl occ_fs expr'
= do { (floats, triv_expr) <- makeTrivial mode top_lvl dmd occ_fs expr'
; return (floats, Cast triv_expr co) }
| otherwise
= do { (floats, new_id) <- makeTrivialBinding mode top_lvl occ_fs
vanillaIdInfo expr expr_ty
id_info expr expr_ty
; return (floats, Var new_id) }
where
id_info = vanillaIdInfo `setDemandInfo` dmd
expr_ty = exprType expr
makeTrivialBinding :: SimplMode -> TopLevelFlag
......@@ -1002,7 +1004,7 @@ simplExprF1 env (App fun arg) cont
, sc_hole_ty = hole'
, sc_cont = cont } }
_ ->
-- crucially, these are /lazy/ bindings. They will
-- Crucially, sc_hole_ty is a /lazy/ binding. It will
-- be forced only if we need to run contHoleType.
-- When these are forced, we might get quadratic behavior;
-- this quadratic blowup could be avoided by drilling down
......@@ -1010,13 +1012,10 @@ simplExprF1 env (App fun arg) cont
-- (instead of one-at-a-time). But in practice, we have not
-- observed the quadratic behavior, so this extra entanglement
-- seems not worthwhile.
let fun_ty = exprType fun
(m, _, _) = splitFunTy fun_ty
in
simplExprF env fun $
ApplyToVal { sc_arg = arg, sc_env = env
, sc_hole_ty = substTy env (exprType fun)
, sc_dup = NoDup, sc_cont = cont, sc_mult = m }
simplExprF env fun $
ApplyToVal { sc_arg = arg, sc_env = env
, sc_hole_ty = substTy env (exprType fun)
, sc_dup = NoDup, sc_cont = cont }
simplExprF1 env expr@(Lam {}) cont
= {-#SCC "simplExprF1-Lam" #-}
......@@ -1321,8 +1320,8 @@ rebuild env expr cont
Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
-> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }
-> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont
StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
-> rebuildCall env (addValArgTo fun expr fun_ty ) cont
StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
, sc_env = se, sc_cont = cont }
-> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
......@@ -1414,7 +1413,7 @@ simplCast env body co0 cont0
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = tail, sc_mult = m })
, sc_dup = dup, sc_cont = tail })
| Just (co1, m_co2) <- pushCoValArg co
, let new_ty = coercionRKind co1
, not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg
......@@ -1438,8 +1437,7 @@ simplCast env body co0 cont0
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail'
, sc_hole_ty = coercionLKind co
, sc_mult = m }) } }
, sc_hole_ty = coercionLKind co }) } }
addCoerce co cont
| isReflexiveCo co = return cont -- Having this at the end makes a huge
......@@ -1567,7 +1565,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
simplLam env' bndrs body cont }
-- Deal with strict bindings
| isStrictId bndr -- Includes coercions
| isStrictId bndr -- Includes coercions, and unlifted types
, sm_case_case (getMode env)
= simplExprF (rhs_se `setInScopeFromE` env) rhs
(StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
......@@ -1924,7 +1922,7 @@ rebuildCall :: SimplEnv
-- - and rebuild
---------- Bottoming applications --------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
......@@ -1972,44 +1970,46 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
= rebuildCall env (addTyArgTo info arg_ty hole_ty) cont
---------- The runRW# rule. Do this after absorbing all arguments ------
-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.
--
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })
| fun `hasKey` runRWKey
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
, not (contIsStop cont) -- Don't fiddle around if the continuation is boring
, [ TyArg {}, TyArg {} ] <- rev_args
= do { s <- newId (fsLit "s") Many realWorldStatePrimTy
; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
; let (m,_,_) = splitFunTy fun_ty
env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
ty' = contResultType cont
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
, sc_env = env', sc_cont = cont
, sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'
, sc_mult = m }
, sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
-- cont' applies to s, then K
; body' <- simplExprC env' arg cont'
; let arg' = Lam s body'
rr' = getRuntimeRep ty'
call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']
call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
; return (emptyFloats env, call') }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
rebuildCall env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
, sc_cont = cont, sc_mult = m })
, sc_cont = cont })
-- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
= rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont
= rebuildCall env (addValArgTo fun_info arg fun_ty) cont
-- Strict arguments
| str
| isStrictArgInfo fun_info
, sm_case_case (getMode env)
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = info', sc_cci = cci_strict
, sc_dup = Simplified, sc_fun_ty = fun_ty
, sc_cont = cont, sc_mult = m })
(StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
, sc_dup = Simplified
, sc_cont = cont })
-- Note [Shadowing]
-- Lazy arguments
......@@ -2019,27 +2019,11 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
(mkLazyArgStop arg_ty cci_lazy)
; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont }
(mkLazyArgStop arg_ty (lazyArgContext fun_info))
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
where
info' = info { ai_strs = strs, ai_discs = discs }
arg_ty = funArgTy fun_ty
-- Use this for lazy arguments
cci_lazy | encl_rules = RuleArgCtxt
| disc > 0 = DiscArgCtxt -- Be keener here
| otherwise = BoringCtxt -- Nothing interesting
-- ..and this for strict arguments
cci_strict | encl_rules = RuleArgCtxt
| disc > 0 = DiscArgCtxt
| otherwise = RhsCtxt
-- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we
-- want to be a bit more eager to inline g, because it may
-- expose an eval (on x perhaps) that can be eliminated or
-- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
-- It's worth an 18% improvement in allocation for this
-- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
---------- No further useful info, revert to generic rebuild ------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
......@@ -2243,24 +2227,11 @@ trySeqRules in_env scrut rhs cont
, TyArg { as_arg_ty = rhs_ty
, as_hole_ty = res2_ty }
, ValArg { as_arg = no_cast_scrut
, as_hole_ty = res3_ty
, as_mult = Many } ]
-- The multiplicity of the scrutiny above is Many because the type
-- of seq requires that its first argument is unrestricted. The
-- typing rule of case also guarantees it though. In a more
-- general world, where the first argument of seq would have
-- affine multiplicity, then we could use the multiplicity of
-- the case (held in the case binder) instead.
, as_dmd = seqDmd
, as_hole_ty = res3_ty } ]
rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
, sc_env = in_env, sc_cont = cont
, sc_hole_ty = res4_ty, sc_mult = Many }
-- The multiplicity in sc_mult above is the
-- multiplicity of the second argument of seq. Since
-- seq's type, as it stands, imposes that its second
-- argument be unrestricted, so is
-- sc_mult. However, a more precise typing rule,
-- for seq, would be to have it be linear. In which
-- case, sc_mult should be 1.
, sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
......@@ -3268,31 +3239,41 @@ altsWouldDup (alt:alts)
is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs
-------------------------
mkDupableCont :: SimplEnv -> SimplCont
mkDupableCont :: SimplEnv
-> SimplCont
-> SimplM ( SimplFloats -- Incoming SimplEnv augmented with
-- extra let/join-floats and in-scope variables
, SimplCont) -- dup_cont: duplicable continuation
mkDupableCont env cont
= mkDupableContWithDmds env (repeat topDmd) cont
mkDupableContWithDmds
:: SimplEnv -> [Demand] -- Demands on arguments; always infinite
-> SimplCont -> SimplM ( SimplFloats, SimplCont)
mkDupableContWithDmds env _ cont
| contIsDupable cont
= return (emptyFloats env, cont)
mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
mkDupableCont env (CastIt ty cont)
= do { (floats, cont') <- mkDupableCont env cont
mkDupableContWithDmds env dmds (CastIt ty cont)
= do { (floats, cont') <- mkDupableContWithDmds env dmds cont
; return (floats, CastIt ty cont') }
-- Duplicating ticks for now, not sure if this is good or not
mkDupableCont env (TickIt t cont)
= do { (floats, cont') <- mkDupableCont env cont
mkDupableContWithDmds env dmds (TickIt t cont)
= do { (floats, cont') <- mkDupableContWithDmds env dmds cont
; return (floats, TickIt t cont') }
mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
, sc_body = body, sc_env = se, sc_cont = cont})
-- See Note [Duplicating StrictBind]
mkDupableContWithDmds env _
(StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
, sc_body = body, sc_env = se, sc_cont = cont})
-- See Note [Duplicating StrictBind]
-- K[ let x = <> in b ] --> join j x = K[ b ]
-- j <>
= do { let sb_env = se `setInScopeFromE` env
; (sb_env1, bndr') <- simplBinder sb_env bndr
; (sb_env1, bndr') <- simplBinder sb_env bndr
; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
-- No need to use mkDupableCont before simplLam; we
-- use cont once here, and then share the result if necessary
......@@ -3300,56 +3281,65 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
; let join_body = wrapFloats floats1 join_inner
res_ty = contResultType cont
; (floats2, body2)
<- if exprIsDupable (targetPlatform (seDynFlags env)) join_body
then return (emptyFloats env, join_body)
else do { join_bndr <- newJoinId [bndr'] res_ty
; let join_call = App (Var join_bndr) (Var bndr')
join_rhs = Lam (setOneShotLambda bndr') join_body
join_bind = NonRec join_bndr join_rhs
floats = emptyFloats env `extendFloats` join_bind
; return (floats, join_call) }
; return ( floats2
, StrictBind { sc_bndr = bndr', sc_bndrs = []
, sc_body = body2
, sc_env = zapSubstEnv se `setInScopeFromF` floats2
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup
, sc_cont = mkBoringStop res_ty } ) }
mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m })
-- See Note [Duplicating StrictArg]
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
= do { (floats1, cont') <- mkDupableCont env cont
; mkDupableStrictBind env bndr' join_body res_ty }
mkDupableContWithDmds env _
(StrictArg { sc_fun = fun, sc_cont = cont
, sc_fun_ty = fun_ty })
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
| thumbsUpPlanA cont
= -- Use Plan A of Note [Duplicating StrictArg]
do { let (_ : dmds) = ai_dmds fun
; (floats1, cont') <- mkDupableContWithDmds env dmds cont
-- Use the demands from the function to add the right
-- demand info on any bindings we make for further args
; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
(ai_args info)
(ai_args fun)
; return ( foldl' addLetFloats floats1 floats_s
, StrictArg { sc_fun = info { ai_args = args' }
, StrictArg { sc_fun = fun { ai_args = args' }
, sc_cont = cont'
, sc_cci = cci
, sc_fun_ty = fun_ty
, sc_mult = m
, sc_dup = OkToDup} ) }
mkDupableCont env (ApplyToTy { sc_cont = cont
, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
= do { (floats, cont') <- mkDupableCont env cont
| otherwise
= -- Use Plan B of Note [Duplicating StrictArg]
-- K[ f a b <> ] --> join j x = K[ f a b x ]
-- j <>
do { let rhs_ty = contResultType cont
(m,arg_ty,_) = splitFunTy fun_ty
; arg_bndr <- newId (fsLit "arg") m arg_ty
; let env' = env `addNewInScopeIds` [arg_bndr]
; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
thumbsUpPlanA (StrictArg {}) = False
thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k
thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k
thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k
thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k
thumbsUpPlanA (Select {}) = True
thumbsUpPlanA (StrictBind {}) = True
thumbsUpPlanA (Stop {}) = True
mkDupableContWithDmds env dmds
(ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
= do { (floats, cont') <- mkDupableContWithDmds env dmds cont
; return (floats, ApplyToTy { sc_cont = cont'
, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
, sc_env = se, sc_cont = cont
, sc_hole_ty = hole_ty, sc_mult = mult })
mkDupableContWithDmds env dmds
(ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
, sc_cont = cont, sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
-- in [...hole...] a
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
do { (floats1, cont') <- mkDupableCont env cont
do { let (dmd:_) = dmds -- Never fails
; (floats1, cont') <- mkDupableContWithDmds env dmds cont
; let env' = env `setInScopeFromF` floats1
; (_, se', arg') <- simplArg env' dup se arg
; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'
; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg'
; let all_floats = floats1 `addLetFloats` let_floats2
; return ( all_floats
, ApplyToVal { sc_arg = arg''
......@@ -3359,10 +3349,10 @@ mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
-- has turned arg'' into a fresh variable
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup, sc_cont = cont'
, sc_hole_ty = hole_ty, sc_mult = mult }) }
, sc_hole_ty = hole_ty }) }
mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
, sc_env = se, sc_cont = cont })
mkDupableContWithDmds env _
(Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
-- let ji = \xij -> ei
......@@ -3404,6 +3394,33 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_cont = mkBoringStop (contResultType cont) } ) }
mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
-> SimplM (SimplFloats, SimplCont)
mkDupableStrictBind env arg_bndr join_rhs res_ty
| exprIsDupable (targetPlatform (seDynFlags env)) join_rhs
= return (emptyFloats env
, StrictBind { sc_bndr = arg_bndr, sc_bndrs = []
, sc_body = join_rhs
, sc_env = zapSubstEnv env
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup
, sc_cont = mkBoringStop res_ty } )
| otherwise
= do { join_bndr <- newJoinId [arg_bndr] res_ty
; let arg_info = ArgInfo { ai_fun = join_bndr
, ai_rules = Nothing, ai_args = []
, ai_encl = False, ai_dmds = repeat topDmd
, ai_discs = repeat 0 }
; return ( addJoinFloats (emptyFloats env) $
unitJoinFloat $
NonRec join_bndr $
Lam (setOneShotLambda arg_bndr) join_rhs
, StrictArg { sc_dup = OkToDup
, sc_fun = arg_info
, sc_fun_ty = idType join_bndr
, sc_cont = mkBoringStop res_ty
} ) }
mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
......@@ -3577,57 +3594,102 @@ type variables as well as term variables.
Note [Duplicating StrictArg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We make a StrictArg duplicable simply by making all its
stored-up arguments (in sc_fun) trivial, by let-binding
them. Thus:
f E [..hole..]
==> let a = E
in f a [..hole..]
Now if the thing in the hole is a case expression (which is when
we'll call mkDupableCont), we'll push the function call into the
branches, which is what we want. Now RULES for f may fire, and
call-pattern specialisation. Here's an example from #3116
Dealing with making a StrictArg continuation duplicable has turned out
to be one of the trickiest corners of the simplifier, giving rise
to several cases in which the simplier expanded the program's size
*exponentially*. They include
#13253 exponential inlining
#10421 ditto
#18140 strict constructors
#18282 another nested-function call case
Suppose we have a call
f e1 (case x of { True -> r1; False -> r2 }) e3
and f is strict in its second argument. Then we end up in
mkDupableCont with a StrictArg continuation for (f e1 <> e3).
There are two ways to make it duplicable.
* Plan A: move the entire call inwards, being careful not
to duplicate e1 or e3, thus:
let a1 = e1
a3 = e3
in case x of { True -> f a1 r1 a3
; False -> f a1 r2 a3 }
* Plan B: make a join point:
join $j x = f e1 x e3
in case x of { True -> jump $j r1
; False -> jump $j r2 }
Notice that Plan B is very like the way we handle strict
bindings; see Note [Duplicating StrictBind].
Plan A is good. Here's an example from #3116
go (n+1) (case l of
1 -> bs'
_ -> Chunk p fpc (o+1) (l-1) bs')
If we can push the call for 'go' inside the case, we get
If we pushed the entire call for 'go' inside the case, we get
call-pattern specialisation for 'go', which is *crucial* for
this program.
this particular program.
Here is the (&&) example:
&& E (case x of { T -> F; F -> T })
==> let a = E in
case x of { T -> && a F; F -> && a T }
Much better!
Notice that
* Arguments to f *after* the strict one are handled by
the ApplyToVal case of mkDupableCont. Eg
f [..hole..] E
* We can only do the let-binding of E because the function
part of a StrictArg continuation is an explicit syntax
tree. In earlier versions we represented it as a function
(CoreExpr -> CoreEpxr) which we couldn't take apart.
Historical aide: previously we did this (where E is a
big argument:
f E [..hole..]
==> let $j = \a -> f E a
in $j [..hole..]
But this is terrible! Here's an example:
Here is another example.
&& E (case x of { T -> F; F -> T })
Now, && is strict so we end up simplifying the case with
an ArgOf continuation. If we let-bind it, we get
let $j = \v -> && E v
in simplExpr (case x of { T -> F; F -> T })
(ArgOf (\r -> $j r)
And after simplifying more we get
let $j = \v -> && E v
in case x of { T -> $j F; F -> $j T }
Which is a Very Bad Thing
Pushing the call inward (being careful not to duplicate E)
let a = E
in case x of { T -> && a F; F -> && a T }
and now the (&& a F) etc can optimise. Moreover there might
be a RULE for the function that can fire when it "sees" the
particular case alterantive.
But Plan A can have terrible, terrible behaviour. Here is a classic
case:
f (f (f (f (f True))))
Suppose f is strict, and has a body that is small enough to inline.
The innermost call inlines (seeing the True) to give
f (f (f (f (case v of { True -> e1; False -> e2 }))))
Now, suppose we naively push the entire continuation into both
case branches (it doesn't look large, just f.f.f.f). We get
case v of
True -> f (f (f (f e1)))
False -> f (f (f (f e2)))
And now the process repeats, so we end up with an exponentially large
number of copies of f. No good!
CONCLUSION: we want Plan A in general, but do Plan B is there a
danger of this nested call behaviour. The function that decides
this is called thumbsUpPlanA.
Note [Keeping demand info in StrictArg Plan A]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Following on from Note [Duplicating StrictArg], another common code
pattern that can go bad is this:
f (case x1 of { T -> F; F -> T })
(case x2 of { T -> F; F -> T })
...etc...
when f is strict in all its arguments. (It might, for example, be a
strict data constructor whose wrapper has not yet been inlined.)
We use Plan A (because there is no nesting) giving
let a2 = case x2 of ...
a3 = case x3 of ...
in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }
Now we must be careful! a2 and a3 are small, and the OneOcc code in
postInlineUnconditionally may inline them both at both sites; see Note
Note [Inline small things to avoid creating a thunk] in
Simplify.Utils. But if we do inline them, the entire process will
repeat -- back to exponential behaviour.
So we are careful to keep the demand-info on a2 and a3. Then they'll
be /strict/ let-bindings, which will be dealt with by StrictBind.
That's why contIsDupableWithDmds is careful to propagage demand
info to the auxiliary bindings it creates. See the Demand argument
to makeTrivial.
Note [Duplicating StrictBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -3636,9 +3698,10 @@ that for case expressions. After all,
let x* = e in b is similar to case e of x -> b
So we potentially make a join-point for the body, thus:
let x = [] in b ==> join j x = b
in let x = [] in j x
let x = <> in b ==> join j x = b
in j <>
Just like StrictArg in fact -- and indeed they share code.
Note [Join point abstraction] Historical note
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -43,6 +43,7 @@ import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..))
import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf )
import Control.Monad ( ap )
import GHC.Core.Multiplicity ( pattern Many )
import GHC.Exts( oneShot )
{-
************************************************************************
......@@ -56,14 +57,25 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter.
-}
newtype SimplM result
= SM { unSM :: SimplTopEnv -- Envt that does not change much
-> UniqSupply -- We thread the unique supply because
-- constantly splitting it is rather expensive
-> SimplCount
-> IO (result, UniqSupply, SimplCount)}
-- we only need IO here for dump output
= SM' { unSM :: SimplTopEnv -- Envt that does not change much
-> UniqSupply -- We thread the unique supply because
-- constantly splitting it is rather expensive
-> SimplCount
-> IO (result, UniqSupply, SimplCount)}
-- We only need IO here for dump output
deriving (Functor)
pattern SM :: (SimplTopEnv -> UniqSupply -> SimplCount
-> IO (result, UniqSupply, SimplCount))
-> SimplM result
-- This pattern synonym makes the simplifier monad eta-expand,
-- which as a very beneficial effect on compiler performance
-- (worth a 1-2% reduction in bytes-allocated). See #18202.
-- See Note [The one-shot state monad trick] in GHC.Core.Unify
pattern SM m <- SM' m
where
SM m = SM' (oneShot m)
data SimplTopEnv
= STE { st_flags :: DynFlags
, st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run
......