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 (90)
Showing
with 265 additions and 195 deletions
......@@ -174,16 +174,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
GET_ARM_ISA()
test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
;;
alpha)
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)
alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
test -z "[$]2" || eval "[$]2=ArchUnknown"
;;
*)
......@@ -221,13 +212,16 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
freebsd)
test -z "[$]2" || eval "[$]2=OSFreeBSD"
;;
kfreebsdgnu)
test -z "[$]2" || eval "[$]2=OSKFreeBSD"
;;
openbsd)
test -z "[$]2" || eval "[$]2=OSOpenBSD"
;;
netbsd)
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"
;;
*)
......@@ -355,6 +349,7 @@ AC_DEFUN([FP_SETTINGS],
then
SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe'
SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand='$topdir/../mingw/bin/ar.exe'
SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe'
SettingsWindresCommand='$topdir/../mingw/bin/windres.exe'
......@@ -362,6 +357,7 @@ AC_DEFUN([FP_SETTINGS],
else
SettingsCCompilerCommand="$WhatGccIsCalled"
SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand="$ArCmd"
SettingsPerlCommand="$PerlCmd"
SettingsDllWrapCommand="/bin/false"
SettingsWindresCommand="/bin/false"
......@@ -369,6 +365,7 @@ AC_DEFUN([FP_SETTINGS],
fi
AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags)
AC_SUBST(SettingsArCommand)
AC_SUBST(SettingsPerlCommand)
AC_SUBST(SettingsDllWrapCommand)
AC_SUBST(SettingsWindresCommand)
......@@ -1894,6 +1891,12 @@ AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[
if test $GhcCanonVersion -ge 701
then
$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
$1=$3
fi
......@@ -1942,10 +1945,12 @@ AC_DEFUN([XCODE_VERSION],[
# Finds where gcc is
AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" &&
test "$XCodeVersion1" -ge 4
test "$XCodeVersion1" -eq 4 &&
test "$XCodeVersion2" -lt 2
then
# From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy
# backend (instead of the LLVM backend)
# In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
# 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])
else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
......
......@@ -430,6 +430,9 @@ instance Outputable Name where
instance OutputableBndr Name where
pprBndr _ name = pprName name
pprInfixOcc = pprInfixName
pprPrefixOcc = pprPrefixName
pprName :: Name -> SDoc
pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})
......
......@@ -273,6 +273,9 @@ instance OutputableBndr RdrName where
| isTvOcc (rdrNameOcc n) = char '@' <+> 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 r = showSDoc (ppr r)
......
......@@ -757,12 +757,14 @@ isStrangeTypeReg (CmmLocal _) = False
isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal CCCS = True
isStrangeTypeGlobal CurrentTSO = True
isStrangeTypeGlobal CurrentNursery = True
isStrangeTypeGlobal BaseReg = True
isStrangeTypeGlobal r = isFixedPtrGlobalReg r
strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
......@@ -793,6 +795,7 @@ pprGlobalReg gr = case gr of
SpLim -> ptext (sLit "SpLim")
Hp -> ptext (sLit "Hp")
HpLim -> ptext (sLit "HpLim")
CCCS -> ptext (sLit "CCCS")
CurrentTSO -> ptext (sLit "CurrentTSO")
CurrentNursery -> ptext (sLit "CurrentNursery")
HpAlloc -> ptext (sLit "HpAlloc")
......
......@@ -374,7 +374,7 @@ mkSlowEntryCode cl_info reg_args
stk_adj_pop = 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}
......
......@@ -271,7 +271,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
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_SP = closureField oFFSET_StgStack_sp
......
......@@ -178,8 +178,8 @@ emitCostCentreDecl cc = do
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
......
......@@ -963,7 +963,10 @@ infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI = fst . labelsFromCI
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 cl@(ClosureInfo { closureName = name,
......
......@@ -246,7 +246,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
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_SP = closureField oFFSET_StgStack_sp
......
......@@ -223,14 +223,14 @@ emitCostCentreDecl cc = do
-- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages.
-- Hence don't emit the package name in the module here.
; let lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
; let lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
......
......@@ -700,29 +700,6 @@ lintTyBndrKind tv =
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
-- Kind coercions are only reflexivity because they mean kind
-- instantiation. See Note [Kind coercions] in Coercion
......@@ -742,21 +719,6 @@ lintCoercion (Refl ty)
; return (ty, ty) }
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
-- kind coercions we have (one kind coercion for one kind
-- instantiation).
......@@ -876,7 +838,10 @@ lintType ty@(FunTy t1 t2)
= lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2]
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
| otherwise
= failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
......
......@@ -26,7 +26,7 @@ import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
import CoreSubst
import MkCore
import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
import Type
import Literal
import Coercion
......
......@@ -26,6 +26,7 @@ module CoreSyn (
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
......@@ -104,6 +105,7 @@ import Outputable
import Util
import Data.Data hiding (TyCon)
import Data.Int
import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
......@@ -992,6 +994,8 @@ instance Outputable b => Outputable (TaggedBndr b) where
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b
\end{code}
......@@ -1042,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b
mkWordLit w = Lit (mkMachWord 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#@.
-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
mkCharLit :: Char -> Expr b
......
......@@ -21,7 +21,8 @@ module CoreUtils (
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
exprIsBig, exprIsConLike,
rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size
......@@ -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
-- 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
-- There is one call at a non-Id binder type, in SetLevels
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
exprOkForSpeculation (Coercion _) = True
exprOkForSpeculation (Var v) = appOkForSpeculation v []
exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
expr_ok _ (Lit _) = True
expr_ok _ (Type _) = True
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
-- are meant to identify whether or not (and how often) the particular
-- source expression was evaluated at runtime.
exprOkForSpeculation (Tick tickish e)
expr_ok primop_ok (Tick tickish e)
| tickishCounts tickish = False
| otherwise = exprOkForSpeculation e
| otherwise = expr_ok primop_ok e
exprOkForSpeculation (Case e _ _ alts)
= exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
&& altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts]
expr_ok primop_ok (Case e _ _ alts)
= expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions]
&& all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
&& altsAreExhaustive alts -- Note [Exhaustive alts]
exprOkForSpeculation other_expr
expr_ok primop_ok other_expr
= case collectArgs other_expr of
(Var f, args) -> appOkForSpeculation f args
(Var f, args) -> app_ok primop_ok f args
_ -> False
-----------------------------
appOkForSpeculation :: Id -> [Expr b] -> Bool
appOkForSpeculation fun args
app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
app_ok primop_ok fun args
= case idDetails fun of
DFunId new_type -> not new_type
-- DFuns terminate, unless the dict is implemented
......@@ -794,7 +799,7 @@ appOkForSpeculation fun args
PrimOpId op
| isDivOp op -- Special case for dividing operations that fail
, [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
-- can get rid of a thunk in an inner looop
......@@ -802,14 +807,14 @@ appOkForSpeculation fun args
-> True
| otherwise
-> primOpOkForSpeculation op &&
all exprOkForSpeculation args
-- A bit conservative: we don't really need
-> primop_ok op -- A bit conservative: we don't really need
&& all (expr_ok primop_ok) args
-- to care about lazy arguments, but this is easy
_other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF
|| idArity fun > n_val_args -- Partial apps
|| (n_val_args ==0 &&
|| (n_val_args == 0 &&
isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
where
n_val_args = valArgCount args
......@@ -872,13 +877,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
The inner case is redundant, and should be nuked.
Note [exprOkForSpeculation: exhaustive alts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Exhaustive alts]
~~~~~~~~~~~~~~~~~~~~~~
We might have something like
case x of {
A -> ...
_ -> ...(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
the outer one (even if we know x is evaluated outside), because
then it would be non-exhaustive. See Trac #5453.
......
......@@ -21,6 +21,9 @@ module MkCore (
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS,
-- * Floats
FloatBind(..), wrapFloat,
-- * Constructing/deconstructing implicit parameter boxes
mkIPUnbox, mkIPBox,
......@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
\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}
......
......@@ -21,6 +21,7 @@ module PprCore (
import CoreSyn
import Literal( pprLiteral )
import Name( pprInfixName, pprPrefixName )
import Var
import Id
import IdInfo
......@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions.
\begin{code}
instance OutputableBndr Var where
pprBndr = pprCoreBinder
pprInfixOcc = pprInfixName . varName
pprPrefixOcc = pprPrefixName . varName
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
......
......@@ -21,7 +21,7 @@ import Match
import DsUtils
import DsMonad
import HsSyn hiding (collectPatBinders, collectPatsBinders )
import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
......@@ -265,21 +265,21 @@ Translation of command judgements of the form
A | xs |- c :: [ts] t
\begin{code}
dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id
dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id]
-> DsM (CoreExpr, IdSet)
dsLCmd ids local_vars env_ids stack res_ty cmd
= dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
dsLCmd ids local_vars stack res_ty cmd env_ids
= dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids
dsCmd :: DsCmdEnv -- arrow combinators
-> 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 -- return type of the command
-> 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
IdSet) -- set of local vars that occur free
IdSet) -- subset of local vars that occur free
-- A |- f :: a (t*ts) t'
-- A, xs |- arg :: t
......@@ -288,8 +288,9 @@ dsCmd :: DsCmdEnv -- arrow combinators
--
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do
dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
......@@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty
res_ty
core_make_arg
core_arrow,
exprFreeVars core_arg `intersectVarSet` local_vars)
exprFreeIds core_arg `intersectVarSet` local_vars)
-- A, xs |- f :: a (t*ts) t'
-- A, xs |- arg :: t
......@@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty
--
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do
dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
......@@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty
res_ty
core_make_pair
(do_app ids arg_ty res_ty),
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
(exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)
`intersectVarSet` local_vars)
-- A | ys |- c :: [t:ts] t'
......@@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty
--
-- ---> 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
let
arg_ty = exprType core_arg
......@@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
res_ty
core_map
core_cmd,
(exprFreeVars core_arg `intersectVarSet` local_vars)
`unionVarSet` free_vars)
free_vars `unionVarSet`
(exprFreeIds core_arg `intersectVarSet` local_vars))
-- A | ys |- c :: [ts] t'
-- -----------------------------------------------
......@@ -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
dsCmd ids local_vars env_ids stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do
dsCmd ids local_vars stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
env_ids = do
let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
local_vars' = pat_vars `unionVarSet` local_vars
stack' = drop (length pats) stack
(core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body
stack_ids <- mapM newSysLocalDs stack
......@@ -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,
free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
= dsLCmd ids local_vars env_ids stack res_ty cmd
dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
= dsLCmd ids local_vars stack res_ty cmd env_ids
-- A, xs |- e :: Bool
-- A | xs1 |- c1 :: [ts] t
......@@ -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)) >>>
-- 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_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
......@@ -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
else_ty = envStackType else_ids stack
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_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)
......@@ -472,7 +476,8 @@ case bodies, containing the following fields:
bodies with |||.
\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
-- 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_
leaves = concatMap leavesMatch matches
make_branch (leaf, bound_vars) = do
(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],
envStackType leaf_ids stack,
core_leaf)
......@@ -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_matches <- matchEnvStack env_ids stack_ids core_body
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
-- ----------------------------------
......@@ -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
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
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
stack_ids <- mapM newSysLocalDs stack
......@@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
res_ty
core_map
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 _)
= dsCmdDo ids local_vars env_ids res_ty stmts
dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
= 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 | xs |- ci :: [tsi] ti
-- -----------------------------------
-- 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
core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
return (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets)
dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do
(expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr
dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
(expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
return (Tick tickish expr1, id_set)
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
......@@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
dsTrimCmdArg
:: IdSet -- set of local vars available 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
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
meth_ids <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
......@@ -603,11 +607,24 @@ dsfixCmd
-> Type -- return type of the command
-> LHsCmd Id -- command to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free
[Id]) -- set as a list, fed back
IdSet, -- subset of local vars that occur free
[Id]) -- the same local vars as a list, fed back
dsfixCmd ids local_vars stack cmd_ty cmd
= fixDs (\ ~(_,_,env_ids') -> do
(core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd
= trimInput (dsLCmd ids local_vars 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))
\end{code}
......@@ -620,31 +637,29 @@ Translation of command judgements of the form
dsCmdDo :: DsCmdEnv -- arrow combinators
-> 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
-- This is typically fed back,
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> 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 |- do { c } :: [] t
dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids
= 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
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
local_vars' = bound_vars `unionVarSet` local_vars
(core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
return (do_compose ids
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
......@@ -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
translated to a composition of such arrows.
\begin{code}
dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id
dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id]
-> DsM (CoreExpr, IdSet)
dsCmdLStmt ids local_vars env_ids out_ids cmd
= dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
dsCmdLStmt ids local_vars out_ids cmd env_ids
= dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
dsCmdStmt
:: DsCmdEnv -- arrow combinators
-> 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
-- This is typically fed back,
-- 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
IdSet) -- set of local vars that occur free
IdSet) -- subset of local vars that occur free
-- A | xs1 |- c :: [] t
-- A | xs' |- do { ss } :: [] t'
......@@ -682,7 +697,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- 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_mux <- matchEnvStack env_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
-- It would be simpler and more consistent to do this using second,
-- 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
let
pat_ty = hsLPatType pat
......@@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do
--
-- ---> 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
core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- match the old environment against the input
......@@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy out_ids)
core_map,
exprFreeVars core_binds `intersectVarSet` local_vars)
exprFreeIds core_binds `intersectVarSet` local_vars)
-- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
-- A | xs' |- do { ss' } :: [] t
......@@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
dsCmdStmt ids local_vars env_ids out_ids
(RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
, recS_rec_rets = rhss }) = do
dsCmdStmt ids local_vars out_ids
(RecStmt { recS_stmts = stmts
, recS_later_ids = later_ids, recS_rec_ids = rec_ids
, recS_later_rets = later_rets, recS_rec_rets = rec_rets })
env_ids = do
let
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
......@@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids
--- loop (...)
(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))
......@@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
-- ss >>>
-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id]
-> DsM (CoreExpr, VarSet, [Var])
dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
-- arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>>
dsRecCmd
:: DsCmdEnv -- arrow combinators
-> 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
later_id_set = mkVarSet later_ids
rec_id_set = mkVarSet rec_ids
out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
out_ty = mkBigCoreVarTupTy out_ids
local_vars' = local_vars `unionVarSet` rec_id_set
local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
-- 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
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
rec_tuple = mkBigCoreTup core_rhss
rec_tuple = mkBigCoreTup core_rec_rets
rec_ty = mkBigCoreVarTupTy rec_ids
out_pair = mkCorePairExpr later_tuple rec_tuple
out_pair_ty = mkCorePairTy later_ty rec_ty
......@@ -905,34 +938,32 @@ dsfixCmdStmts
:: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement
-> [Id] -- output vars of these statements
-> [LStmt Id] -- statements to desugar
-> [LStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet, -- set of local vars that occur free
[Id]) -- input vars
IdSet, -- subset of local vars that occur free
[Id]) -- same local vars as a list
dsfixCmdStmts ids local_vars out_ids stmts
= fixDs (\ ~(_,_,env_ids) -> do
(core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
= trimInput (dsCmdStmts ids local_vars out_ids stmts)
dsCmdStmts
:: DsCmdEnv -- arrow combinators
-> 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
-> [LStmt Id] -- statements to desugar
-> [LStmt Id] -- statements to desugar
-> [Id] -- list of vars in the input to these statements
-> 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]
= dsCmdLStmt ids local_vars env_ids out_ids stmt
dsCmdStmts ids local_vars out_ids [stmt] env_ids
= 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
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_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
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
......@@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
core_stmts,
fv_stmt)
dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []"
dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
\end{code}
......@@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id]
add_ev_bndr (EvBind b _) bs | isId b = b:bs
| otherwise = bs
-- 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}
......@@ -758,21 +758,21 @@ dsDo stmts
= ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts)
where
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
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
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(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
ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt,
......
......@@ -138,7 +138,7 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ _ = do
let ty = pFst $ coercionKind co
fod = case tyConAppTyCon_maybe ty of
fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
IsFunction
......
......@@ -65,11 +65,11 @@ Library
Build-Depends: directory >= 1 && < 1.2,
process >= 1 && < 1.2,
bytestring >= 0.9 && < 0.10,
old-time >= 1 && < 1.1,
old-time >= 1 && < 1.2,
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
if os(windows)
Build-Depends: Win32
......