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
  • 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
  • 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
  • zaquest/ghc
  • fangyi-zhou/ghc
  • augyg/ghc
  • rkirkman/ghc
  • gulin.serge/ghc-windows-aarch64-bootstrap
  • iris/ghc
  • kwxm/ghc
  • maralorn/ghc
  • rafl/ghc
  • nikshalark/ghc
  • mrcjkb/ghc
  • blackheaven/ghc
  • laurenyim/ghc
  • bolt12/ghc
  • Xitian9/ghc
  • wenkokke/ghc
  • kephas/ghc
651 results
Show changes
Commits on Source (86)
Showing
with 265 additions and 195 deletions
...@@ -174,16 +174,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], ...@@ -174,16 +174,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
GET_ARM_ISA() GET_ARM_ISA()
test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\"" test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
;; ;;
alpha) alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
test -z "[$]2" || eval "[$]2=ArchAlpha"
;;
mips|mipseb)
test -z "[$]2" || eval "[$]2=ArchMipseb"
;;
mipsel)
test -z "[$]2" || eval "[$]2=ArchMipsel"
;;
hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
test -z "[$]2" || eval "[$]2=ArchUnknown" test -z "[$]2" || eval "[$]2=ArchUnknown"
;; ;;
*) *)
...@@ -221,13 +212,16 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], ...@@ -221,13 +212,16 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
freebsd) freebsd)
test -z "[$]2" || eval "[$]2=OSFreeBSD" test -z "[$]2" || eval "[$]2=OSFreeBSD"
;; ;;
kfreebsdgnu)
test -z "[$]2" || eval "[$]2=OSKFreeBSD"
;;
openbsd) openbsd)
test -z "[$]2" || eval "[$]2=OSOpenBSD" test -z "[$]2" || eval "[$]2=OSOpenBSD"
;; ;;
netbsd) netbsd)
test -z "[$]2" || eval "[$]2=OSNetBSD" test -z "[$]2" || eval "[$]2=OSNetBSD"
;; ;;
dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku)
test -z "[$]2" || eval "[$]2=OSUnknown" test -z "[$]2" || eval "[$]2=OSUnknown"
;; ;;
*) *)
...@@ -355,6 +349,7 @@ AC_DEFUN([FP_SETTINGS], ...@@ -355,6 +349,7 @@ AC_DEFUN([FP_SETTINGS],
then then
SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe'
SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2" SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand='$topdir/../mingw/bin/ar.exe'
SettingsPerlCommand='$topdir/../perl/perl.exe' SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe'
SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' SettingsWindresCommand='$topdir/../mingw/bin/windres.exe'
...@@ -362,6 +357,7 @@ AC_DEFUN([FP_SETTINGS], ...@@ -362,6 +357,7 @@ AC_DEFUN([FP_SETTINGS],
else else
SettingsCCompilerCommand="$WhatGccIsCalled" SettingsCCompilerCommand="$WhatGccIsCalled"
SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2" SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand="$ArCmd"
SettingsPerlCommand="$PerlCmd" SettingsPerlCommand="$PerlCmd"
SettingsDllWrapCommand="/bin/false" SettingsDllWrapCommand="/bin/false"
SettingsWindresCommand="/bin/false" SettingsWindresCommand="/bin/false"
...@@ -369,6 +365,7 @@ AC_DEFUN([FP_SETTINGS], ...@@ -369,6 +365,7 @@ AC_DEFUN([FP_SETTINGS],
fi fi
AC_SUBST(SettingsCCompilerCommand) AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags) AC_SUBST(SettingsCCompilerFlags)
AC_SUBST(SettingsArCommand)
AC_SUBST(SettingsPerlCommand) AC_SUBST(SettingsPerlCommand)
AC_SUBST(SettingsDllWrapCommand) AC_SUBST(SettingsDllWrapCommand)
AC_SUBST(SettingsWindresCommand) AC_SUBST(SettingsWindresCommand)
...@@ -1894,6 +1891,12 @@ AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[ ...@@ -1894,6 +1891,12 @@ AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[
if test $GhcCanonVersion -ge 701 if test $GhcCanonVersion -ge 701
then then
$1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'` $1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'`
tmp=${$1#\$topdir/}
if test "${$1}" != "$tmp"
then
topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'`
$1="$topdir/$tmp"
fi
else else
$1=$3 $1=$3
fi fi
...@@ -1942,10 +1945,12 @@ AC_DEFUN([XCODE_VERSION],[ ...@@ -1942,10 +1945,12 @@ AC_DEFUN([XCODE_VERSION],[
# Finds where gcc is # Finds where gcc is
AC_DEFUN([FIND_GCC],[ AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" && if test "$TargetOS_CPP" = "darwin" &&
test "$XCodeVersion1" -ge 4 test "$XCodeVersion1" -eq 4 &&
test "$XCodeVersion2" -lt 2
then then
# From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
# backend (instead of the LLVM backend) # than the LLVM backend). We prefer the legacy gcc, but in
# Xcode 4.2 'gcc-4.2' was removed.
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2]) FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2])
else else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
......
...@@ -430,6 +430,9 @@ instance Outputable Name where ...@@ -430,6 +430,9 @@ instance Outputable Name where
instance OutputableBndr Name where instance OutputableBndr Name where
pprBndr _ name = pprName name pprBndr _ name = pprName name
pprInfixOcc = pprInfixName
pprPrefixOcc = pprPrefixName
pprName :: Name -> SDoc pprName :: Name -> SDoc
pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})
......
...@@ -273,6 +273,9 @@ instance OutputableBndr RdrName where ...@@ -273,6 +273,9 @@ instance OutputableBndr RdrName where
| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
| otherwise = ppr n | otherwise = ppr n
pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
showRdrName :: RdrName -> String showRdrName :: RdrName -> String
showRdrName r = showSDoc (ppr r) showRdrName r = showSDoc (ppr r)
......
...@@ -757,12 +757,14 @@ isStrangeTypeReg (CmmLocal _) = False ...@@ -757,12 +757,14 @@ isStrangeTypeReg (CmmLocal _) = False
isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal CCCS = True
isStrangeTypeGlobal CurrentTSO = True isStrangeTypeGlobal CurrentTSO = True
isStrangeTypeGlobal CurrentNursery = True isStrangeTypeGlobal CurrentNursery = True
isStrangeTypeGlobal BaseReg = True isStrangeTypeGlobal BaseReg = True
isStrangeTypeGlobal r = isFixedPtrGlobalReg r isStrangeTypeGlobal r = isFixedPtrGlobalReg r
strangeRegType :: CmmReg -> Maybe SDoc strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *")) strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *")) strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *")) strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
...@@ -793,6 +795,7 @@ pprGlobalReg gr = case gr of ...@@ -793,6 +795,7 @@ pprGlobalReg gr = case gr of
SpLim -> ptext (sLit "SpLim") SpLim -> ptext (sLit "SpLim")
Hp -> ptext (sLit "Hp") Hp -> ptext (sLit "Hp")
HpLim -> ptext (sLit "HpLim") HpLim -> ptext (sLit "HpLim")
CCCS -> ptext (sLit "CCCS")
CurrentTSO -> ptext (sLit "CurrentTSO") CurrentTSO -> ptext (sLit "CurrentTSO")
CurrentNursery -> ptext (sLit "CurrentNursery") CurrentNursery -> ptext (sLit "CurrentNursery")
HpAlloc -> ptext (sLit "HpAlloc") HpAlloc -> ptext (sLit "HpAlloc")
......
...@@ -374,7 +374,7 @@ mkSlowEntryCode cl_info reg_args ...@@ -374,7 +374,7 @@ mkSlowEntryCode cl_info reg_args
stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) [] jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) []
\end{code} \end{code}
......
...@@ -271,7 +271,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks ...@@ -271,7 +271,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
tso_stackobj = closureField oFFSET_StgTSO_stackobj tso_stackobj = closureField oFFSET_StgTSO_stackobj
tso_CCCS = closureField oFFSET_StgTSO_CCCS tso_CCCS = closureField oFFSET_StgTSO_cccs
stack_STACK = closureField oFFSET_StgStack_stack stack_STACK = closureField oFFSET_StgStack_stack
stack_SP = closureField oFFSET_StgStack_sp stack_SP = closureField oFFSET_StgStack_sp
......
...@@ -178,8 +178,8 @@ emitCostCentreDecl cc = do ...@@ -178,8 +178,8 @@ emitCostCentreDecl cc = do
label, -- char *label, label, -- char *label,
modl, -- char *module, modl, -- char *module,
loc, -- char *srcloc, loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link zero -- struct _CostCentre *link
] ]
......
...@@ -963,7 +963,10 @@ infoTableLabelFromCI :: ClosureInfo -> CLabel ...@@ -963,7 +963,10 @@ infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI = fst . labelsFromCI infoTableLabelFromCI = fst . labelsFromCI
entryLabelFromCI :: ClosureInfo -> CLabel entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI = snd . labelsFromCI entryLabelFromCI ci
| tablesNextToCode = info_lbl
| otherwise = entry_lbl
where (info_lbl, entry_lbl) = labelsFromCI ci
labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry)
labelsFromCI cl@(ClosureInfo { closureName = name, labelsFromCI cl@(ClosureInfo { closureName = name,
......
...@@ -246,7 +246,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks ...@@ -246,7 +246,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
tso_stackobj = closureField oFFSET_StgTSO_stackobj tso_stackobj = closureField oFFSET_StgTSO_stackobj
tso_CCCS = closureField oFFSET_StgTSO_CCCS tso_CCCS = closureField oFFSET_StgTSO_cccs
stack_STACK = closureField oFFSET_StgStack_stack stack_STACK = closureField oFFSET_StgStack_stack
stack_SP = closureField oFFSET_StgStack_sp stack_SP = closureField oFFSET_StgStack_sp
......
...@@ -223,14 +223,14 @@ emitCostCentreDecl cc = do ...@@ -223,14 +223,14 @@ emitCostCentreDecl cc = do
-- All cost centres will be in the main package, since we -- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages. -- don't normally use -auto-all or add SCCs to other packages.
-- Hence don't emit the package name in the module here. -- Hence don't emit the package name in the module here.
; let lits = [ zero, -- StgInt ccID, ; let lits = [ zero, -- StgInt ccID,
label, -- char *label, label, -- char *label,
modl, -- char *module, modl, -- char *module,
loc, -- char *srcloc, loc, -- char *srcloc,
zero, -- StgWord time_ticks zero64, -- StgWord64 mem_alloc
zero64, -- StgWord64 mem_alloc zero, -- StgWord time_ticks
is_caf, -- StgInt is_caf is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link zero -- struct _CostCentre *link
] ]
; emitDataLits (mkCCLabel cc) lits ; emitDataLits (mkCCLabel cc) lits
} }
......
...@@ -700,29 +700,6 @@ lintTyBndrKind tv = ...@@ -700,29 +700,6 @@ lintTyBndrKind tv =
else lintKind ki -- type forall else lintKind ki -- type forall
------------------- -------------------
{-
lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
lint_prim_eq_co tc co arg_cos = case arg_cos of
[co1,co2] -> do { (t1,s1) <- lintCoercion co1
; (t2,s2) <- lintCoercion co2
; checkL (typeKind t1 `eqKind` typeKind t2) $
ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
_ -> failWithL (ptext (sLit "Unsaturated or oversaturated ~# coercion") <+> ppr co)
lint_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
lint_eq_co tc co arg_cos = case arg_cos of
[co1,co2] -> do { (t1,s1) <- lintCoercion co1
; (t2,s2) <- lintCoercion co2
; checkL (typeKind t1 `eqKind` typeKind t2) $
ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
[co1] -> do { (t1,s1) <- lintCoercion co1
; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
[] -> return (mkTyConApp tc [], mkTyConApp tc [])
_ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co)
-}
lintKindCoercion :: OutCoercion -> LintM OutKind lintKindCoercion :: OutCoercion -> LintM OutKind
-- Kind coercions are only reflexivity because they mean kind -- Kind coercions are only reflexivity because they mean kind
-- instantiation. See Note [Kind coercions] in Coercion -- instantiation. See Note [Kind coercions] in Coercion
...@@ -742,21 +719,6 @@ lintCoercion (Refl ty) ...@@ -742,21 +719,6 @@ lintCoercion (Refl ty)
; return (ty, ty) } ; return (ty, ty) }
lintCoercion co@(TyConAppCo tc cos) lintCoercion co@(TyConAppCo tc cos)
{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
| tc `hasKey` eqPrimTyConKey -- Just as in lintType, treat applications of (~) and (~#)
= lint_prim_eq_co tc co cos -- specially to allow for polymorphism. This hack will
-- hopefully go away when we merge in kind polymorphism.
| tc `hasKey` eqTyConKey
= lint_eq_co tc co cos
| otherwise
= do { (ss,ts) <- mapAndUnzipM lintCoercion cos
; let kind_to_check = if (tc `hasKey` funTyConKey) && (length cos == 2)
then mkArrowKinds [argTypeKind,openTypeKind] liftedTypeKind
else tyConKind tc -- TODO: Fix this when kind polymorphism is in!
; check_co_app co kind_to_check ss
; return (mkTyConApp tc ss, mkTyConApp tc ts) }
-}
= do -- We use the kind of the type constructor to know how many = do -- We use the kind of the type constructor to know how many
-- kind coercions we have (one kind coercion for one kind -- kind coercions we have (one kind coercion for one kind
-- instantiation). -- instantiation).
...@@ -876,7 +838,10 @@ lintType ty@(FunTy t1 t2) ...@@ -876,7 +838,10 @@ lintType ty@(FunTy t1 t2)
= lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2]
lintType ty@(TyConApp tc tys) lintType ty@(TyConApp tc tys)
| tyConHasKind tc | tyConHasKind tc -- Guards for SuperKindOon
, not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc
-- Check that primitive types are saturated
-- See Note [The kind invariant] in TypeRep
= lint_ty_app ty (tyConKind tc) tys = lint_ty_app ty (tyConKind tc) tys
| otherwise | otherwise
= failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
......
...@@ -26,7 +26,7 @@ import CoreFVs ...@@ -26,7 +26,7 @@ import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) ) import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn import CoreSyn
import CoreSubst import CoreSubst
import MkCore import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
import Type import Type
import Literal import Literal
import Coercion import Coercion
......
...@@ -26,6 +26,7 @@ module CoreSyn ( ...@@ -26,6 +26,7 @@ module CoreSyn (
mkIntLit, mkIntLitInt, mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord, mkWordLit, mkWordLitWord,
mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit, mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat, mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble, mkDoubleLit, mkDoubleLitDouble,
...@@ -104,6 +105,7 @@ import Outputable ...@@ -104,6 +105,7 @@ import Outputable
import Util import Util
import Data.Data hiding (TyCon) import Data.Data hiding (TyCon)
import Data.Int
import Data.Word import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
...@@ -992,6 +994,8 @@ instance Outputable b => Outputable (TaggedBndr b) where ...@@ -992,6 +994,8 @@ instance Outputable b => Outputable (TaggedBndr b) where
instance Outputable b => OutputableBndr (TaggedBndr b) where instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b
\end{code} \end{code}
...@@ -1042,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b ...@@ -1042,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b
mkWordLit w = Lit (mkMachWord w) mkWordLit w = Lit (mkMachWord w)
mkWordLitWord w = Lit (mkMachWord (toInteger w)) mkWordLitWord w = Lit (mkMachWord (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
mkInt64LitInt64 :: Int64 -> Expr b
mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
-- | Create a machine character literal expression of type @Char#@. -- | Create a machine character literal expression of type @Char#@.
-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
mkCharLit :: Char -> Expr b mkCharLit :: Char -> Expr b
......
...@@ -21,7 +21,8 @@ module CoreUtils ( ...@@ -21,7 +21,8 @@ module CoreUtils (
exprType, coreAltType, coreAltsType, exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp, rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size -- * Expression and bindings size
...@@ -752,35 +753,39 @@ it's applied only to dictionaries. ...@@ -752,35 +753,39 @@ it's applied only to dictionaries.
-- --
-- We can only do this if the @y + 1@ is ok for speculation: it has no -- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception. -- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: Expr b -> Bool exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
exprOkForSpeculation = expr_ok primOpOkForSpeculation
exprOkForSideEffects = expr_ok primOpOkForSideEffects
-- Polymorphic in binder type -- Polymorphic in binder type
-- There is one call at a non-Id binder type, in SetLevels -- There is one call at a non-Id binder type, in SetLevels
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
exprOkForSpeculation (Coercion _) = True expr_ok _ (Lit _) = True
exprOkForSpeculation (Var v) = appOkForSpeculation v [] expr_ok _ (Type _) = True
exprOkForSpeculation (Cast e _) = exprOkForSpeculation e expr_ok _ (Coercion _) = True
expr_ok primop_ok (Var v) = app_ok primop_ok v []
expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
-- Tick annotations that *tick* cannot be speculated, because these -- Tick annotations that *tick* cannot be speculated, because these
-- are meant to identify whether or not (and how often) the particular -- are meant to identify whether or not (and how often) the particular
-- source expression was evaluated at runtime. -- source expression was evaluated at runtime.
exprOkForSpeculation (Tick tickish e) expr_ok primop_ok (Tick tickish e)
| tickishCounts tickish = False | tickishCounts tickish = False
| otherwise = exprOkForSpeculation e | otherwise = expr_ok primop_ok e
exprOkForSpeculation (Case e _ _ alts) expr_ok primop_ok (Case e _ _ alts)
= exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
&& altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts] && altsAreExhaustive alts -- Note [Exhaustive alts]
exprOkForSpeculation other_expr expr_ok primop_ok other_expr
= case collectArgs other_expr of = case collectArgs other_expr of
(Var f, args) -> appOkForSpeculation f args (Var f, args) -> app_ok primop_ok f args
_ -> False _ -> False
----------------------------- -----------------------------
appOkForSpeculation :: Id -> [Expr b] -> Bool app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
appOkForSpeculation fun args app_ok primop_ok fun args
= case idDetails fun of = case idDetails fun of
DFunId new_type -> not new_type DFunId new_type -> not new_type
-- DFuns terminate, unless the dict is implemented -- DFuns terminate, unless the dict is implemented
...@@ -794,7 +799,7 @@ appOkForSpeculation fun args ...@@ -794,7 +799,7 @@ appOkForSpeculation fun args
PrimOpId op PrimOpId op
| isDivOp op -- Special case for dividing operations that fail | isDivOp op -- Special case for dividing operations that fail
, [arg1, Lit lit] <- args -- only if the divisor is zero , [arg1, Lit lit] <- args -- only if the divisor is zero
-> not (isZeroLit lit) && exprOkForSpeculation arg1 -> not (isZeroLit lit) && expr_ok primop_ok arg1
-- Often there is a literal divisor, and this -- Often there is a literal divisor, and this
-- can get rid of a thunk in an inner looop -- can get rid of a thunk in an inner looop
...@@ -802,14 +807,14 @@ appOkForSpeculation fun args ...@@ -802,14 +807,14 @@ appOkForSpeculation fun args
-> True -> True
| otherwise | otherwise
-> primOpOkForSpeculation op && -> primop_ok op -- A bit conservative: we don't really need
all exprOkForSpeculation args && all (expr_ok primop_ok) args
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy -- to care about lazy arguments, but this is easy
_other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF
|| idArity fun > n_val_args -- Partial apps || idArity fun > n_val_args -- Partial apps
|| (n_val_args ==0 && || (n_val_args == 0 &&
isEvaldUnfolding (idUnfolding fun)) -- Let-bound values isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
where where
n_val_args = valArgCount args n_val_args = valArgCount args
...@@ -872,13 +877,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: ...@@ -872,13 +877,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
The inner case is redundant, and should be nuked. The inner case is redundant, and should be nuked.
Note [exprOkForSpeculation: exhaustive alts] Note [Exhaustive alts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~
We might have something like We might have something like
case x of { case x of {
A -> ... A -> ...
_ -> ...(case x of { B -> ...; C -> ... })... _ -> ...(case x of { B -> ...; C -> ... })...
Here, the inner case is fine, becuase the A alternative Here, the inner case is fine, because the A alternative
can't happen, but it's not ok to float the inner case outside can't happen, but it's not ok to float the inner case outside
the outer one (even if we know x is evaluated outside), because the outer one (even if we know x is evaluated outside), because
then it would be non-exhaustive. See Trac #5453. then it would be non-exhaustive. See Trac #5453.
......
...@@ -21,6 +21,9 @@ module MkCore ( ...@@ -21,6 +21,9 @@ module MkCore (
mkFloatExpr, mkDoubleExpr, mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS, mkCharExpr, mkStringExpr, mkStringExprFS,
-- * Floats
FloatBind(..), wrapFloat,
-- * Constructing/deconstructing implicit parameter boxes -- * Constructing/deconstructing implicit parameter boxes
mkIPUnbox, mkIPBox, mkIPUnbox, mkIPBox,
...@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type ...@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
\end{code} \end{code}
%************************************************************************
%* *
Floats
%* *
%************************************************************************
\begin{code}
data FloatBind
= FloatLet CoreBind
| FloatCase CoreExpr Id AltCon [Var]
-- case e of y { C ys -> ... }
-- See Note [Floating cases] in SetLevels
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns) body = Let defns body
wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Tuple destructors} \subsection{Tuple destructors}
......
...@@ -21,6 +21,7 @@ module PprCore ( ...@@ -21,6 +21,7 @@ module PprCore (
import CoreSyn import CoreSyn
import Literal( pprLiteral ) import Literal( pprLiteral )
import Name( pprInfixName, pprPrefixName )
import Var import Var
import Id import Id
import IdInfo import IdInfo
...@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions. ...@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions.
\begin{code} \begin{code}
instance OutputableBndr Var where instance OutputableBndr Var where
pprBndr = pprCoreBinder pprBndr = pprCoreBinder
pprInfixOcc = pprInfixName . varName
pprPrefixOcc = pprPrefixName . varName
pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder pprCoreBinder LetBind binder
......
...@@ -21,7 +21,7 @@ import Match ...@@ -21,7 +21,7 @@ import Match
import DsUtils import DsUtils
import DsMonad import DsMonad
import HsSyn hiding (collectPatBinders, collectPatsBinders ) import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
import TcHsSyn import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes -- NB: The desugarer, which straddles the source and Core worlds, sometimes
...@@ -265,21 +265,21 @@ Translation of command judgements of the form ...@@ -265,21 +265,21 @@ Translation of command judgements of the form
A | xs |- c :: [ts] t A | xs |- c :: [ts] t
\begin{code} \begin{code}
dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id]
-> DsM (CoreExpr, IdSet) -> DsM (CoreExpr, IdSet)
dsLCmd ids local_vars env_ids stack res_ty cmd dsLCmd ids local_vars stack res_ty cmd env_ids
= dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids
dsCmd :: DsCmdEnv -- arrow combinators dsCmd :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this command -> IdSet -- set of local vars available to this command
-> [Id] -- list of vars in the input to this command
-- This is typically fed back,
-- so don't pull on it too early
-> [Type] -- type of the stack -> [Type] -- type of the stack
-> Type -- return type of the command -> Type -- return type of the command
-> HsCmd Id -- command to desugar -> HsCmd Id -- command to desugar
-> [Id] -- list of vars in the input to this command
-- This is typically fed back,
-- so don't pull on it too early
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- subset of local vars that occur free
-- A |- f :: a (t*ts) t' -- A |- f :: a (t*ts) t'
-- A, xs |- arg :: t -- A, xs |- arg :: t
...@@ -288,8 +288,9 @@ dsCmd :: DsCmdEnv -- arrow combinators ...@@ -288,8 +288,9 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- --
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars env_ids stack res_ty dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
env_ids = do
let let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
...@@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty ...@@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty
res_ty res_ty
core_make_arg core_make_arg
core_arrow, core_arrow,
exprFreeVars core_arg `intersectVarSet` local_vars) exprFreeIds core_arg `intersectVarSet` local_vars)
-- A, xs |- f :: a (t*ts) t' -- A, xs |- f :: a (t*ts) t'
-- A, xs |- arg :: t -- A, xs |- arg :: t
...@@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty ...@@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty
-- --
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars env_ids stack res_ty dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
env_ids = do
let let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
...@@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty ...@@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty
res_ty res_ty
core_make_pair core_make_pair
(do_app ids arg_ty res_ty), (do_app ids arg_ty res_ty),
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg) (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)
`intersectVarSet` local_vars) `intersectVarSet` local_vars)
-- A | ys |- c :: [t:ts] t' -- A | ys |- c :: [t:ts] t'
...@@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty ...@@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty
-- --
-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
core_arg <- dsLExpr arg core_arg <- dsLExpr arg
let let
arg_ty = exprType core_arg arg_ty = exprType core_arg
...@@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do ...@@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
res_ty res_ty
core_map core_map
core_cmd, core_cmd,
(exprFreeVars core_arg `intersectVarSet` local_vars) free_vars `unionVarSet`
`unionVarSet` free_vars) (exprFreeIds core_arg `intersectVarSet` local_vars))
-- A | ys |- c :: [ts] t' -- A | ys |- c :: [ts] t'
-- ----------------------------------------------- -- -----------------------------------------------
...@@ -372,11 +374,12 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do ...@@ -372,11 +374,12 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
-- --
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty dsCmd ids local_vars stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
env_ids = do
let let
pat_vars = mkVarSet (collectPatsBinders pats) pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars local_vars' = pat_vars `unionVarSet` local_vars
stack' = drop (length pats) stack stack' = drop (length pats) stack
(core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body
stack_ids <- mapM newSysLocalDs stack stack_ids <- mapM newSysLocalDs stack
...@@ -399,8 +402,8 @@ dsCmd ids local_vars env_ids stack res_ty ...@@ -399,8 +402,8 @@ dsCmd ids local_vars env_ids stack res_ty
return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
free_vars `minusVarSet` pat_vars) free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
= dsLCmd ids local_vars env_ids stack res_ty cmd = dsLCmd ids local_vars stack res_ty cmd env_ids
-- A, xs |- e :: Bool -- A, xs |- e :: Bool
-- A | xs1 |- c1 :: [ts] t -- A | xs1 |- c1 :: [ts] t
...@@ -412,7 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) ...@@ -412,7 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
-- c1 ||| c2 -- c1 ||| c2
dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd)
env_ids = do
core_cond <- dsLExpr cond core_cond <- dsLExpr cond
(core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
(core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd
...@@ -428,7 +432,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = ...@@ -428,7 +432,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) =
then_ty = envStackType then_ids stack then_ty = envStackType then_ids stack
else_ty = envStackType else_ids stack else_ty = envStackType else_ids stack
sum_ty = mkTyConApp either_con [then_ty, else_ty] sum_ty = mkTyConApp either_con [then_ty, else_ty]
fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars
core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids)
core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)
...@@ -472,7 +476,8 @@ case bodies, containing the following fields: ...@@ -472,7 +476,8 @@ case bodies, containing the following fields:
bodies with |||. bodies with |||.
\begin{code} \begin{code}
dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
env_ids = do
stack_ids <- mapM newSysLocalDs stack stack_ids <- mapM newSysLocalDs stack
-- Extract and desugar the leaf commands in the case, building tuple -- Extract and desugar the leaf commands in the case, building tuple
...@@ -482,7 +487,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ ...@@ -482,7 +487,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
leaves = concatMap leavesMatch matches leaves = concatMap leavesMatch matches
make_branch (leaf, bound_vars) = do make_branch (leaf, bound_vars) = do
(core_leaf, _fvs, leaf_ids) <- (core_leaf, _fvs, leaf_ids) <-
dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack res_ty leaf
return ([mkHsEnvStackExpr leaf_ids stack_ids], return ([mkHsEnvStackExpr leaf_ids stack_ids],
envStackType leaf_ids stack, envStackType leaf_ids stack,
core_leaf) core_leaf)
...@@ -522,7 +527,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ ...@@ -522,7 +527,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
core_matches <- matchEnvStack env_ids stack_ids core_body core_matches <- matchEnvStack env_ids stack_ids core_body
return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
exprFreeVars core_body `intersectVarSet` local_vars) exprFreeIds core_body `intersectVarSet` local_vars)
-- A | ys |- c :: [ts] t -- A | ys |- c :: [ts] t
-- ---------------------------------- -- ----------------------------------
...@@ -530,10 +535,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ ...@@ -530,10 +535,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
-- --
-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c -- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
let let
defined_vars = mkVarSet (collectLocalBinders binds) defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = local_vars `unionVarSet` defined_vars local_vars' = defined_vars `unionVarSet` local_vars
(core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
stack_ids <- mapM newSysLocalDs stack stack_ids <- mapM newSysLocalDs stack
...@@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do ...@@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
res_ty res_ty
core_map core_map
core_body, core_body,
exprFreeVars core_binds `intersectVarSet` local_vars) exprFreeIds core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
= dsCmdDo ids local_vars env_ids res_ty stmts = dsCmdDo ids local_vars res_ty stmts env_ids
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti -- A | xs |- ci :: [tsi] ti
-- ----------------------------------- -- -----------------------------------
-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
return (mkApps (App core_op (Type env_ty)) core_args, return (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets) unionVarSets fv_sets)
dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
(expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr
return (Tick tickish expr1, id_set) return (Tick tickish expr1, id_set)
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
...@@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) ...@@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
dsTrimCmdArg dsTrimCmdArg
:: IdSet -- set of local vars available to this command :: IdSet -- set of local vars available to this command
-> [Id] -- list of vars in the input to this command -> [Id] -- list of vars in the input to this command
-> LHsCmdTop Id -- command argument to desugar -> LHsCmdTop Id -- command argument to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
meth_ids <- mkCmdEnv ids meth_ids <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
...@@ -603,11 +607,24 @@ dsfixCmd ...@@ -603,11 +607,24 @@ dsfixCmd
-> Type -- return type of the command -> Type -- return type of the command
-> LHsCmd Id -- command to desugar -> LHsCmd Id -- command to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free IdSet, -- subset of local vars that occur free
[Id]) -- set as a list, fed back [Id]) -- the same local vars as a list, fed back
dsfixCmd ids local_vars stack cmd_ty cmd dsfixCmd ids local_vars stack cmd_ty cmd
= fixDs (\ ~(_,_,env_ids') -> do = trimInput (dsLCmd ids local_vars stack cmd_ty cmd)
(core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd
-- Feed back the list of local variables actually used a command,
-- for use as the input tuple of the generated arrow.
trimInput
:: ([Id] -> DsM (CoreExpr, IdSet))
-> DsM (CoreExpr, -- desugared expression
IdSet, -- subset of local vars that occur free
[Id]) -- same local vars as a list, fed back to
-- the inner function to form the tuple of
-- inputs to the arrow.
trimInput build_arrow
= fixDs (\ ~(_,_,env_ids) -> do
(core_cmd, free_vars) <- build_arrow env_ids
return (core_cmd, free_vars, varSetElems free_vars)) return (core_cmd, free_vars, varSetElems free_vars))
\end{code} \end{code}
...@@ -620,31 +637,29 @@ Translation of command judgements of the form ...@@ -620,31 +637,29 @@ Translation of command judgements of the form
dsCmdDo :: DsCmdEnv -- arrow combinators dsCmdDo :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> [Id] -- list of vars in the input to this statement -> [Id] -- list of vars in the input to this statement
-- This is typically fed back, -- This is typically fed back,
-- so don't pull on it too early -- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- subset of local vars that occur free
-- A | xs |- c :: [] t -- A | xs |- c :: [] t
-- -------------------------- -- --------------------------
-- A | xs |- do { c } :: [] t -- A | xs |- do { c } :: [] t
dsCmdDo _ _ _ _ [] = panic "dsCmdDo" dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)] dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids
= dsLCmd ids local_vars env_ids [] res_ty body = dsLCmd ids local_vars [] res_ty body env_ids
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
let let
bound_vars = mkVarSet (collectLStmtBinders stmt) bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars local_vars' = bound_vars `unionVarSet` local_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids return (do_compose ids
(mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids') (mkBigCoreVarTupTy env_ids')
...@@ -658,21 +673,21 @@ A statement maps one local environment to another, and is represented ...@@ -658,21 +673,21 @@ A statement maps one local environment to another, and is represented
as an arrow from one tuple type to another. A statement sequence is as an arrow from one tuple type to another. A statement sequence is
translated to a composition of such arrows. translated to a composition of such arrows.
\begin{code} \begin{code}
dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id]
-> DsM (CoreExpr, IdSet) -> DsM (CoreExpr, IdSet)
dsCmdLStmt ids local_vars env_ids out_ids cmd dsCmdLStmt ids local_vars out_ids cmd env_ids
= dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
dsCmdStmt dsCmdStmt
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- list of vars in the output of this statement
-> Stmt Id -- statement to desugar
-> [Id] -- list of vars in the input to this statement -> [Id] -- list of vars in the input to this statement
-- This is typically fed back, -- This is typically fed back,
-- so don't pull on it too early -- so don't pull on it too early
-> [Id] -- list of vars in the output of this statement
-> Stmt Id -- statement to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- subset of local vars that occur free
-- A | xs1 |- c :: [] t -- A | xs1 |- c :: [] t
-- A | xs' |- do { ss } :: [] t' -- A | xs' |- do { ss } :: [] t'
...@@ -682,7 +697,7 @@ dsCmdStmt ...@@ -682,7 +697,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss -- arr snd >>> ss
dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
core_mux <- matchEnvStack env_ids [] core_mux <- matchEnvStack env_ids []
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
...@@ -711,7 +726,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do ...@@ -711,7 +726,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
-- It would be simpler and more consistent to do this using second, -- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first. -- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd
let let
pat_ty = hsLPatType pat pat_ty = hsLPatType pat
...@@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do ...@@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do
-- --
-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
-- build a new environment using the let bindings -- build a new environment using the let bindings
core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- match the old environment against the input -- match the old environment against the input
...@@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do ...@@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
(mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy out_ids) (mkBigCoreVarTupTy out_ids)
core_map, core_map,
exprFreeVars core_binds `intersectVarSet` local_vars) exprFreeIds core_binds `intersectVarSet` local_vars)
-- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ... -- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
-- A | xs' |- do { ss' } :: [] t -- A | xs' |- do { ss' } :: [] t
...@@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do ...@@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss' -- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
dsCmdStmt ids local_vars env_ids out_ids dsCmdStmt ids local_vars out_ids
(RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids (RecStmt { recS_stmts = stmts
, recS_rec_rets = rhss }) = do , recS_later_ids = later_ids, recS_rec_ids = rec_ids
, recS_later_rets = later_rets, recS_rec_rets = rec_rets })
env_ids = do
let let
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set env2_ids = varSetElems env2_id_set
...@@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids ...@@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids
--- loop (...) --- loop (...)
(core_loop, env1_id_set, env1_ids) (core_loop, env1_id_set, env1_ids)
<- dsRecCmd ids local_vars stmts later_ids rec_ids rhss <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
-- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
...@@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) ...@@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>> -- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
-- ss >>> -- ss >>>
-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>> -- arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>>
dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id] dsRecCmd
-> DsM (CoreExpr, VarSet, [Var]) :: DsCmdEnv -- arrow combinators
dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do -> IdSet -- set of local vars available to this statement
-> [LStmt Id] -- list of statements inside the RecCmd
-> [Id] -- list of vars defined here and used later
-> [HsExpr Id] -- expressions corresponding to later_ids
-> [Id] -- list of vars fed back through the loop
-> [HsExpr Id] -- expressions corresponding to rec_ids
-> DsM (CoreExpr, -- desugared statement
IdSet, -- subset of local vars that occur free
[Id]) -- same local vars as a list
dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
let let
later_id_set = mkVarSet later_ids
rec_id_set = mkVarSet rec_ids rec_id_set = mkVarSet rec_ids
out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set) local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
out_ty = mkBigCoreVarTupTy out_ids
local_vars' = local_vars `unionVarSet` rec_id_set
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
core_rhss <- mapM dsExpr rhss core_later_rets <- mapM dsExpr later_rets
core_rec_rets <- mapM dsExpr rec_rets
let let
later_tuple = mkBigCoreVarTup later_ids -- possibly polymorphic version of vars of later_ids and rec_ids
out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
out_ty = mkBigCoreVarTupTy out_ids
later_tuple = mkBigCoreTup core_later_rets
later_ty = mkBigCoreVarTupTy later_ids later_ty = mkBigCoreVarTupTy later_ids
rec_tuple = mkBigCoreTup core_rhss
rec_tuple = mkBigCoreTup core_rec_rets
rec_ty = mkBigCoreVarTupTy rec_ids rec_ty = mkBigCoreVarTupTy rec_ids
out_pair = mkCorePairExpr later_tuple rec_tuple out_pair = mkCorePairExpr later_tuple rec_tuple
out_pair_ty = mkCorePairTy later_ty rec_ty out_pair_ty = mkCorePairTy later_ty rec_ty
...@@ -905,34 +938,32 @@ dsfixCmdStmts ...@@ -905,34 +938,32 @@ dsfixCmdStmts
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- output vars of these statements -> [Id] -- output vars of these statements
-> [LStmt Id] -- statements to desugar -> [LStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free IdSet, -- subset of local vars that occur free
[Id]) -- input vars [Id]) -- same local vars as a list
dsfixCmdStmts ids local_vars out_ids stmts dsfixCmdStmts ids local_vars out_ids stmts
= fixDs (\ ~(_,_,env_ids) -> do = trimInput (dsCmdStmts ids local_vars out_ids stmts)
(core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
dsCmdStmts dsCmdStmts
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- list of vars in the input to these statements
-> [Id] -- output vars of these statements -> [Id] -- output vars of these statements
-> [LStmt Id] -- statements to desugar -> [LStmt Id] -- statements to desugar
-> [Id] -- list of vars in the input to these statements
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free IdSet) -- subset of local vars that occur free
dsCmdStmts ids local_vars env_ids out_ids [stmt] dsCmdStmts ids local_vars out_ids [stmt] env_ids
= dsCmdLStmt ids local_vars env_ids out_ids stmt = dsCmdLStmt ids local_vars out_ids stmt env_ids
dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
let let
bound_vars = mkVarSet (collectLStmtBinders stmt) bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars local_vars' = bound_vars `unionVarSet` local_vars
(core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
return (do_compose ids return (do_compose ids
(mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids') (mkBigCoreVarTupTy env_ids')
...@@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do ...@@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
core_stmts, core_stmts,
fv_stmt) fv_stmt)
dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []" dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
\end{code} \end{code}
...@@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id] ...@@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id]
add_ev_bndr (EvBind b _) bs | isId b = b:bs add_ev_bndr (EvBind b _) bs | isId b = b:bs
| otherwise = bs | otherwise = bs
-- A worry: what about coercion variable binders?? -- A worry: what about coercion variable binders??
collectLStmtsBinders :: [LStmt Id] -> [Id]
collectLStmtsBinders = concatMap collectLStmtBinders
collectLStmtBinders :: LStmt Id -> [Id]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: Stmt Id -> [Id]
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (ExprStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
\end{code} \end{code}
...@@ -758,21 +758,21 @@ dsDo stmts ...@@ -758,21 +758,21 @@ dsDo stmts
= ASSERT( length rec_ids > 0 ) = ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts) goL (new_bind_stmt : stmts)
where where
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
mfix_app bind_op mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
rec_tup_pats = map nlVarPat tup_ids rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats later_pats = rec_tup_pats
rets = map noLoc rec_rets rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty)) (mkFunTy tup_ty body_ty))
mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
ret_stmt = noLoc $ mkLastStmt ret_app ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo, -- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt, -- which ignores the return_op in the LastStmt,
......
...@@ -138,7 +138,7 @@ dsCImport :: Id ...@@ -138,7 +138,7 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc) -> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ _ = do dsCImport id co (CLabel cid) cconv _ _ = do
let ty = pFst $ coercionKind co let ty = pFst $ coercionKind co
fod = case tyConAppTyCon_maybe ty of fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon Just tycon
| tyConUnique tycon == funPtrTyConKey -> | tyConUnique tycon == funPtrTyConKey ->
IsFunction IsFunction
......
...@@ -65,11 +65,11 @@ Library ...@@ -65,11 +65,11 @@ Library
Build-Depends: directory >= 1 && < 1.2, Build-Depends: directory >= 1 && < 1.2,
process >= 1 && < 1.2, process >= 1 && < 1.2,
bytestring >= 0.9 && < 0.10, bytestring >= 0.9 && < 0.10,
old-time >= 1 && < 1.1, old-time >= 1 && < 1.2,
containers >= 0.1 && < 0.5, containers >= 0.1 && < 0.5,
array >= 0.1 && < 0.4 array >= 0.1 && < 0.5
Build-Depends: filepath >= 1 && < 1.3 Build-Depends: filepath >= 1 && < 1.4
Build-Depends: Cabal, hpc Build-Depends: Cabal, hpc
if os(windows) if os(windows)
Build-Depends: Win32 Build-Depends: Win32
......