From: Ian Lynagh Date: Sun, 8 May 2011 15:13:33 +0000 (+0100) Subject: Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d45197aabb22178066a8ec50d29331786a0c518c;hp=daead6bf93cc751417461507048db9b1aa8b669a Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core --- diff --git a/.gitignore b/.gitignore index 79629da..3e2e7f4 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ *.BAK *.orig *.prof +*.rej *.hi *.hi-boot @@ -22,6 +23,7 @@ *.o.cmd *.depend* log +tags autom4te.cache config.log @@ -29,6 +31,12 @@ config.status configure # ----------------------------------------------------------------------------- +# Ignore any overlapped darcs repos and back up files + +*-darcs-backup* +_darcs/ + +# ----------------------------------------------------------------------------- # sub-repositories /ghc-tarballs/ @@ -78,9 +86,7 @@ configure /bindist-list /bindistprep/ /bindisttest/HelloWorld -/bindisttest/a/ -/bindisttest/install\ dir/ -/bindisttest/output +/bindisttest/ /ch01.html /ch02.html /compiler/cmm/CmmLex.hs @@ -118,8 +124,12 @@ configure /docs/users_guide/users_guide.xml /docs/users_guide/users_guide/ /docs/users_guide/what_glasgow_exts_does.gen.xml +/driver/ghc/dist/ +/driver/haddock/dist/ /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace +/driver/ghci/dist/ +/driver/ghci/ghci.res /driver/mangler/dist/ghc-asm /driver/mangler/dist/ghc-asm.prl /driver/package.conf @@ -127,7 +137,7 @@ configure /driver/split/dist/ghc-split /driver/split/dist/ghc-split.prl /driver/stamp-pkg-conf-rts -/extra-gcc-opts +/settings /ghc.spec /ghc/ghc-bin.cabal /ghc/stage1/ @@ -149,6 +159,8 @@ configure /libffi/package.conf.inplace /libffi/package.conf.inplace.raw /libffi/stamp* +/libffi/package.conf.install +/libffi/package.conf.install.raw /libraries/bin-package-db/GNUmakefile /libraries/bin-package-db/ghc.mk /libraries/bootstrapping.conf @@ -184,6 +196,8 @@ configure /rts/package.conf.inplace.raw /rts/sm/Evac_thr.c /rts/sm/Scav_thr.c +/rts/package.conf.install +/rts/package.conf.install.raw /stage3.package.conf /testsuite_summary.txt /testlog @@ -217,3 +231,4 @@ configure /utils/runghc/runhaskell /utils/runstdtest/runstdtest /utils/unlit/unlit + diff --git a/HACKING b/HACKING index be9eec2..8ceff18 100644 --- a/HACKING +++ b/HACKING @@ -21,10 +21,15 @@ The GHC Developer's Wiki Quick Start for developers http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking - + This section on the wiki will get you up and running with a - serviceable build tree in no time: - + serviceable build tree in no time. + + Don't skip this! By default, GHC builds with all optimizations + and profiling; most hackers will want a quicker build, so creating + a mk/build.mk file and knowing how to rebuild only parts of GHC is + very important. + This is part of the "Building GHC" section of the wiki, which has more detailed information on GHC's build system should you need it. diff --git a/MAKEHELP b/MAKEHELP index 85497e9..c14767f 100644 --- a/MAKEHELP +++ b/MAKEHELP @@ -25,12 +25,6 @@ Common commands: Shows the targets available in - make html - make pdf - make ps - - Make documentation - make install Installs GHC, libraries and tools under $(prefix) diff --git a/Makefile b/Makefile index 1a23e2e..0929f28 100644 --- a/Makefile +++ b/Makefile @@ -45,7 +45,7 @@ endif include mk/custom-settings.mk # No need to update makefiles for these targets: -REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS)) +REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS)) # configure touches certain files even if they haven't changed. This # can mean a lot of unnecessary recompilation after a re-configure, so @@ -102,12 +102,6 @@ framework-pkg: $(MAKE) -C distrib/MacOS $@ endif -# install-docs is a historical target that isn't supported in GHC 6.12. See #3662. -install-docs: - @echo "The install-docs target is not supported in GHC 6.12.1 and later." - @echo "'make install' now installs everything, including documentation." - @exit 1 - # If the user says 'make A B', then we don't want to invoke two # instances of the rule above in parallel: .NOTPARALLEL: diff --git a/README b/README index b041773..c7d390d 100644 --- a/README +++ b/README @@ -34,7 +34,7 @@ There are two ways to get a source tree: $ git clone http://darcs.haskell.org/ghc.git/ - Then run the darcs-all script in that repository + Then run the sync-all script in that repository to get the other repositories: $ cd ghc @@ -54,7 +54,7 @@ NB. you need GHC installed in order to build GHC, because the compiler is itself written in Haskell. For instructions on how to port GHC to a new platform, see the Building Guide. -If you're building from darcs sources (as opposed to a source +If you're building from git sources (as opposed to a source distribution) then you also need to install Happy [4] and Alex [5]. For building library documentation, you'll need Haddock [6]. To build @@ -69,7 +69,7 @@ Quick start: the following gives you a default build: $ make install The "perl boot" step is only necessary if this is a tree checked out -from darcs. For source distributions downloaded from GHC's web site, +from git. For source distributions downloaded from GHC's web site, this step has already been performed. These steps give you the default build, which includes everything diff --git a/aclocal.m4 b/aclocal.m4 index 691fd45..c7aba3e 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -94,14 +94,10 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], AC_MSG_CHECKING([Setting up $2, $3, $4 and $5]) case $$1 in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - $2="$$2 -march=i686 -m32" - $3="$$3 -march=i686 -m32" + $2="$$2 -m32" + $3="$$3 -m32" $4="$$4 -arch i386" - $5="$$5 -march=i686 -m32" + $5="$$5 -m32" ;; x86_64-apple-darwin) $2="$$2 -m64" @@ -109,6 +105,21 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], $4="$$4 -arch x86_64" $5="$$5 -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + $2="$$2 -w -mieee -D_REENTRANT" + $3="$$3 -w -mieee -D_REENTRANT" + $5="$$5 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + $2="$$2 -D_HPUX_SOURCE" + $3="$$3 -D_HPUX_SOURCE" + $5="$$5 -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -185,8 +196,8 @@ AC_DEFUN([FP_EVAL_STDERR], # -------------------- # XXX # -# $1 = the command to look for -# $2 = the variable to set +# $1 = the variable to set +# $2 = the command to look for # AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG], [ @@ -484,6 +495,31 @@ AC_SUBST([LdXFlag]) ])# FP_PROG_LD_X +# FP_PROG_LD_BUILD_ID +# ------------ + +# Sets the output variable LdHasBuildId to YES if ld supports +# --build-id, or NO otherwise. +AC_DEFUN([FP_PROG_LD_BUILD_ID], +[ +AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id], +[echo 'foo() {}' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi +AC_SUBST([LdHasBuildId]) +])# FP_PROG_LD_BUILD_ID + + # FP_PROG_LD_IS_GNU # ----------------- # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is @@ -599,7 +635,7 @@ AC_SUBST([ArArgs], ["$fp_prog_ar_args"]) # FP_PROG_AR_NEEDS_RANLIB # ----------------------- # Sets the output variable RANLIB to "ranlib" if it is needed and found, -# to ":" otherwise. +# to "true" otherwise. AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB], [AC_REQUIRE([FP_PROG_AR_IS_GNU]) AC_REQUIRE([FP_PROG_AR_ARGS]) @@ -619,38 +655,12 @@ fi]) if test $fp_cv_prog_ar_needs_ranlib = yes; then AC_PROG_RANLIB else - RANLIB=":" + RANLIB="true" AC_SUBST([RANLIB]) fi ])# FP_PROG_AR_NEEDS_RANLIB -# FP_PROG_AR_SUPPORTS_INPUT -# ------------------------- -# Sets the output variable ArSupportsInput to "-input" or "", depending on -# whether ar supports -input flag is supported or not. -AC_DEFUN([FP_PROG_AR_SUPPORTS_INPUT], -[AC_REQUIRE([FP_PROG_AR_IS_GNU]) -AC_REQUIRE([FP_PROG_AR_ARGS]) -AC_CACHE_CHECK([whether $fp_prog_ar_raw supports -input], [fp_cv_prog_ar_supports_input], -[fp_cv_prog_ar_supports_input=no -if test $fp_prog_ar_is_gnu = no; then - rm -f conftest* - touch conftest.lst - if FP_EVAL_STDERR(["$fp_prog_ar_raw" $fp_prog_ar_args conftest.a -input conftest.lst]) >/dev/null; then - test -s conftest.err || fp_cv_prog_ar_supports_input=yes - fi - rm -f conftest* -fi]) -if test $fp_cv_prog_ar_supports_input = yes; then - ArSupportsInput="-input" -else - ArSupportsInput="" -fi -AC_SUBST([ArSupportsInput]) -])# FP_PROG_AR_SUPPORTS_INPUT - - dnl dnl AC_SHEBANG_PERL - can we she-bang perl? dnl @@ -670,38 +680,30 @@ rm -f conftest ])]) -# FP_HAVE_GCC +# FP_GCC_VERSION # ----------- # Extra testing of the result AC_PROG_CC, testing the gcc version no. Sets the -# output variables HaveGcc and GccVersion. -AC_DEFUN([FP_HAVE_GCC], +# output variable GccVersion. +AC_DEFUN([FP_GCC_VERSION], [AC_REQUIRE([AC_PROG_CC]) -if test -z "$GCC"; then - fp_have_gcc=NO -else - fp_have_gcc=YES -fi -if test "$fp_have_gcc" = "NO" -a -d $srcdir/ghc; then +if test -z "$GCC" +then AC_MSG_ERROR([gcc is required]) fi GccLT34= AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], -[if test "$fp_have_gcc" = "YES"; then - fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], - [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) - # See #2770: gcc 2.95 doesn't work any more, apparently. There probably - # isn't a very good reason for that, but for now just make configure - # fail. - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) - else - fp_cv_gcc_version="not-installed" - fi +[ + fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], + [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) + # See #2770: gcc 2.95 doesn't work any more, apparently. There probably + # isn't a very good reason for that, but for now just make configure + # fail. + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) ]) -AC_SUBST([HaveGcc], [$fp_have_gcc]) AC_SUBST([GccVersion], [$fp_cv_gcc_version]) AC_SUBST(GccLT34) -])# FP_HAVE_GCC +])# FP_GCC_VERSION dnl Small feature test for perl version. Assumes PerlCmd dnl contains path to perl binary. @@ -1029,18 +1031,6 @@ AC_SUBST([FopCmd]) ])# FP_PROG_FOP -# FP_PROG_HSTAGS -# ---------------- -# Sets the output variable HstagsCmd to the full Haskell tags program path. -# HstagsCmd is empty if no such program could be found. -AC_DEFUN([FP_PROG_HSTAGS], -[AC_PATH_PROG([HstagsCmd], [hasktags]) -if test -z "$HstagsCmd"; then - AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags]) -fi -])# FP_PROG_HSTAGS - - # FP_PROG_GHC_PKG # ---------------- # Try to find a ghc-pkg matching the ghc mentioned in the environment variable @@ -1069,43 +1059,16 @@ AC_SUBST([GhcPkgCmd]) # Determine which extra flags we need to pass gcc when we invoke it # to compile .hc code. # -# Some OSs (Mandrake Linux, in particular) configure GCC with -# -momit-leaf-frame-pointer on by default. If this is the case, we -# need to turn it off for mangling to work. The test is currently a -# bit crude, using only the version number of gcc. -# # -fwrapv is needed for gcc to emit well-behaved code in the presence of # integer wrap around. (Trac #952) # -# -fno-unit-at-a-time or -fno-toplevel-reoder is necessary to avoid gcc -# reordering things in the module and confusing the manger and/or splitter. -# (eg. Trac #1427) -# AC_DEFUN([FP_GCC_EXTRA_FLAGS], -[AC_REQUIRE([FP_HAVE_GCC]) +[AC_REQUIRE([FP_GCC_VERSION]) AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts], [fp_cv_gcc_extra_opts= FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"], []) - case $TargetPlatform in - i386-*|x86_64-*) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer"], - []) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], - [FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time"] - )], - []) - ;; - sparc-*-solaris2) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - []) - ;; - esac ]) AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts) ]) @@ -1122,7 +1085,7 @@ if test "$RELEASE" = "NO"; then AC_MSG_RESULT(given $PACKAGE_VERSION) elif test -d .git; then changequote(, )dnl - ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"` + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else changequote([, ])dnl AC_MSG_ERROR([failed to detect version date: check that git is in your path]) @@ -1534,6 +1497,21 @@ case "$1" in esac ]) +# BOOTSTRAPPING_GHC_INFO_FIELD +# -------------------------------- +# If the bootstrapping compiler is >= 7.1, then set the variable +# $1 to the value of the ghc --info field $2. Otherwise, set it to +# $3. +AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[ +if test $GhcCanonVersion -ge 701 +then + $1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'` +else + $1=$3 +fi +AC_SUBST($1) +]) + # LIBRARY_VERSION(lib) # -------------------------------- # Gets the version number of a library. diff --git a/boot b/boot index ae57381..0b67b17 100755 --- a/boot +++ b/boot @@ -3,10 +3,18 @@ use strict; use Cwd; +use File::Path 'rmtree'; +use File::Basename; my %required_tag; +my $validate; +my $curdir; $required_tag{"-"} = 1; +$validate = 0; + +$curdir = &cwd() + or die "Can't find current directory: $!"; while ($#ARGV ne -1) { my $arg = shift @ARGV; @@ -14,59 +22,212 @@ while ($#ARGV ne -1) { if ($arg =~ /^--required-tag=(.*)/) { $required_tag{$1} = 1; } + elsif ($arg =~ /^--validate$/) { + $validate = 1; + } else { die "Bad arg: $arg"; } } +sub sanity_check_line_endings { + local $/ = undef; + open FILE, "packages" or die "Couldn't open file: $!"; + binmode FILE; + my $string = ; + close FILE; + + if ($string =~ /\r/) { + print STDERR <) { + if (/^#/) { + # Comment; do nothing + } + elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) { + $dir = $1; + $tag = $2; + + # If $tag is not "-" then it is an optional repository, so its + # absence isn't an error. + if (defined($required_tag{$tag})) { + # We would like to just check for a .git directory here, + # but in an lndir tree we avoid making .git directories, + # so it doesn't exist. We therefore require that every repo + # has a LICENSE file instead. + if (! -f "$dir/LICENSE") { + print STDERR "Error: $dir/LICENSE doesn't exist.\n"; + die "Maybe you haven't done './sync-all get'?"; + } + } + } + else { + die "Bad line in packages file: $_"; + } + } + close PACKAGES; +} + # Create libraries/*/{ghc.mk,GNUmakefile} -system("/usr/bin/perl", "-w", "boot-pkgs") == 0 - or die "Running boot-pkgs failed: $?"; +sub boot_pkgs { + my @library_dirs = (); + my @tarballs = glob("libraries/tarballs/*"); -my $tag; -my $dir; -my $curdir; + my $tarball; + my $package; + my $stamp; -$curdir = &cwd() - or die "Can't find current directory: $!"; + for $tarball (@tarballs) { + $package = $tarball; + $package =~ s#^libraries/tarballs/##; + $package =~ s/-[0-9.]*(-snapshot)?\.tar\.gz$//; -# Check that we have all boot packages. -open PACKAGES, "< packages"; -while () { - if (/^#/) { - # Comment; do nothing + # Sanity check, so we don't rmtree the wrong thing below + if (($package eq "") || ($package =~ m#[/.\\]#)) { + die "Bad package name: $package"; + } + + if (-d "libraries/$package/_darcs") { + print "Ignoring libraries/$package as it looks like a darcs checkout\n" + } + elsif (-d "libraries/$package/.git") { + print "Ignoring libraries/$package as it looks like a git checkout\n" + } + else { + if (! -d "libraries/stamp") { + mkdir "libraries/stamp"; + } + $stamp = "libraries/stamp/$package"; + if ((! -d "libraries/$package") || (! -f "$stamp") + || ((-M "libraries/stamp/$package") > (-M $tarball))) { + print "Unpacking $package\n"; + if (-d "libraries/$package") { + &rmtree("libraries/$package") + or die "Can't remove libraries/$package: $!"; + } + mkdir "libraries/$package" + or die "Can't create libraries/$package: $!"; + system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0 + or die "Failed to unpack $package"; + open STAMP, "> $stamp" + or die "Failed to open stamp file: $!"; + close STAMP + or die "Failed to close stamp file: $!"; + } + } } - elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) { - $dir = $1; - $tag = $2; - - # If $tag is not "-" then it is an optional repository, so its - # absence isn't an error. - if (defined($required_tag{$tag})) { - # We would like to just check for a .git directory here, - # but in an lndir tree we avoid making .git directories, - # so it doesn't exist. We therefore require that every repo - # has a LICENSE file instead. - if (! -f "$dir/LICENSE") { - print STDERR "Error: $dir/LICENSE doesn't exist.\n"; - die "Maybe you haven't done './sync-all get'?"; + + for $package (glob "libraries/*/") { + $package =~ s/\/$//; + my $pkgs = "$package/ghc-packages"; + if (-f $pkgs) { + open PKGS, "< $pkgs" + or die "Failed to open $pkgs: $!"; + while () { + chomp; + s/\r//g; + if (/.+/) { + push @library_dirs, "$package/$_"; + } } } + else { + push @library_dirs, $package; + } } - else { - die "Bad line in packages file: $_"; + + for $package (@library_dirs) { + my $dir = &basename($package); + my @cabals = glob("$package/*.cabal"); + if ($#cabals > 0) { + die "Too many .cabal file in $package\n"; + } + if ($#cabals eq 0) { + my $cabal = $cabals[0]; + my $pkg; + my $top; + if (-f $cabal) { + $pkg = $cabal; + $pkg =~ s#.*/##; + $pkg =~ s/\.cabal$//; + $top = $package; + $top =~ s#[^/]+#..#g; + $dir = $package; + $dir =~ s#^libraries/##g; + + print "Creating $package/ghc.mk\n"; + open GHCMK, "> $package/ghc.mk" + or die "Opening $package/ghc.mk failed: $!"; + print GHCMK "${package}_PACKAGE = ${pkg}\n"; + print GHCMK "${package}_dist-install_GROUP = libraries\n"; + print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n"; + close GHCMK + or die "Closing $package/ghc.mk failed: $!"; + + print "Creating $package/GNUmakefile\n"; + open GNUMAKEFILE, "> $package/GNUmakefile" + or die "Opening $package/GNUmakefile failed: $!"; + print GNUMAKEFILE "dir = ${package}\n"; + print GNUMAKEFILE "TOP = ${top}\n"; + print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n"; + print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n"; + close GNUMAKEFILE + or die "Closing $package/GNUmakefile failed: $!"; + } + } } } -close PACKAGES; # autoreconf everything that needs it. -foreach $dir (".", glob("libraries/*/")) { - if (-f "$dir/configure.ac") { - print "Booting $dir\n"; - chdir $dir or die "can't change to $dir: $!"; - system("autoreconf") == 0 - or die "Running autoreconf failed with exitcode $?"; - chdir $curdir or die "can't change to $curdir: $!"; +sub autoreconf { + my $dir; + + foreach $dir (".", glob("libraries/*/")) { + if (-f "$dir/configure.ac") { + print "Booting $dir\n"; + chdir $dir or die "can't change to $dir: $!"; + system("autoreconf") == 0 + or die "Running autoreconf failed with exitcode $?"; + chdir $curdir or die "can't change to $curdir: $!"; + } } } +sub checkBuildMk { + if ($validate eq 0 && ! -f "mk/build.mk") { + print < (-M $tarball))) { - print "Unpacking $package\n"; - if (-d "libraries/$package") { - &rmtree("libraries/$package") - or die "Can't remove libraries/$package: $!"; - } - mkdir "libraries/$package" - or die "Can't create libraries/$package: $!"; - system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0 - or die "Failed to unpack $package"; - open STAMP, "> $stamp" - or die "Failed to open stamp file: $!"; - close STAMP - or die "Failed to close stamp file: $!"; - } - } -} - -for $package (glob "libraries/*/") { - $package =~ s/\/$//; - my $pkgs = "$package/ghc-packages"; - if (-f $pkgs) { - open PKGS, "< $pkgs" - or die "Failed to open $pkgs: $!"; - while () { - chomp; - if (/.+/) { - push @library_dirs, "$package/$_"; - } - } - } - else { - push @library_dirs, $package; - } -} - -for $package (@library_dirs) { - my $dir = &basename($package); - my @cabals = glob("$package/*.cabal"); - if ($#cabals > 0) { - die "Too many .cabal file in $package\n"; - } - if ($#cabals eq 0) { - my $cabal = $cabals[0]; - my $pkg; - my $top; - if (-f $cabal) { - $pkg = $cabal; - $pkg =~ s#.*/##; - $pkg =~ s/\.cabal$//; - $top = $package; - $top =~ s#[^/]+#..#g; - $dir = $package; - $dir =~ s#^libraries/##g; - - print "Creating $package/ghc.mk\n"; - open GHCMK, "> $package/ghc.mk" - or die "Opening $package/ghc.mk failed: $!"; - print GHCMK "${package}_PACKAGE = ${pkg}\n"; - print GHCMK "${package}_dist-install_GROUP = libraries\n"; - print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n"; - close GHCMK - or die "Closing $package/ghc.mk failed: $!"; - - print "Creating $package/GNUmakefile\n"; - open GNUMAKEFILE, "> $package/GNUmakefile" - or die "Opening $package/GNUmakefile failed: $!"; - print GNUMAKEFILE "dir = ${package}\n"; - print GNUMAKEFILE "TOP = ${top}\n"; - print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n"; - print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n"; - close GNUMAKEFILE - or die "Closing $package/GNUmakefile failed: $!"; - } - } -} - diff --git a/compiler/Makefile.local b/compiler/Makefile.local deleted file mode 100644 index 1d53451..0000000 --- a/compiler/Makefile.local +++ /dev/null @@ -1,75 +0,0 @@ -# Local GHC-build-tree customization for Cabal makefiles. We want to build -# libraries using flags that the user has put in build.mk/validate.mk and -# appropriate flags for Mac OS X deployment targets. - -# Careful here: including boilerplate.mk breaks things, because paths.mk and -# opts.mk overrides some of the variable settings in the Cabal Makefile, so -# we just include config.mk and custom-settings.mk. -TOP=.. -SAVE_GHC := $(GHC) -SAVE_AR := $(AR) -SAVE_LD := $(LD) -include $(TOP)/mk/config.mk -include $(TOP)/mk/custom-settings.mk -GHC := $(SAVE_GHC) -AR := $(SAVE_AR) -LD := $(SAVE_LD) - -# Now add flags from the GHC build system to the Cabal build: -GHC_CC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) -GHC_OPTS += $(SRC_HC_OPTS) -GHC_OPTS += $(GhcHcOpts) -GHC_OPTS += $(GhcStage$(stage)HcOpts) -GHC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS)) -LIB_LD_OPTS += $(addprefix -optl, $(MACOSX_DEPLOYMENT_LD_OPTS)) - -# XXX These didn't work in the old build system, according to the -# comment at least. We should actually handle them properly at some -# point: - -# Some .hs files #include other source files, but since ghc -M doesn't spit out -# these dependencies we have to include them manually. - -# We don't add dependencies on HsVersions.h, ghcautoconf.h, or ghc_boot_platform.h, -# because then modifying one of these files would force recompilation of everything, -# which is probably not what you want. However, it does mean you have to be -# careful to recompile stuff you need if you reconfigure or change HsVersions.h. - -# Aargh, these don't work properly anyway, because GHC's recompilation checker -# just reports "compilation NOT required". Do we have to add -fforce-recomp for each -# of these .hs files? I haven't done anything about this yet. - -# $(odir)/codeGen/Bitmap.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/CgCallConv.$(way_)o : ../includes/StgFun.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/Constants.h -# $(odir)/codeGen/CgProf.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/codeGen/CgTicky.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/codeGen/ClosureInfo.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/SMRep.$(way_)o : ../includes/MachDeps.h -# $(odir)/codeGen/SMRep.$(way_)o : ../includes/ClosureTypes.h -# $(odir)/ghci/ByteCodeAsm.$(way_)o : ../includes/Bytecodes.h -# $(odir)/ghci/ByteCodeFFI.$(way_)o : nativeGen/NCG.h -# $(odir)/ghci/ByteCodeInstr.$(way_)o : ../includes/MachDeps.h -# $(odir)/ghci/ByteCodeItbls.$(way_)o : ../includes/ClosureTypes.h -# $(odir)/ghci/ByteCodeItbls.$(way_)o : nativeGen/NCG.h -# $(odir)/main/Constants.$(way_)o : ../includes/MachRegs.h -# $(odir)/main/Constants.$(way_)o : ../includes/Constants.h -# $(odir)/main/Constants.$(way_)o : ../includes/MachDeps.h -# $(odir)/main/Constants.$(way_)o : ../includes/DerivedConstants.h -# $(odir)/main/Constants.$(way_)o : ../includes/GHCConstants.h -# $(odir)/nativeGen/AsmCodeGen.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachCodeGen.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachCodeGen.$(way_)o : ../includes/MachDeps.h -# $(odir)/nativeGen/MachInstrs.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachRegs.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/MachRegs.$(way_)o : ../includes/MachRegs.h -# $(odir)/nativeGen/PositionIndependentCode.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/PprMach.$(way_)o : nativeGen/NCG.h -# $(odir)/nativeGen/RegAllocInfo.$(way_)o : nativeGen/NCG.h -# $(odir)/typecheck/TcForeign.$(way_)o : nativeGen/NCG.h -# $(odir)/utils/Binary.$(way_)o : ../includes/MachDeps.h -# $(odir)/utils/FastMutInt.$(way_)o : ../includes/MachDeps.h -# $(PRIMOP_BITS) is defined in Makefile -# $(odir)/prelude/PrimOp.o: $(PRIMOP_BITS) - diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 108bd8d..89b3edd 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -154,6 +154,7 @@ addBootSuffixLocn locn \begin{code} -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString + deriving Typeable instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm @@ -174,8 +175,6 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) -INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName") - instance Data ModuleName where -- don't traverse? toConstr _ = abstractConstr "ModuleName" @@ -223,7 +222,7 @@ data Module = Module { modulePackageId :: !PackageId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) instance Uniquable Module where getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) @@ -235,8 +234,6 @@ instance Binary Module where put_ bh (Module p n) = put_ bh p >> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) -INSTANCE_TYPEABLE0(Module,moduleTc,"Module") - instance Data Module where -- don't traverse? toConstr _ = abstractConstr "Module" @@ -280,7 +277,7 @@ pprPackagePrefix p mod = getPprStyle doc \begin{code} -- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq ) +newtype PackageId = PId FastString deriving( Eq, Typeable ) -- here to avoid module loops with PackageConfig instance Uniquable PackageId where @@ -291,8 +288,6 @@ instance Uniquable PackageId where instance Ord PackageId where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId") - instance Data PackageId where -- don't traverse? toConstr _ = abstractConstr "PackageId" diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 70cf298..f2ae963 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -106,6 +106,7 @@ data Name = Name { --(note later when changing Int# -> FastInt: is that still true about UNPACK?) n_loc :: !SrcSpan -- Definition site } + deriving Typeable -- NOTE: we make the n_loc field strict to eliminate some potential -- (and real!) space leaks, due to the fact that we don't look at @@ -363,8 +364,6 @@ instance Uniquable Name where instance NamedThing Name where getName n = n -INSTANCE_TYPEABLE0(Name,nameTc,"Name") - instance Data Name where -- don't traverse? toConstr _ = abstractConstr "Name" diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index e2acaf7..bef9e92 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -48,7 +48,12 @@ import Data.Data \begin{code} type NameSet = UniqSet Name -INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet") +-- TODO: These Data/Typeable instances look very dubious. Surely either +-- UniqFM should have the instances, or this should be a newtype? + +nameSetTc :: TyCon +nameSetTc = mkTyCon "NameSet" +instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] } instance Data NameSet where gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly @@ -176,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus get (Just d1, _u1) d2 = d1 `unionNameSets` d2 allUses :: DefUses -> Uses --- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned allUses dus = foldr get emptyNameSet dus where get (_d1, u1) u2 = u1 `unionNameSets` u2 @@ -184,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus duUses :: DefUses -> Uses -- ^ Collect all 'Uses', regardless of whether the group is itself used, -- but remove 'Defs' on the way -duUses dus - = foldr get emptyNameSet dus +duUses dus = foldr get emptyNameSet dus where get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index f02ae8d..5489ea7 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -209,6 +209,7 @@ data OccName = OccName { occNameSpace :: !NameSpace , occNameFS :: !FastString } + deriving Typeable \end{code} @@ -221,8 +222,6 @@ instance Ord OccName where compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) -INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName") - instance Data OccName where -- don't traverse? toConstr _ = abstractConstr "OccName" diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 5dcdabe..d2cbd7f 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -185,8 +185,6 @@ instance Outputable SrcLoc where ppr (UnhelpfulLoc s) = ftext s -INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan") - instance Data SrcSpan where -- don't traverse? toConstr _ = abstractConstr "SrcSpan" @@ -237,10 +235,10 @@ data SrcSpan -- also used to indicate an empty span #ifdef DEBUG - deriving (Eq, Show) -- Show is used by Lexer.x, becuase we - -- derive Show for Token + deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token #else - deriving Eq + deriving (Eq, Typeable) #endif -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index ec83494..13810da 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -137,8 +137,7 @@ data Var -- Identical to the Unique in the name, -- cached here for speed varType :: Kind, -- ^ The type or kind of the 'Var' in question - isCoercionVar :: Bool - } + isCoercionVar :: Bool } | TcTyVar { -- Used only during type inference -- Used for kind variables during @@ -155,6 +154,7 @@ data Var idScope :: IdScope, id_details :: IdDetails, -- Stable, doesn't change id_info :: IdInfo } -- Unstable, updated by simplifier + deriving Typeable data IdScope -- See Note [GlobalId/LocalId] = GlobalId @@ -216,8 +216,6 @@ instance Ord Var where a > b = realUnique a ># realUnique b a `compare` b = varUnique a `compare` varUnique b -INSTANCE_TYPEABLE0(Var,varTc,"Var") - instance Data Var where -- don't traverse? toConstr _ = abstractConstr "Var" diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 4d95961..3451c7d 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -51,9 +51,7 @@ module CLabel ( mkAsmTempLabel, - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, + mkPlainModuleInitLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, @@ -70,10 +68,7 @@ module CLabel ( mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, mkCmmInfoLabel, @@ -102,7 +97,6 @@ module CLabel ( mkDeadStripPreventer, mkHpcTicksLabel, - mkHpcModuleNameLabel, hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, @@ -202,23 +196,9 @@ data CLabel | StringLitLabel {-# UNPACK #-} !Unique - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- at some point we might want some kind of version number in - -- the module init label, to guard against compiling modules in - -- the wrong order. We can't use the interface file version however, - -- because we don't always recompile modules which depend on a module - -- whose version has changed. - - | PlainModuleInitLabel -- without the version & way info + | PlainModuleInitLabel -- without the version & way info Module - | ModuleInitTableLabel -- table of imported modules to init - Module - - | ModuleRegdLabel - | CC_Label CostCentre | CCS_Label CostCentreStack @@ -242,9 +222,6 @@ data CLabel -- | Per-module table of tick locations | HpcTicksLabel Module - -- | Per-module name of the module for Hpc - | HpcModuleNameLabel - -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -490,7 +467,6 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) -- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel -- Constructing labels used for dynamic linking @@ -515,19 +491,9 @@ mkStringLitLabel = StringLitLabel mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a = AsmTempLabel (getUnique a) -mkModuleInitLabel :: Module -> String -> CLabel -mkModuleInitLabel mod way = ModuleInitLabel mod way - mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - - -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. @@ -591,10 +557,7 @@ needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False +needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False @@ -612,7 +575,6 @@ needsCDecl l@(ForeignLabel{}) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False -- | Check whether a label is a local temporary for native code generation @@ -630,7 +592,7 @@ maybeAsmTemp _ = Nothing -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we abovoid generating our +-- to the C compiler. For these labels we avoid generating our -- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs @@ -725,11 +687,8 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name @@ -737,8 +696,7 @@ externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- @@ -777,9 +735,7 @@ labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -837,10 +793,8 @@ labelDynamic this_pkg lbl = CmmLabel pkg _ _ -> True #endif - ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -896,8 +850,8 @@ instance Outputable CLabel where pprCLabel :: CLabel -> SDoc -#if ! OMIT_NATIVE_CODEGEN pprCLabel (AsmTempLabel u) + | cGhcWithNativeCodeGen == "YES" = getPprStyle $ \ sty -> if asmStyle sty then ptext asmTempLabelPrefix <> pprUnique u @@ -905,23 +859,22 @@ pprCLabel (AsmTempLabel u) char '_' <> pprUnique u pprCLabel (DynamicLinkerLabel info lbl) + | cGhcWithNativeCodeGen == "YES" = pprDynamicLinkerAsmLabel info lbl pprCLabel PicBaseLabel + | cGhcWithNativeCodeGen == "YES" = ptext (sLit "1b") pprCLabel (DeadStripPreventer lbl) + | cGhcWithNativeCodeGen == "YES" = pprCLabel lbl <> ptext (sLit "_dsp") -#endif -pprCLabel lbl = -#if ! OMIT_NATIVE_CODEGEN - getPprStyle $ \ sty -> - if asmStyle sty then - maybe_underscore (pprAsmCLbl lbl) - else -#endif - pprCLbl lbl +pprCLabel lbl + = getPprStyle $ \ sty -> + if cGhcWithNativeCodeGen == "YES" && asmStyle sty + then maybe_underscore (pprAsmCLbl lbl) + else pprCLbl lbl maybe_underscore doc | underscorePrefix = pp_cSEP <> doc @@ -1008,9 +961,6 @@ pprCLbl (RtsLabel (RtsPrimOp primop)) pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") -pprCLbl ModuleRegdLabel - = ptext (sLit "_module_registered") - pprCLbl (ForeignLabel str _ _ _) = ftext str @@ -1019,22 +969,12 @@ pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs -pprCLbl (ModuleInitLabel mod way) - = ptext (sLit "__stginit_") <> ppr mod - <> char '_' <> text way - pprCLbl (PlainModuleInitLabel mod) = ptext (sLit "__stginit_") <> ppr mod -pprCLbl (ModuleInitTableLabel mod) - = ptext (sLit "__stginittable_") <> ppr mod - pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") -pprCLbl HpcModuleNameLabel - = ptext (sLit "_hpc_module_name_str") - ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> (case x of diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 2e9f952..54b4b11 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -9,10 +9,11 @@ #endif module Cmm - ( CmmGraph(..), CmmBlock + ( CmmGraph, GenCmmGraph(..), CmmBlock , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite + , modifyGraph , lastNode, replaceLastNode, insertBetween , ofBlockMap, toBlockMap, insertBlock , ofBlockList, toBlockList, bodyToBlockList @@ -41,7 +42,8 @@ import Panic ------------------------------------------------- -- CmmBlock, CmmGraph and Cmm -data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C } +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x)) @@ -56,6 +58,9 @@ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph ------------------------------------------------- -- Manipulating CmmGraphs +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + toBlockMap :: CmmGraph -> LabelMap CmmBlock toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body @@ -150,26 +155,26 @@ insertBetween b ms succId = insert $ lastNode b -- Running dataflow analysis and/or rewrites -- Constructing forward and backward analysis-only pass -analFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f -analBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f +analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f +analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f analFwd lat xfer = analRewFwd lat xfer noFwdRewrite analBwd lat xfer = analRewBwd lat xfer noBwdRewrite -- Constructing forward and backward analysis + rewrite pass -analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f -analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f +analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f +analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew} analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew} -- Running forward and backward dataflow analysis + optional rewrite -dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f) +dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) return (CmmGraph {g_entry=entry, g_graph=graph}, facts) -dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f) +dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) return (CmmGraph {g_entry=entry, g_graph=graph}, facts) diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 372562c..aad0037 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -71,10 +71,10 @@ cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)]) cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = do -- Why bother doing it this early? - -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads" -- (dualLivenessWithInsertion callPPs) g -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses - -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" -- (removeDeadAssignmentsAndReloads callPPs) g dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g @@ -91,16 +91,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Spills and reloads ------------------- g <- -- pprTrace "pre Spills" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "spills and reloads" + dual_rewrite run Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion procPoints) g -- Insert spills at defns; reloads at return points g <- -- pprTrace "pre insertLateReloads" (ppr g) $ - run $ insertLateReloads g -- Duplicate reloads just before uses + runOptimization $ insertLateReloads g -- Duplicate reloads just before uses dump Opt_D_dump_cmmz "Post late reloads" g g <- -- pprTrace "post insertLateReloads" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) @@ -112,12 +112,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g + let spEntryMap = getSpEntryMap entry_off g mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () - let areaMap = layout procPoints slotEnv entry_off g + let areaMap = layout procPoints spEntryMap slotEnv entry_off g mbpprTrace "areaMap" (ppr areaMap) $ return () ------------ Manifest the stack pointer -------- - g <- run $ manifestSP areaMap entry_off g + g <- run $ manifestSP spEntryMap areaMap entry_off g dump Opt_D_dump_cmmz "after manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... @@ -146,12 +147,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) - - run = runFuelIO (hsc_OptFuel hsc_env) - - dual_rewrite flag txt pass g = + -- Runs a required transformation/analysis + run = runInfiniteFuelIO (hsc_OptFuel hsc_env) + -- Runs an optional transformation/analysis (and should + -- thus be subject to optimization fuel) + runOptimization = runFuelIO (hsc_OptFuel hsc_env) + + -- pass 'run' or 'runOptimization' for 'r' + dual_rewrite r flag txt pass g = do dump flag ("Pre " ++ txt) g - g <- run $ pass g + g <- r $ pass g dump flag ("Post " ++ txt) $ g return g diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 3ae2996..55a5b73 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -42,8 +42,8 @@ data CmmExpr | CmmRegOff CmmReg Int -- CmmRegOff reg i -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep))) - -- where rep = cmmRegType reg + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) instance Eq CmmExpr where -- Equality ignores the types CmmLit l1 == CmmLit l2 = l1==l2 @@ -124,6 +124,8 @@ cmmExprType (CmmReg reg) = cmmRegType reg cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) cmmExprType (CmmRegOff reg _) = cmmRegType reg cmmExprType (CmmStackSlot _ _) = bWord -- an address +-- Careful though: what is stored at the stack slot may be bigger than +-- an address cmmLitType :: CmmLit -> CmmType cmmLitType (CmmInt _ width) = cmmBits width diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 95b1eef..32fead3 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -24,7 +24,6 @@ import OldPprCmm() import Constants import FastString -import Control.Monad import Data.Maybe -- ----------------------------------------------------------------------------- @@ -70,8 +69,10 @@ lintCmmBlock labels (BasicBlock id stmts) lintCmmExpr :: CmmExpr -> CmmLint CmmType lintCmmExpr (CmmLoad expr rep) = do _ <- lintCmmExpr expr - when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - cmmCheckWordAddress expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ + -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do tys <- mapM lintCmmExpr args @@ -99,14 +100,14 @@ isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -cmmCheckWordAddress :: CmmExpr -> CmmLint () -cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress _ +_cmmCheckWordAddress _ = return () -- No warnings for unaligned arithmetic with the node register, @@ -152,6 +153,7 @@ lintTarget (CmmPrim {}) = return () checkCond :: CmmExpr -> CmmLint () checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 78867b0..c87a3a9 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -63,12 +63,12 @@ gen a live = foldRegsUsed extendRegSet live a kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet kill a live = foldRegsDefd delOneFromUniqSet live a +-- Testing! xferLive :: BwdTransfer CmmNode CmmLive xferLive = mkBTransfer3 fst mid lst where fst _ f = f mid :: CmmNode O O -> CmmLive -> CmmLive - mid n f = gen_kill n $ case n of CmmUnsafeForeignCall {} -> emptyRegSet - _ -> f + mid n f = gen_kill n f lst :: CmmNode O C -> FactBase CmmLive -> CmmLive lst n f = gen_kill n $ case n of CmmCall {} -> emptyRegSet CmmForeignCall {} -> emptyRegSet diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 93564ac..e67321c 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -92,6 +92,8 @@ data CmmNode e x where A MidForeign call is used for *unsafe* foreign calls; a LastForeign call is used for *safe* foreign calls. Unsafe ones are easy: think of them as a "fat machine instruction". +In particular, they do *not* kill all live registers (there was a bit +of code in GHC that conservatively assumed otherwise.) Safe ones are trickier. A safe foreign call r = f(x) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0dec26d..a2eecd5 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module CmmOpt ( + cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold, cmmLoopifyForC, @@ -30,10 +31,69 @@ import UniqFM import Unique import FastTypes import Outputable +import BlockId import Data.Bits import Data.Word import Data.Int +import Data.Maybe +import Data.List + +import Compiler.Hoopl hiding (Unique) + +-- ----------------------------------------------------------------------------- +-- Eliminates dead blocks + +{- +We repeatedly expand the set of reachable blocks until we hit a +fixpoint, and then prune any blocks that were not in this set. This is +actually a required optimization, as dead blocks can cause problems +for invariants in the linear register allocator (and possibly other +places.) +-} + +-- Deep fold over statements could probably be abstracted out, but it +-- might not be worth the effort since OldCmm is moribund +cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock] +cmmEliminateDeadBlocks [] = [] +cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = + let -- Calculate what's reachable from what block + reachableMap = foldl' f emptyUFM blocks -- lazy in values + where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts) + reachableFrom stmts = foldl stmt [] stmts + where + stmt m CmmNop = m + stmt m (CmmComment _) = m + stmt m (CmmAssign _ e) = expr m e + stmt m (CmmStore e1 e2) = expr (expr m e1) e2 + stmt m (CmmCall c _ as _ _) = f (actuals m as) c + where f m (CmmCallee e _) = expr m e + f m (CmmPrim _) = m + stmt m (CmmBranch b) = b:m + stmt m (CmmCondBranch e b) = b:(expr m e) + stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e + stmt m (CmmJump e as) = expr (actuals m as) e + stmt m (CmmReturn as) = actuals m as + actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as + -- We have to do a deep fold into CmmExpr because + -- there may be a BlockId in the CmmBlock literal. + expr m (CmmLit l) = lit m l + expr m (CmmLoad e _) = expr m e + expr m (CmmReg _) = m + expr m (CmmMachOp _ es) = foldl' expr m es + expr m (CmmStackSlot _ _) = m + expr m (CmmRegOff _ _) = m + lit m (CmmBlock b) = b:m + lit m _ = m + -- go todo done + reachable = go [base_id] (setEmpty :: BlockSet) + where go [] m = m + go (x:xs) m + | setMember x m = go xs m + | otherwise = go (add ++ xs) (setInsert x m) + where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block") + (lookupUFM reachableMap x) + in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks -- ----------------------------------------------------------------------------- -- The mini-inliner @@ -115,12 +175,15 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts cmmMiniInlineStmts uses (stmt:stmts) = stmt : cmmMiniInlineStmts uses stmts -lookForInline u expr (stmt : rest) +lookForInline u expr stmts = lookForInline' u expr regset stmts + where regset = foldRegsUsed extendRegSet emptyRegSet expr + +lookForInline' u expr regset (stmt : rest) | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline = Just (inlineStmt u expr stmt : rest) | ok_to_skip - = case lookForInline u expr rest of + = case lookForInline' u expr regset rest of Nothing -> Nothing Just stmts -> Just (stmt:stmts) @@ -137,13 +200,18 @@ lookForInline u expr (stmt : rest) CmmCall{} -> hasNoGlobalRegs expr _ -> True - -- We can skip over assignments to other tempoararies, because we - -- know that expressions aren't side-effecting and temporaries are - -- single-assignment. + -- Expressions aren't side-effecting. Temporaries may or may not + -- be single-assignment depending on the source (the old code + -- generator creates single-assignment code, but hand-written Cmm + -- and Cmm from the new code generator is not single-assignment.) + -- So we do an extra check to make sure that the register being + -- changed is not one we were relying on. I don't know how much of a + -- performance hit this is (we have to create a regset for every + -- instruction.) -- EZY ok_to_skip = case stmt of CmmNop -> True CmmComment{} -> True - CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True + CmmAssign (CmmLocal r@(LocalReg u' _)) rhs | u' /= u && not (r `elemRegSet` regset) -> True CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr) _other -> False diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 8c2498e..4dc7e32 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -396,13 +396,15 @@ stmt :: { ExtCode } | NAME '(' exprs0 ')' ';' {% stmtMacro $1 $3 } | 'switch' maybe_range expr '{' arms default '}' - { doSwitch $2 $3 $5 $6 } + { do as <- sequence $5; doSwitch $2 $3 as $6 } | 'goto' NAME ';' { do l <- lookupLabel $2; stmtEC (CmmBranch l) } | 'jump' expr maybe_actuals ';' { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) } | 'return' maybe_actuals ';' { do e <- sequence $2; stmtEC (CmmReturn e) } + | 'if' bool_expr 'goto' NAME + { do l <- lookupLabel $4; cmmRawIf $2 l } | 'if' bool_expr '{' body '}' else { cmmIfThenElse $2 $4 $6 } @@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) } : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } | {- empty -} { Nothing } -arms :: { [([Int],ExtCode)] } +arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } : {- empty -} { [] } | arm arms { $1 : $2 } -arm :: { ([Int],ExtCode) } - : 'case' ints ':' '{' body '}' { ($2, $5) } +arm :: { ExtFCode ([Int],Either BlockId ExtCode) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } + +arm_body :: { ExtFCode (Either BlockId ExtCode) } + : '{' body '}' { return (Right $2) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } ints :: { [Int] } : INT { [ fromIntegral $1 ] } @@ -458,6 +464,8 @@ default :: { Maybe ExtCode } -- 'default' branches | {- empty -} { Nothing } +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. else :: { ExtCode } : {- empty -} { nopEC } | 'else' '{' body '}' { $3 } @@ -952,6 +960,10 @@ cmmIfThenElse cond then_part else_part = do -- fall through to join code (labelC join_id) +cmmRawIf cond then_id = do + c <- cond + emitCond c then_id + -- 'emitCond cond true_id' emits code to test whether the cond is true, -- branching to true_id if so, and falling through otherwise. emitCond (BoolTest e) then_id = do @@ -991,7 +1003,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do -- optional range on the switch (eg. switch [0..7] {...}), or by -- the minimum/maximum values from the branches. -doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)] +doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)] -> Maybe ExtCode -> ExtCode doSwitch mb_range scrut arms deflt = do @@ -1018,12 +1030,12 @@ doSwitch mb_range scrut arms deflt -- ToDo: check for out of range and jump to default if necessary stmtEC (CmmSwitch expr entries) where - emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)] - emitArm (ints,code) = do + emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do blockid <- forkLabelledCodeEC code return [ (i,blockid) | i <- ints ] - -- ----------------------------------------------------------------------------- -- Putting it all together diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index d0d54d9..fbe979b 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -378,6 +378,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) -- 4. build info tables for the procedures -- and update the info table for -- the SRTs in the entry procedure as well. -- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> CmmTop -> FuelUniqSM [CmmTop] splitAtProcPoints entry_label callPPs procPoints procMap diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 4e2dd38..17364ad 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -100,11 +100,11 @@ dualLiveTransfers entry procPoints = mkBTransfer3 first middle last where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x middle :: CmmNode O O -> DualLive -> DualLive - middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live) - where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle - regs_in :: RegSet -> RegSet - regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet - _ -> live + middle m = changeStack updSlots + . changeRegs updRegs + where -- Reuse middle of liveness analysis from CmmLive + updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m + updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r spill live _ = live diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 01543c4..c0fb6af 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -13,7 +13,7 @@ module CmmStackLayout ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs - , layout, manifestSP, igraph, areaBuilder + , getSpEntryMap, layout, manifestSP, igraph, areaBuilder , stubSlotsOnDeath ) -- to help crash early during debugging where @@ -195,7 +195,7 @@ liveLastOut env l = type Set x = Map x () data IGraphBuilder n = Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z - , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int] + , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int] } areaBuilder :: IGraphBuilder Area @@ -242,10 +242,13 @@ igraph builder env g = foldr interfere Map.empty (postorderDfs g) -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. +-- Mapping of areas to area sizes (not offsets!) +type AreaSizeMap = AreaMap + -- JD: WHY CAN'T THIS COME FROM THE slot-liveness info? -getAreaSize :: ByteOff -> CmmGraph -> AreaMap +getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap -- The domain of the returned mapping consists only of Areas - -- used for (a) variable spill slots, and (b) parameter passing ares for calls + -- used for (a) variable spill slots, and (b) parameter passing areas for calls getAreaSize entry_off g = foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last)) (Map.singleton (CallArea Old) entry_off) g @@ -266,10 +269,11 @@ getAreaSize entry_off g = -- The 'max' is important. Two calls, to f and g, might share a common -- continuation (and hence a common CallArea), but their number of overflow -- parameters might differ. + -- EZY: Ought to use insert with combining function... -- Find the Stack slots occupied by the subarea's conflicts -conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int +conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = foldNodes subarea foldNode Map.empty where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig @@ -278,10 +282,10 @@ conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) setAdd w s = Map.insert w () s --- Find any open space on the stack, starting from the offset. --- If the area is a CallArea or a spill slot for a pointer, then it must --- be word-aligned. -freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int +-- Find any open space for 'area' on the stack, starting from the +-- 'offset'. If the area is a CallArea or a spill slot for a pointer, +-- then it must be word-aligned. +freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int freeSlotFrom ig areaSize offset areaMap area = let size = Map.lookup area areaSize `orElse` 0 conflicts = conflictSlots ig areaSize areaMap (area, size, size) @@ -299,11 +303,24 @@ freeSlotFrom ig areaSize offset areaMap area = in findSpace (align (offset + size)) size -- Find an open space on the stack, and assign it to the area. -allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap +allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap allocSlotFrom ig areaSize from areaMap area = if Map.member area areaMap then areaMap else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap +-- Figure out all of the offsets from the slot location; this will be +-- non-zero for procpoints. +type SpEntryMap = BlockEnv Int +getSpEntryMap :: Int -> CmmGraph -> SpEntryMap +getSpEntryMap entry_off g@(CmmGraph {g_entry = entry}) + = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g + where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int + add_sp_off b env = + case lastNode b of + CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env + CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env + _ -> env + -- | Greedy stack layout. -- Compute liveness, build the interference graph, and allocate slots for the areas. -- We visit each basic block in a (generally) forward order. @@ -326,12 +343,16 @@ allocSlotFrom ig areaSize from areaMap area = -- Note: The stack pointer only has to be younger than the youngest live stack slot -- at proc points. Otherwise, the stack pointer can point anywhere. -layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap +layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap -- The domain of the returned map includes an Area for EVERY block -- including each block that is not the successor of a call (ie is not a proc-point) --- That's how we return the info of what the SP should be at the entry of every block +-- That's how we return the info of what the SP should be at the entry of every non +-- procpoint block. However, note that procpoint blocks have their +-- /slot/ stored, which is not necessarily the value of the SP on entry +-- to the block (in fact, it probably isn't, due to argument passing). +-- See [Procpoint Sp offset] -layout procPoints env entry_off g = +layout procPoints spEntryMap env entry_off g = let ig = (igraph areaBuilder env g, areaBuilder) env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" areaSize = getAreaSize entry_off g @@ -370,21 +391,87 @@ layout procPoints env entry_off g = allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m allocLast bid l areaMap = foldr (setSuccSPs inSp) areaMap' (successors l) - where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap + where inSp = slot + spOffset -- [Procpoint Sp offset] + -- If it's not in the map, we should use our previous + -- calculation unchanged. + spOffset = mapLookup bid spEntryMap `orElse` 0 + slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a alloc' areaMap _ = areaMap - initMap = Map.insert (CallArea (Young (g_entry g))) 0 $ - Map.insert (CallArea Old) 0 Map.empty - + initMap = Map.insert (CallArea (Young (g_entry g))) 0 + . Map.insert (CallArea Old) 0 + $ Map.empty + areaMap = foldl layoutAreas initMap (postorderDfs g) in -- pprTrace "ProcPoints" (ppr procPoints) $ - -- pprTrace "Area SizeMap" (ppr areaSize) $ - -- pprTrace "Entry SP" (ppr entrySp) $ - -- pprTrace "Area Map" (ppr areaMap) $ + -- pprTrace "Area SizeMap" (ppr areaSize) $ + -- pprTrace "Entry offset" (ppr entry_off) $ + -- pprTrace "Area Map" (ppr areaMap) $ areaMap +{- Note [Procpoint Sp offset] + +The calculation of inSp is a little tricky. (Un)fortunately, if you get +it wrong, you will get inefficient but correct code. You know you've +got it wrong if the generated stack pointer bounces up and down for no +good reason. + +Why can't we just set inSp to the location of the slot? (This is what +the code used to do.) The trouble is when we actually hit the proc +point the start of the slot will not be the same as the actual Sp due +to argument passing: + + a: + I32[(young + 4)] = cde; + // Stack pointer is moved to young end (bottom) of young for call + // +-------+ + // | arg 1 | + // +-------+ <- Sp + call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4; + b: + // After call, stack pointer is above the old end (top) of + // young (the difference is spOffset) + // +-------+ <- Sp + // | arg 1 | + // +-------+ + +If we blithely set the Sp to be the same as the slot (the young end of +young), an adjustment will be necessary when we go to the next block. +This is wasteful. So, instead, for the next block after a procpoint, +the actual Sp should be set to the same as the true Sp when we just +entered the procpoint. Then manifestSP will automatically do the right +thing. + +Questions you may ask: + +1. Why don't we need to change the mapping for the procpoint itself? + Because manifestSP does its own calculation of the true stack value, + manifestSP will notice the discrepancy between the actual stack + pointer and the slot start, and adjust all of its memory accesses + accordingly. So the only problem is when we adjust the Sp in + preparation for the successor block; that's why this code is here and + not in setSuccSPs. + +2. Why don't we make the procpoint call area and the true offset match + up? If we did that, we would never use memory above the true value + of the stack pointer, thus wasting all of the stack we used to store + arguments. You might think that some clever changes to the slot + offsets, using negative offsets, might fix it, but this does not make + semantic sense. + +3. If manifestSP is already calculating the true stack value, why we can't + do this trick inside manifestSP itself? The reason is that if two + branches join with inconsistent SPs, one of them has to be fixed: we + can't know what the fix should be without already knowing what the + chosen location of SP is on the next successor. (This is + the "succ already knows incoming SP" case), This calculation cannot + be easily done in manifestSP, since it processes the nodes + /backwards/. So we need to have figured this out before we hit + manifestSP. +-} + -- After determining the stack layout, we can: -- 1. Replace references to stack Areas with addresses relative to the stack -- pointer. @@ -394,8 +481,8 @@ layout procPoints env entry_off g = -- stack pointer to be younger than the live values on the stack at proc points. -- 3. Compute the maximum stack offset used in the procedure and replace -- the stack high-water mark with that offset. -manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph -manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = +manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph +manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) = ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g) where slot a = -- pprTrace "slot" (ppr a) $ Map.lookup a areaMap `orElse` panic "unallocated Area" @@ -404,13 +491,6 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = sp_high = maxSlot slot g proc_entry_sp = slot (CallArea Old) + entry_off - add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int - add_sp_off b env = - case lastNode b of - CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env - CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env - _ -> env - spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g spOffset id = mapLookup id spEntryMap `orElse` 0 sp_on_entry id | id == entry = proc_entry_sp @@ -427,10 +507,26 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) = where spIn = sp_on_entry (entryLabel block) middle spOff m = mapExpDeep (replSlot spOff) m + -- XXX there shouldn't be any global registers in the + -- CmmCall, so there shouldn't be any slots in + -- CmmCall... check that... last spOff l = mapExpDeep (replSlot spOff) l replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i)) replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord)) + -- Invariant: Sp is always greater than SpLim. Thus, if + -- the high water mark is zero, we can optimize away the + -- conditional branch. Relies on dead code elimination + -- to get rid of the dead GC blocks. + -- EZY: Maybe turn this into a guard that checks if a + -- statement is stack-check ish? Maybe we should make + -- an actual mach-op for it, so there's no chance of + -- mixing this up with something else... + replSlot _ (CmmMachOp (MO_U_Lt _) + [CmmMachOp (MO_Sub _) + [ CmmReg (CmmGlobal Sp) + , CmmLit (CmmInt 0 _)], + CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth) replSlot _ e = e replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock] diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 69b481b..c9e422f 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -24,7 +24,7 @@ module MkGraph , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot -- Reexport of needed Cmm stuff , Convention(..), ForeignConvention(..), ForeignTarget(..) - , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..) + , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..) , Cmm, CmmTop ) where diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 057a965..f624c1c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -6,12 +6,12 @@ -- the optimiser with varying amount of fuel to find out the exact number of -- steps where a bug is introduced in the output. module OptimizationFuel - ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel + ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel , OptFuelState, initOptFuelState , FuelConsumer, FuelUsingMonad, FuelState , fuelGet, fuelSet, lastFuelPass, setFuelPass , fuelExhausted, fuelDec1, tryWithFuel - , runFuelIO, fuelConsumingPass + , runFuelIO, runInfiniteFuelIO, fuelConsumingPass , FuelUniqSM , liftUniq ) @@ -21,9 +21,7 @@ import Data.IORef import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply -#ifdef DEBUG import Panic -#endif import Compiler.Hoopl import Compiler.Hoopl.GHC (getFuel, setFuel) @@ -51,8 +49,8 @@ amountOfFuel :: OptimizationFuel -> Int anyFuelLeft :: OptimizationFuel -> Bool oneLessFuel :: OptimizationFuel -> OptimizationFuel +unlimitedFuel :: OptimizationFuel -#ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int deriving Show @@ -61,16 +59,7 @@ amountOfFuel (OptimizationFuel f) = f anyFuelLeft (OptimizationFuel f) = f > 0 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) -#else --- type OptimizationFuel = State# () -- would like this, but it won't work -data OptimizationFuel = OptimizationFuel - deriving Show -tankFilledTo _ = OptimizationFuel -amountOfFuel _ = maxBound - -anyFuelLeft _ = True -oneLessFuel _ = OptimizationFuel -#endif +unlimitedFuel = OptimizationFuel infiniteFuel data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) } @@ -92,6 +81,16 @@ runFuelIO fs (FUSM f) = writeIORef (fuel_ref fs) fuel' return a +-- ToDo: Do we need the pass_ref when we are doing infinite fueld +-- transformations? +runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runInfiniteFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass) + writeIORef (pass_ref fs) pass' + return a + instance Monad FuelUniqSM where FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s') return a = FUSM (\s -> return (a, s)) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 10c9f18..aa7d914 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -50,6 +50,7 @@ import Outputable import Constants import BasicTypes import CLabel +import Util -- The rest import Data.List @@ -63,10 +64,6 @@ import Data.Word import Data.Array.ST import Control.Monad.ST -#if x86_64_TARGET_ARCH -import StaticFlags ( opt_Unregisterised ) -#endif - #if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH) #define BEWARE_LOAD_STORE_ALIGNMENT #endif @@ -104,18 +101,19 @@ pprTop (CmmProc info clbl (ListGraph blocks)) = then pprDataExterns info $$ pprWordArray (entryLblToInfoLbl clbl) info else empty) $$ - (case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> vcat [ + (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + case blocks of + [] -> empty + -- the first block doesn't get a label: + (BasicBlock _ stmts : rest) -> + nest 8 (vcat (map pprStmt stmts)) $$ + vcat (map pprBBlock rest), nest 8 mkFE_, rbrace ] ) @@ -818,17 +816,6 @@ pprCall ppr_fn cconv results args _ | otherwise = -#if x86_64_TARGET_ARCH - -- HACK around gcc optimisations. - -- x86_64 needs a __DISCARD__() here, to create a barrier between - -- putting the arguments into temporaries and passing the arguments - -- to the callee, because the argument expressions may refer to - -- machine registers that are also used for passing arguments in the - -- C calling convention. - (if (not opt_Unregisterised) - then ptext (sLit "__DISCARD__();") - else empty) $$ -#endif ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs @@ -1022,18 +1009,6 @@ machRep_S_CType _ = panic "machRep_S_CType" pprStringInCStyle :: [Word8] -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers. We can't -- just emit the floating point number, because C will cast it to an int diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes index 0852711..e787f18 100644 --- a/compiler/cmm/cmm-notes +++ b/compiler/cmm/cmm-notes @@ -15,14 +15,11 @@ Things to do: This will fix the spill before stack check problem but only really as a side effect. A 'real fix' probably requires making the spiller know about sp checks. - - There is some silly stuff happening with the Sp. We end up with code like: - Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8 - Seems to be perhaps caused by the issue above but also maybe a optimisation - pass needed? + EZY: I don't understand this comment. David Terei, can you clarify? - - Proc pass all arguments on the stack, adding more code and slowing down things - a lot. We either need to fix this or even better would be to get rid of - proc points. + - Proc points pass all arguments on the stack, adding more code and + slowing down things a lot. We either need to fix this or even better + would be to get rid of proc points. - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to Old.Cmm. We should abstract it to work on both representations, it needs only to @@ -32,7 +29,7 @@ Things to do: we could convert codeGen/StgCmm* clients to the Hoopl's semantics? It's all deeply unsatisfactory. - - Improve preformance of Hoopl. + - Improve performance of Hoopl. A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters (using the same ghc-cmm branch +libraries compiled by the old codegenerator) @@ -50,6 +47,9 @@ Things to do: So we generate a bit better code, but it takes us longer! + EZY: Also importantly, Hoopl uses dramatically more memory than the + old code generator. + - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could splice blocks instead? @@ -57,7 +57,7 @@ Things to do: a block catenation function would be probably nicer than blockToNodeList / blockOfNodeList combo. - - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that + - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that delete splitEntrySeq from HooplUtils. - manifestSP seems to touch a lot of the graph representation. It is @@ -76,6 +76,9 @@ Things to do: calling convention, and the code for calling foreign calls is generated - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline + EZY (2011-04-16): The mini-inliner has been generalized and ported, + but the constant folding and other optimizations need to still be + ported. - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches); we ultimately want to share this with the Cmm branch eliminator. @@ -113,7 +116,7 @@ Things to do: - See "CAFs" below; we want to totally refactor the way SRTs are calculated - Pull out Areas into its own module - Parameterise AreaMap + Parameterise AreaMap (note there are type synonyms in CmmStackLayout!) Add ByteWidth = Int type SubArea = (Area, ByteOff, ByteWidth) ByteOff should not be defined in SMRep -- that is too high up the hierarchy @@ -293,8 +296,8 @@ cpsTop: insert spills/reloads across LastCalls, and Branches to proc-points - Now sink those reloads: - - CmmSpillReload.insertLateReloads + Now sink those reloads (and other instructions): + - CmmSpillReload.rewriteAssignments - CmmSpillReload.removeDeadAssignmentsAndReloads * CmmStackLayout.stubSlotsOnDeath @@ -344,7 +347,7 @@ to J that way. This is an awkward choice. (We think that we currently never pass variables to join points via arguments.) Furthermore, there is *no way* to pass q to J in a register (other -than a paramter register). +than a parameter register). What we want is to do register allocation across the whole caboodle. Then we could drop all the code that deals with the above awkward diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index da44122..d158bf7 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -250,7 +250,6 @@ closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc { enterCostCentre cl_info cc body - ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body] ; cgExpr body } } diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 8da2715..4875650 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -6,24 +6,14 @@ -- ----------------------------------------------------------------------------- -module CgHpc (cgTickBox, initHpc, hpcTable) where +module CgHpc (cgTickBox, hpcTable) where import OldCmm import CLabel import Module import OldCmmUtils -import CgUtils import CgMonad -import CgForeignCall -import ForeignCall -import ClosureInfo -import FastString import HscTypes -import Panic -import BasicTypes - -import Data.Char -import Data.Word cgTickBox :: Module -> Int -> Code cgTickBox mod n = do @@ -40,47 +30,10 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) ] ++ [ CmmStaticLit (CmmInt 0 W64) | _ <- take hpc_tickCount [0::Int ..] ] - where - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str hpcTable _ (NoHpcInfo {}) = error "TODO: impossible" - -initHpc :: Module -> HpcInfo -> Code -initHpc this_mod (HpcInfo tickCount hashNo) - = do { id <- newTemp bWord - ; emitForeignCall' - PlayRisky - [CmmHinted id NoHint] - (CmmCallee - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - CCallConv - ) - [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint - , CmmHinted (word32 tickCount) NoHint - , CmmHinted (word32 hashNo) NoHint - , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint - ] - (Just []) - NoC_SRT -- No SRT b/c we PlayRisky - CmmMayReturn - } - where - word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32) - mod_alloc = mkFastString "hs_hpc_module" -initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo" - diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 0cf209e..243aa1d 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -16,8 +16,7 @@ module CgProf ( costCentreFrom, curCCS, curCCSAddr, emitCostCentreDecl, emitCostCentreStackDecl, - emitRegisterCC, emitRegisterCCS, - emitSetCCC, emitCCS, + emitSetCCC, emitCCS, -- Lag/drag/void stuff ldvEnter, ldvEnterClosure, ldvRecordCreate @@ -348,56 +347,6 @@ sizeof_ccs_words (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -emitRegisterCC :: CostCentre -> Code -emitRegisterCC cc = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - CmmStore cC_LIST cc_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -emitRegisterCCS :: CostCentreStack -> Code -emitRegisterCCS ccs = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - CmmStore cCS_LIST ccs_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Code diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 6ce8fca..7a7bf48 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -29,7 +29,6 @@ import CgHpc import CLabel import OldCmm -import OldCmmUtils import OldPprCmm import StgSyn @@ -51,8 +50,7 @@ import Panic codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output @@ -61,8 +59,7 @@ codeGen :: DynFlags -- possible for object splitting to split up the -- pieces later. -codeGen dflags this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "CodeGen" @@ -73,167 +70,46 @@ codeGen dflags this_mod data_tycons imported_mods { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons ; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info - this_mod imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in -- code_stuff + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) ; return code_stuff } -\end{code} - -%************************************************************************ -%* * -\subsection[codegen-init]{Module initialisation code} -%* * -%************************************************************************ - -/* ----------------------------------------------------------------------------- - Module initialisation - - The module initialisation code looks like this, roughly: - - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } - - FN(__stginit_Foo_1_p) { - ... - } - - We have one version of the init code with a module version and the - 'way' attached to it. The version number helps to catch cases - where modules are not compiled in dependency order before being - linked: if a module has been compiled since any modules which depend on - it, then the latter modules will refer to a different version in their - init blocks and a link error will ensue. - - The 'way' suffix helps to catch cases where modules compiled in different - ways are linked together (eg. profiled and non-profiled). - - We provide a plain, unadorned, version of the module init code - which just jumps to the version with the label and way attached. The - reason for this is that when using foreign exports, the caller of - startupHaskell() must supply the name of the init function for the "top" - module in the program, and we don't want to require that this name - has the version and way info appended to it. - -------------------------------------------------------------------------- */ - -We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot - -\begin{code} -mkModuleInit +mkModuleInit :: DynFlags -> CollectedCCs -- cost centre info -> Module - -> [Module] - -> HpcInfo + -> HpcInfo -> Code -mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] +mkModuleInit dflags cost_centre_info this_mod hpc_info + = do { -- Allocate the static boolean that records if this ; whenC (opt_Hpc) $ hpcTable this_mod hpc_info - -- we emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; emitSimpleProc real_init_lbl $ do - { ret_blk <- forkLabelledCode ret_code - - ; init_blk <- forkLabelledCode $ do - { mod_init_code; stmtC (CmmBranch ret_blk) } - - ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - ret_blk) - ; stmtC (CmmBranch init_blk) - } - - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) - } - where - -- The way string we attach to the __stginit label to catch - -- accidental linking of modules compiled in different ways. We - -- omit "dyn" from this way, because we want to be able to load - -- both dynamic and non-dynamic modules into a dynamic GHC. - way = mkBuildTag (filter want_way (ways dflags)) - want_way w = not (wayRTSOnly w) && wayName w /= WayDyn - - main_mod = mainModIs dflags - - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - - mod_init_code = do - { -- Set mod_reg to 1 to record that we've been here - stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) - ; whenC (opt_SccProfilingOn) $ do initCostCentres cost_centre_info - ; whenC (opt_Hpc) $ - initHpc this_mod hpc_info - - ; mapCs (registerModuleImport way) - (imported_mods++extra_imported_mods) - - } - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1) - , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ] - - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerModuleImport :: String -> Module -> Code -registerModuleImport way mod - | mod == gHC_PRIM - = nopC - | otherwise -- Push the init procedure onto the work stack - = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + + ; whenC (this_mod == mainModIs dflags) $ + emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () + } \end{code} @@ -252,9 +128,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) | otherwise = do { mapM_ emitCostCentreDecl local_CCs ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; mapM_ emitRegisterCC local_CCs - ; mapM_ emitRegisterCCS singleton_CCSs - } + } \end{code} %************************************************************************ diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 26ace07..2bfe187 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -24,16 +24,13 @@ import StgCmmHpc import StgCmmTicky import MkGraph -import CmmDecl import CmmExpr -import CmmUtils +import CmmDecl import CLabel import PprCmm import StgSyn -import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -50,17 +47,14 @@ import Outputable codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- Directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons imported_mods +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "New CodeGen" - ; let way = buildTag dflags - main_mod = mainModIs dflags -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons @@ -68,10 +62,9 @@ codeGen dflags this_mod data_tycons imported_mods ; code_stuff <- initC dflags this_mod $ do { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit way cost_centre_info - this_mod main_mod - imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + ; cmm_init <- getCmm (mkModuleInit cost_centre_info + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -82,6 +75,12 @@ codeGen dflags this_mod data_tycons imported_mods -- possible for object splitting to split up the -- pieces later. + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) ; return code_stuff } @@ -173,89 +172,18 @@ We initialise the module tree by keeping a work-stack, -} mkModuleInit - :: String -- the "way" - -> CollectedCCs -- cost centre info + :: CollectedCCs -- cost centre info -> Module - -> Module -- name of the Main module - -> [Module] - -> HpcInfo + -> HpcInfo -> FCode () -mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] - - ; init_hpc <- initHpc this_mod hpc_info - ; init_prof <- initCostCentres cost_centre_info - - -- We emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; updfr_sz <- getUpdFrameOff - ; tail <- getCode (pushUpdateFrame imports - (do updfr_sz' <- getUpdFrameOff - emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) - ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId updfr_sz - , init_prof - , init_hpc - , tail]) - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) - } - where - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz - - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - all_imported_mods = imported_mods ++ extra_imported_mods - imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) - (filter (gHC_PRIM /=) all_imported_mods) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId updfr_sz - = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop - <*> -- Set mod_reg to 1 to record that we've been here - mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumps to the popped item - ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord - ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) - -- mkAssign spReg (cmmRegOffW spReg 1) <*> - -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz - - pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) - - rec_descent_init updfr_sz = - if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init updfr_sz - else ret_code updfr_sz + +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + } --------------------------------------------------------------- -- Generating static stuff for algebraic data types diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index fe09f68..d617743 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -304,13 +304,15 @@ type DynTag = Int -- The tag on a *pointer* {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors) -can be either: +The family size of a data type (the number of constructors +or the arity of a function) can be either: * small, if the family size < 2**tag_bits * big, otherwise. Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -} +Big families only use the tag value 1 to represent evaluatedness. +We don't have very many tag bits: for example, we have 2 bits on +x86-32 and 3 bits on x86-64. -} isSmallFamily :: Int -> Bool isSmallFamily fam_size = fam_size <= mAX_PTR_TAG diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index a93af34..fae3bef 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -8,9 +8,7 @@ module StgCmmHpc ( initHpc, mkTickBox ) where -import StgCmmUtils import StgCmmMonad -import StgCmmForeign import MkGraph import CmmDecl @@ -18,11 +16,8 @@ import CmmExpr import CLabel import Module import CmmUtils -import FastString import HscTypes -import Data.Char import StaticFlags -import BasicTypes mkTickBox :: Module -> Int -> CmmAGraph mkTickBox mod n @@ -35,41 +30,15 @@ mkTickBox mod n (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n -initHpc :: Module -> HpcInfo -> FCode CmmAGraph +initHpc :: Module -> HpcInfo -> FCode () -- Emit top-level tables for HPC and return code to initialise initHpc _ (NoHpcInfo {}) - = return mkNop -initHpc this_mod (HpcInfo tickCount hashNo) - = getCode $ whenC opt_Hpc $ - do { emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] - ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) + = return () +initHpc this_mod (HpcInfo tickCount _hashNo) + = whenC opt_Hpc $ + do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) ] ++ [ CmmStaticLit (CmmInt 0 W64) | _ <- take tickCount [0::Int ..] ] - - ; id <- newTemp bWord -- TODO FIXME NOW - ; emitCCall - [(id,NoHint)] - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - [ (mkLblExpr mkHpcModuleNameLabel,AddrHint) - , (CmmLit $ mkIntCLit tickCount,NoHint) - , (CmmLit $ mkIntCLit hashNo,NoHint) - , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint) - ] } - where - mod_alloc = mkFastString "hs_hpc_module" - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str - - - diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 36d05ac..08bf529 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -348,14 +348,12 @@ ifProfilingL xs -- Initialising Cost Centres & CCSs --------------------------------------------------------------- -initCostCentres :: CollectedCCs -> FCode CmmAGraph --- Emit the declarations, and return code to register them +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = getCode $ whenC opt_SccProfilingOn $ + = whenC opt_SccProfilingOn $ do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; emit $ catAGraphs $ map mkRegisterCC local_CCs - ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs } + ; mapM_ emitCostCentreStackDecl singleton_CCSs } emitCostCentreDecl :: CostCentre -> FCode () @@ -409,54 +407,6 @@ sizeof_ccs_words (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -mkRegisterCC :: CostCentre -> CmmAGraph -mkRegisterCC cc - = withTemp cInt $ \tmp -> - catAGraphs [ - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - mkStore cC_LIST cc_lit, - mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -mkRegisterCCS :: CostCentreStack -> CmmAGraph -mkRegisterCCS ccs - = withTemp cInt $ \ tmp -> - catAGraphs [ - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - mkStore cCS_LIST ccs_lit, - mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> FCode () diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2432051..d894179 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -112,7 +112,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) -- if there are view patterns, just give up - don't know what the function is check qs = (untidy_warns, shadowed_eqns) where - (warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs) + tidy_qs = map tidy_eqn qs + (warns, used_nos) = check' ([1..] `zip` tidy_qs) untidy_warns = map untidy_exhaustive warns shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], not (i `elementOfUniqSet` used_nos)] @@ -671,8 +672,6 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty -tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq - tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) = pat { pat_args = tidy_con id ps } @@ -696,16 +695,18 @@ tidy_pat (TuplePat ps boxity ty) where arity = length ps --- Unpack string patterns fully, so we can see when they overlap with --- each other, or even explicit lists of Chars. -tidy_pat (LitPat lit) +tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq +tidy_pat (LitPat lit) = tidy_lit_pat lit + +tidy_lit_pat :: HsLit -> Pat Id +-- Unpack string patterns fully, so we can see when they +-- overlap with each other, or even explicit lists of Chars. +tidy_lit_pat lit | HsString s <- lit - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy) + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s) | otherwise = tidyLitPat lit - where - mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy ----------------- tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 95b70f0..8071da7 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -5,7 +5,7 @@ \section[Coverage]{@coverage@: the main function} \begin{code} -module Coverage (addCoverageTicksToBinds) where +module Coverage (addCoverageTicksToBinds, hpcInitCode) where import HsSyn import Module @@ -25,6 +25,8 @@ import StaticFlags import TyCon import MonadUtils import Maybes +import CLabel +import Util import Data.Array import System.Directory ( createDirectoryIfMissing ) @@ -299,10 +301,9 @@ addTickHsExpr (HsLet binds e) = liftM2 HsLet (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprNeverOrAlways e) -addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do - (stmts', last_exp') <- addTickLStmts' forQual stmts - (addTickLHsExpr last_exp) - return (HsDo cxt stmts' last_exp' srcloc) +addTickHsExpr (HsDo cxt stmts srcloc) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo cxt stmts' srcloc) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -363,6 +364,20 @@ addTickHsExpr (HsWrap w e) = (return w) (addTickHsExpr e) -- explicitly no tick on inside +addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) = + liftM5 HsArrApp + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return arr_ty) + (return lr) + +addTickHsExpr (HsArrForm e fix cmdtop) = + liftM3 HsArrForm + (addTickLHsExpr e) + (return fix) + (mapM (liftL (addTickHsCmdTop)) cmdtop) + addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. @@ -408,45 +423,50 @@ addTickLStmts isGuard stmts = do addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a -> TM ([LStmt Id], a) addTickLStmts' isGuard lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders lstmts + = bindLocals (collectLStmtsBinders lstmts) $ + do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) +addTickStmt _isGuard (LastStmt e ret) = do + liftM2 LastStmt + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt pat e bind fail) = do liftM4 BindStmt (addTickLPat pat) (addTickLHsExprAlways e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) -addTickStmt isGuard (ExprStmt e bind' ty) = do - liftM3 ExprStmt +addTickStmt isGuard (ExprStmt e bind' guard' ty) = do + liftM4 ExprStmt (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') (return ty) addTickStmt _isGuard (LetStmt binds) = do liftM LetStmt (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs) = do - liftM ParStmt +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do + liftM4 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) - -addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do - liftM4 TransformStmt - (addTickLStmts isGuard stmts) - (return ids) - (addTickLHsExprAlways usingExpr) - (addTickMaybeByLHsExpr maybeByExpr) - -addTickStmt isGuard (GroupStmt stmts binderMap by using) = do - liftM4 GroupStmt - (addTickLStmts isGuard stmts) - (return binderMap) - (fmapMaybeM addTickLHsExprAlways by) - (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using) + (addTickSyntaxExpr hpcSrcSpan mzipExpr) + (addTickSyntaxExpr hpcSrcSpan bindExpr) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprAlways by + t_u <- addTickLHsExprAlways using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } addTickStmt isGuard stmt@(RecStmt {}) = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) @@ -467,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) = (addTickLStmts isGuard stmts) (return ids) -addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id)) -addTickMaybeByLHsExpr maybeByExpr = - case maybeByExpr of - Nothing -> return Nothing - Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just) - addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) addTickHsLocalBinds (HsValBinds binds) = liftM HsValBinds @@ -553,10 +567,10 @@ addTickHsCmd (HsLet binds c) = liftM2 HsLet (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do - (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp) - return (HsDo cxt stmts' last_exp' srcloc) - where +addTickHsCmd (HsDo cxt stmts srcloc) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsDo cxt stmts' srcloc) } + addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsArrApp (addTickLHsExpr e1) @@ -619,10 +633,15 @@ addTickCmdStmt (BindStmt pat c bind fail) = do (addTickLHsCmd c) (return bind) (return fail) -addTickCmdStmt (ExprStmt c bind' ty) = do - liftM3 ExprStmt +addTickCmdStmt (LastStmt c ret) = do + liftM2 LastStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (ExprStmt c bind' guard' ty) = do + liftM4 ExprStmt (addTickLHsCmd c) - (return bind') + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') (return ty) addTickCmdStmt (LetStmt binds) = do liftM LetStmt @@ -871,3 +890,56 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} + +%************************************************************************ +%* * +%* initialisation +%* * +%************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} + +\begin{code} +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + ptext (sLit "extern StgWord64 ") <> tickboxes <> + ptext (sLit "[]") <> semi, + ptext (sLit "hs_hpc_module") <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ + bytesFS (moduleNameFS (Module.moduleName this_mod))) + package_name = hcat (map (text.charToC) $ + bytesFS (packageIdFS (modulePackageId this_mod))) + full_name_str + | modulePackageId this_mod == mainPackageId + = module_name + | otherwise + = package_name <> char '/' <> module_name +\end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 142f695..37a3cf9 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -105,10 +105,14 @@ deSugar hsc_env ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects + ; let hpc_init + | opt_Hpc = hpcInitCode mod ds_hpc_info + | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects - , ds_fords, ds_hpc_info, modBreaks) } + , ds_fords `appendStubC` hpc_init + , ds_hpc_info, modBreaks) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 58bf6b8..a5bf2b6 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do core_body, exprFreeVars core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _) - = dsCmdDo ids local_vars env_ids res_ty stmts body +dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) + = dsCmdDo ids local_vars env_ids res_ty stmts -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A | xs |- ci :: [tsi] ti @@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- so don't pull on it too early -> Type -- return type of the statement -> [LStmt Id] -- statements to desugar - -> LHsExpr Id -- body -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo ids local_vars env_ids res_ty [] body +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 env_ids res_ty (stmt:stmts) body = do +dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = 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 body + (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 return (do_compose ids @@ -674,7 +675,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 env_ids out_ids (ExprStmt cmd _ _ c_ty) = 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)) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 1781aef..4088e44 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -325,26 +325,12 @@ dsExpr (HsLet binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts body result_ty) - = -- Special case for list comprehensions - dsListComp stmts body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - -dsExpr (HsDo DoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo GhciStmt stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo MDoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo PArrComp stmts body result_ty) - = -- Special case for array comprehensions - dsPArrComp (map unLoc stmts) body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -708,25 +694,20 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsDo stmts body result_ty +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts = goL stmts where - -- result_ty must be of the form (m b) - (m_ty, _b_ty) = tcSplitAppTy result_ty - - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (ExprStmt rhs then_expr _) stmts + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty - _ -> return () + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } @@ -750,29 +731,29 @@ dsDo stmts body result_ty go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_rec_rets = rec_rets }) stmts + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = ASSERT( length rec_ids > 0 ) goL (new_bind_stmt : stmts) where - -- returnE <- dsExpr return_id - -- mfixE <- dsExpr mfix_id - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app - bind_op + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup 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 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 - body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case + 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 + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls @@ -790,104 +771,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++ showSDoc (ppr (getLoc pat)) \end{code} -Translation for RecStmt's: ------------------------------ -We turn (RecStmt [v1,..vn] stmts) into: - - (v1,..,vn) <- mfix (\~(v1,..vn). do stmts - return (v1,..vn)) - -\begin{code} -{- -dsMDo :: HsStmtContext Name - -> [(Name,Id)] - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsMDo ctxt tbl stmts body result_ty - = goL stmts - where - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - return_id = lookupEvidence tbl returnMName - bind_id = lookupEvidence tbl bindMName - then_id = lookupEvidence tbl thenMName - fail_id = lookupEvidence tbl failMName - - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (ExprStmt rhs then_expr rhs_ty) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs m_ty rhs_ty - ; then_expr2 <- dsExpr then_expr - ; rest <- goL stmts - ; return (mkApps then_expr2 [rhs2, rest]) } - - go _ (BindStmt pat rhs bind_op _) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat - result_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op [rhs', Lam var match_code]) } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts - = ASSERT( length rec_ids > 0 ) - ASSERT( length rec_ids == length rec_rets ) - ASSERT( isEmptyTcEvBinds _ev_binds ) - pprTrace "dsMDo" (ppr later_ids) $ - goL (new_bind_stmt : stmts) - where - new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app - bind_op noSyntaxExpr - - -- Remove the later_ids that appear (without fancy coercions) - -- in rec_rets, because there's no need to knot-tie them separately - -- See Note [RecStmt] in HsExpr - later_ids' = filter (`notElem` mono_rec_ids) later_ids - mono_rec_ids = [ id | HsVar id <- rec_rets ] - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - - -- The rec_tup_pat must bind the rec_ids only; remember that the - -- trimmed_laters may share the same Names - -- Meanwhile, the later_pats must bind the later_vars - rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids - later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids - rets = map nlHsVar later_ids' ++ map noLoc rec_rets - - mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats - body = noLoc $ HsDo ctxt rec_stmts return_app body_ty - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - - mk_wild_pat :: Id -> LPat Id - mk_wild_pat v = noLoc $ WildPat $ idType v - - mk_later_pat :: Id -> LPat Id - mk_later_pat v | v `elem` later_ids' = mk_wild_pat v - | otherwise = nlVarPat v - - mk_tup_pat :: [LPat Id] -> LPat Id - mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed --} -\end{code} - %************************************************************************ %* * @@ -927,30 +810,34 @@ conversionNames \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc -unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") wrongMonadBind :: LHsExpr Id -> Type -> SDoc -wrongMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +wrongMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") \end{code} diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index a7260e2..d3fcf76 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -106,11 +106,11 @@ matchGuards [] _ rhs _ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings -matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty +matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index cd22b8f..aabd6b0 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -3,9 +3,10 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -Desugaring list comprehensions and array comprehensions +Desugaring list comprehensions, monad comprehensions and array comprehensions \begin{code} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -13,11 +14,11 @@ Desugaring list comprehensions and array comprehensions -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module DsListComp ( dsListComp, dsPArrComp ) where +module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) import HsSyn import TcHsSyn @@ -37,6 +38,7 @@ import PrelNames import SrcLoc import Outputable import FastString +import TcType \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -47,12 +49,14 @@ There will be at least one ``qualifier'' in the input. \begin{code} dsListComp :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of list elements + -> Type -- Type of entire list -> DsM CoreExpr -dsListComp lquals body elt_ty = do +dsListComp lquals res_ty = do dflags <- getDOptsDs let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags -- Either rules are switched off, or we are ignoring what there are; @@ -60,8 +64,8 @@ dsListComp lquals body elt_ty = do -- Wadler-style desugaring || isParallelComp quals -- Foldr-style desugaring can't handle parallel list comprehensions - then deListComp quals body (mkNilExpr elt_ty) - else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body) + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) -- Foldr/build should be enabled, so desugar -- into foldrs and builds @@ -72,92 +76,69 @@ dsListComp lquals body elt_ty = do -- mix of possibly a single element in length, so we do this to leave the possibility open isParallelComp = any isParallelStmt - isParallelStmt (ParStmt _) = True - isParallelStmt _ = False + isParallelStmt (ParStmt _ _ _ _) = True + isParallelStmt _ = False -- This function lets you desugar a inner list comprehension and a list of the binders -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type) -dsInnerListComp (stmts, bndrs) = do - expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type - return (expr, bndrs_tuple_type) - where - bndrs_types = map idType bndrs - bndrs_tuple_type = mkBigCoreTupTy bndrs_types - +dsInnerListComp (stmts, bndrs) + = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) + (mkListTy bndrs_tuple_type) + ; return (expr, bndrs_tuple_type) } + where + bndrs_tuple_type = mkBigCoreVarTupTy bndrs --- This function factors out commonality between the desugaring strategies for TransformStmt. --- Given such a statement it gives you back an expression representing how to compute the transformed --- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) - = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders) - ; usingExpr' <- dsLExpr usingExpr - - ; using_args <- - case maybeByExpr of - Nothing -> return [expr] - Just byExpr -> do - byExpr' <- dsLExpr byExpr - - us <- newUniqueSupply - [tuple_binder] <- newSysLocalsDs [binders_tuple_type] - let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder) - - return [Lam tuple_binder byExprWrapper, expr] - - ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args) - pat = mkBigLHsVarPatTup binders - ; return (inner_list_expr, pat) } - -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsGroupStmt (GroupStmt stmts binderMap by using) = do - let (fromBinders, toBinders) = unzip binderMap - - fromBindersTypes = map idType fromBinders - toBindersTypes = map idType toBinders - - toBindersTupleType = mkBigCoreTupTy toBindersTypes +dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders) + (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr (either id noLoc using) + usingExpr' <- dsLExpr using usingArgs <- case by of Nothing -> return [expr] Just by_e -> do { by_e' <- dsLExpr by_e - ; us <- newUniqueSupply - ; [from_tup_id] <- newSysLocalsDs [from_tup_ty] - ; let by_wrap = mkTupleCase us fromBinders by_e' - from_tup_id (Var from_tup_id) - ; return [Lam from_tup_id by_wrap, expr] } + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } -- Create an unzip function for the appropriate arity and element types and find "map" - (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes + unzip_stuff <- mkUnzipBind form from_bndrs_tys map_id <- dsLookupGlobalId mapName -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs) + inner_list_expr = mkApps usingExpr' usingArgs -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! - unzipped_inner_list_expr = mkApps (Var map_id) - [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr] -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr - - -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values - let pat = mkBigLHsVarPatTup toBinders + bound_unzipped_inner_list_expr + = case unzip_stuff of + Nothing -> inner_list_expr + Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn + , inner_list_expr] + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTup to_bndrs return (bound_unzipped_inner_list_expr, pat) - \end{code} %************************************************************************ @@ -226,53 +207,50 @@ with the Unboxed variety. \begin{code} -deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr - -deListComp (ParStmt stmtss_w_bndrs : quals) body list - = do - exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs - let (exps, qual_tys) = unzip exps_and_qual_tys - - (zip_fn, zip_rhs) <- mkZipBind qual_tys +deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr - -- Deal with [e | pat <- zip l1 .. ln] in example above - deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) - quals body list +deListComp [] _ = panic "deListComp" - where - bndrs_s = map snd stmtss_w_bndrs - - -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = mkBigLHsPatTup pats - pats = map mkBigLHsVarPatTup bndrs_s - - -- Last: the one to return -deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above - core_body <- dsLExpr body - return (mkConsExpr (exprType core_body) core_body list) +deListComp (LastStmt body _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } -- Non-last: must be a guard -deListComp (ExprStmt guard _ _ : quals) body list = do -- rule B above +deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above core_guard <- dsLExpr guard - core_rest <- deListComp quals body list + core_rest <- deListComp quals list return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) body list = do - core_rest <- deListComp quals body list +deListComp (LetStmt binds : quals) list = do + core_rest <- deListComp quals list dsLocalBinds binds core_rest -deListComp (stmt@(TransformStmt {}) : quals) body list = do - (inner_list_expr, pat) <- dsTransformStmt stmt - deBindComp pat inner_list_expr quals body list +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list -deListComp (stmt@(GroupStmt {}) : quals) body list = do - (inner_list_expr, pat) <- dsGroupStmt stmt - deBindComp pat inner_list_expr quals body list - -deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above +deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExpr list1 - deBindComp pat core_list1 quals body core_list2 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list } + where + bndrs_s = map snd stmtss_w_bndrs + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTup pats + pats = map mkBigLHsVarPatTup bndrs_s \end{code} @@ -280,10 +258,9 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov deBindComp :: OutPat Id -> CoreExpr -> [Stmt Id] - -> LHsExpr Id -> CoreExpr -> DsM (Expr Id) -deBindComp pat core_list1 quals body core_list2 = do +deBindComp pat core_list1 quals core_list2 = do let u3_ty@u1_ty = exprType core_list1 -- two names, same thing @@ -300,7 +277,7 @@ deBindComp pat core_list1 quals body core_list2 = do core_fail = App (Var h) (Var u3) letrec_body = App (Var h) core_list1 - rest_expr <- deListComp quals body core_fail + rest_expr <- deListComp quals core_fail core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail let @@ -335,48 +312,43 @@ TE[ e | p <- l , q ] c n = let \begin{code} dfListComp :: Id -> Id -- 'c' and 'n' -> [Stmt Id] -- the rest of the qual's - -> LHsExpr Id -> DsM CoreExpr - -- Last: the one to return -dfListComp c_id n_id [] body = do - core_body <- dsLExpr body - return (mkApps (Var c_id) [core_body, Var n_id]) +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt body _ : quals) + = ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard -dfListComp c_id n_id (ExprStmt guard _ _ : quals) body = do +dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do core_guard <- dsLExpr guard - core_rest <- dfListComp c_id n_id quals body + core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt binds : quals) body = do +dfListComp c_id n_id (LetStmt binds : quals) = do -- new in 1.3, local bindings - core_rest <- dfListComp c_id n_id quals body + core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest -dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do - (inner_list_expr, pat) <- dsTransformStmt stmt - -- Anyway, we bind the newly transformed list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals body - -dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do - (inner_list_expr, pat) <- dsGroupStmt stmt +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt -- Anyway, we bind the newly grouped list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals body + dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do +dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 -- Do the rest of the work in the generic binding builder - dfBindComp c_id n_id (pat, core_list1) quals body + dfBindComp c_id n_id (pat, core_list1) quals dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat Id, CoreExpr) -> [Stmt Id] -- the rest of the qual's - -> LHsExpr Id -> DsM CoreExpr -dfBindComp c_id n_id (pat, core_list1) quals body = do +dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type let x_ty = hsLPatType pat b_ty = idType n_id @@ -385,7 +357,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do [b, x] <- newSysLocalsDs [b_ty, x_ty] -- build rest of the comprehesion - core_rest <- dfListComp c_id b quals body + core_rest <- dfListComp c_id b quals -- build the pattern match core_expr <- matchSimply (Var x) (StmtCtxt ListComp) @@ -439,7 +411,7 @@ mkZipBind elt_tys = do -- Increasing order of tag -mkUnzipBind :: [Type] -> DsM (Id, CoreExpr) +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) -- mkUnzipBind [t1, t2] -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) -- -> case ax of @@ -449,28 +421,29 @@ mkUnzipBind :: [Type] -> DsM (Id, CoreExpr) -- ys) -- -- We use foldr here in all cases, even if rules are turned off, because we may as well! -mkUnzipBind elt_tys = do - ax <- newSysLocalDs elt_tuple_ty - axs <- newSysLocalDs elt_list_tuple_ty - ys <- newSysLocalDs elt_tuple_list_ty - xs <- mapM newSysLocalDs elt_tys - xss <- mapM newSysLocalDs elt_list_tys +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalDs elt_tuple_ty + ; axs <- newSysLocalDs elt_list_tuple_ty + ; ys <- newSysLocalDs elt_tuple_list_ty + ; xs <- mapM newSysLocalDs elt_tys + ; xss <- mapM newSysLocalDs elt_list_tys - unzip_fn <- newSysLocalDs unzip_fn_ty - - [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - - let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) - - concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) - tupled_concat_expression = mkBigCoreTup concat_expressions - - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case - - unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) - return (unzip_fn, mkLams [ys] unzip_body) + ; unzip_fn <- newSysLocalDs unzip_fn_ty + + ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) + folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } where elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_list_ty = mkListTy elt_tuple_ty @@ -480,9 +453,6 @@ mkUnzipBind elt_tys = do unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail - - - \end{code} %************************************************************************ @@ -498,11 +468,10 @@ mkUnzipBind elt_tys = do -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- dsPArrComp :: [Stmt Id] - -> LHsExpr Id - -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr -dsPArrComp [ParStmt qss] body _ = -- parallel comprehension - dePArrParComp qss body + +-- Special case for parallel comprehension +dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- Special case for simple generators: -- @@ -513,7 +482,7 @@ dsPArrComp [ParStmt qss] body _ = -- parallel comprehension -- <<[:e' | p <- e, qs:]>> = -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) -- -dsPArrComp (BindStmt p e _ _ : qs) body _ = do +dsPArrComp (BindStmt p e _ _ : qs) = do filterP <- dsLookupDPHId filterPName ce <- dsLExpr e let ety'ce = parrElemType ce @@ -523,38 +492,41 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false let gen | isIrrefutableHsPat p = ce | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - dePArrComp qs body p gen + dePArrComp qs p gen -dsPArrComp qs body _ = do -- no ParStmt in `qs' +dsPArrComp qs = do -- no ParStmt in `qs' sglP <- dsLookupDPHId singletonPName let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] - dePArrComp qs body (noLoc $ WildPat unitTy) unitArray + dePArrComp qs (noLoc $ WildPat unitTy) unitArray -- the work horse -- dePArrComp :: [Stmt Id] - -> LHsExpr Id -> LPat Id -- the current generator pattern -> CoreExpr -- the current generator expression -> DsM CoreExpr + +dePArrComp [] _ _ = panic "dePArrComp" + -- -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- -dePArrComp [] e' pa cea = do - mapP <- dsLookupDPHId mapPName - let ty = parrElemType cea - (clam, ty'e') <- deLambda ty pa e' - return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] +dePArrComp (LastStmt e' _ : quals) pa cea + = ASSERT( null quals ) + do { mapP <- dsLookupDPHId mapPName + ; let ty = parrElemType cea + ; (clam, ty'e') <- deLambda ty pa e' + ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] } -- -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- -dePArrComp (ExprStmt b _ _ : qs) body pa cea = do +dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do filterP <- dsLookupDPHId filterPName let ty = parrElemType cea (clam,_) <- deLambda ty pa b - dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea]) + dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) -- -- <<[:e' | p <- e, qs:]>> pa ea = @@ -569,7 +541,7 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do -- in -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- -dePArrComp (BindStmt p e _ _ : qs) body pa cea = do +dePArrComp (BindStmt p e _ _ : qs) pa cea = do filterP <- dsLookupDPHId filterPName crossMapP <- dsLookupDPHId crossMapPName ce <- dsLExpr e @@ -585,7 +557,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do let ety'cef = ety'ce -- filter doesn't change the element type pa' = mkLHsPatTup [pa, p] - dePArrComp qs body pa' (mkApps (Var crossMapP) + dePArrComp qs pa' (mkApps (Var crossMapP) [Type ety'cea, Type ety'cef, cea, clam]) -- -- <<[:e' | let ds, qs:]>> pa ea = @@ -594,7 +566,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt ds : qs) body pa cea = do +dePArrComp (LetStmt ds : qs) pa cea = do mapP <- dsLookupDPHId mapPName let xs = collectLocalBinders ds ty'cea = parrElemType cea @@ -609,14 +581,14 @@ dePArrComp (LetStmt ds : qs) body pa cea = do ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] proj = mkLams [v] ccase - dePArrComp qs body pa' (mkApps (Var mapP) + dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, Type errTy, proj, cea]) -- -- The parser guarantees that parallel comprehensions can only appear as -- singeltons qualifier lists, which we already special case in the caller. -- So, encountering one here is a bug. -- -dePArrComp (ParStmt _ : _) _ _ _ = +dePArrComp (ParStmt _ _ _ _ : _) _ _ = panic "DsListComp.dePArrComp: malformed comprehension AST" -- <<[:e' | qs | qss:]>> pa ea = @@ -625,17 +597,17 @@ dePArrComp (ParStmt _ : _) _ _ _ = -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr -dePArrParComp qss body = do +dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr +dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss - dePArrComp [] body pQss ceQss + dePArrComp quals pQss ceQss where deParStmt [] = -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = do -- first statement let res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs) res_expr undefined + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) parStmts qss (mkLHsVarPatTup xs) cqs --- parStmts [] pa cea = return (pa, cea) @@ -644,7 +616,7 @@ dePArrParComp qss body = do let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs) res_expr undefined + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] parStmts qss pa' cea' @@ -682,3 +654,222 @@ parrElemType e = _ -> panic "DsListComp.parrElemType: not a parallel array type" \end{code} + +Translation for monad comprehensions + +\begin{code} +-- Entry point for monad comprehension desugaring +dsMonadComp :: [LStmt Id] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [LStmt Id] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr + +dsMcStmt (LastStmt body ret_op) stmts + = ASSERT( null stmts ) + do { body' <- dsLExpr body + ; ret_op' <- dsExpr ret_op + ; return (App ret_op' body') } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' bind_op fail_op stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts + = do { exp' <- dsLExpr exp + ; guard_exp' <- dsExpr guard_exp + ; then_exp' <- dsExpr then_exp + ; rest <- dsMcStmts stmts + ; return $ mkApps then_exp' [ mkApps guard_exp' [exp'] + , rest ] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + from_bndr_tys = map idType from_bndrs -- Types ty + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; bind_op' <- dsExpr bind_op + ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 + n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c) + tup_n_ty = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var <- newSysLocalDs n_tup_ty + ; tup_n_var <- newSysLocalDs tup_n_ty + ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs + body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr + + ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let -- The pattern variables + pats = map (mkBigLHsVarPatTup . snd) pairs + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } + where + ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op + ; return (exp, tup_ty) } + where + mono_ret_op = HsWrap (WpTyApp tup_ty) return_op + tup_ty = mkBigCoreVarTupTy bndrs + +dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { us <- newUniqueSupply + ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat Id + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr Id + -> SyntaxExpr Id + -> [LStmt Id] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op stmts + = do { body <- dsMcStmts stmts + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op' [rhs', Lam var match_code]) } + + where + -- In a monad comprehension expression, pattern-match failure just calls + -- the monadic `fail` rather than throwing an exception + handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") + + mk_fail_msg :: Located e -> String + mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++ + showSDoc (ppr (getLoc pat)) + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [LStmt Id] + -> [Id] -- Return a tuple of these variables + -> HsExpr Id -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)]) + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> SyntaxExpr TcId -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- mapM newSysLocalDs elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (elt_tys !! i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } +\end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index e34c696..e68173a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -721,23 +721,19 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt sts body _) +repE e@(HsDo ctxt sts _) | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); + e' <- repDoE (nonEmptyCoreList zs); wrapGenSyms ss e' } | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repComp (nonEmptyCoreList (zs ++ [ret])); + e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } | otherwise - = notHandled "mdo and [: :]" (ppr e) + = notHandled "mdo, monad comprehension and [: :]" (ppr e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) @@ -817,7 +813,7 @@ repGuards other wrapGenSyms (concat xs) gd } where process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) - process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2)) + process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2)) = do { x <- repLNormalGE e1 e2; return ([], x) } process (L _ (GRHS ss rhs)) @@ -876,7 +872,7 @@ repSts (LetStmt bs : ss) = ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e _ _ : ss) = +repSts (ExprStmt e _ _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 5c6b224..15c5a55 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -522,7 +522,7 @@ tidy1 _ (LitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form tidy1 _ (NPat lit mb_neg eq) - = return (idDsWrapper, tidyNPat lit mb_neg eq) + = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) -- BangPatterns: Pattern matching is already strict in constructors, -- tuples etc, so the last case strips off the bang for thoses patterns. diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 5e5e81d..be112e0 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -152,8 +152,14 @@ tidyLitPat (HsString s) tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id -tidyNPat (OverLit val False _ ty) mb_neg _ +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Pat Id +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -169,7 +175,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _ | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit) | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit) | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit) - | isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit) + | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit) where mk_con_pat :: DataCon -> HsLit -> Pat Id mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) @@ -193,7 +199,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _ (Nothing, HsIsString s) -> Just s _ -> Nothing -tidyNPat over_lit mb_neg eq +tidyNPat _ over_lit mb_neg eq = NPat over_lit mb_neg eq \end{code} diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 32d13f8..18a06b0 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -36,11 +36,6 @@ Flag ghci Default: False Manual: True -Flag ncg - Description: Build the NCG. - Default: False - Manual: True - Flag stage1 Description: Is this stage 1? Default: False @@ -88,9 +83,6 @@ Library CPP-Options: -DGHCI Include-Dirs: ../libffi/build/include - if !flag(ncg) - CPP-Options: -DOMIT_NATIVE_CODEGEN - Build-Depends: bin-package-db Build-Depends: hoopl @@ -350,6 +342,7 @@ Library TysPrim TysWiredIn CostCentre + ProfInit SCCfinal RnBinds RnEnv @@ -489,10 +482,7 @@ Library Vectorise.Exp Vectorise - -- We only need to expose more modules as some of the ncg code is used - -- by the LLVM backend so its always included - if flag(ncg) - Exposed-Modules: + Exposed-Modules: AsmCodeGen TargetReg NCGMonad @@ -502,10 +492,6 @@ Library RegClass PIC Platform - Alpha.Regs - Alpha.RegInfo - Alpha.Instr - Alpha.CodeGen X86.Regs X86.RegInfo X86.Instr diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 0def1c1..2254332 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -49,8 +49,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo '{-# LANGUAGE CPP #-}' >> $@ @echo 'module Config where' >> $@ @echo >> $@ - @echo 'import Distribution.System' >> $@ - @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @@ -60,42 +58,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cTargetPlatformString :: String' >> $@ @echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@ @echo >> $@ -# Sync this with checkArch in configure.ac - @echo 'cTargetArch :: Arch' >> $@ - @echo '#if i386_TARGET_ARCH' >> $@ - @echo 'cTargetArch = I386' >> $@ - @echo '#elif x86_64_TARGET_ARCH' >> $@ - @echo 'cTargetArch = X86_64' >> $@ - @echo '#elif powerpc_TARGET_ARCH' >> $@ - @echo 'cTargetArch = PPC' >> $@ - @echo '#elif powerpc64_TARGET_ARCH' >> $@ - @echo 'cTargetArch = PPC64' >> $@ - @echo '#elif sparc_TARGET_ARCH || sparc64_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Sparc' >> $@ - @echo '#elif arm_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Arm' >> $@ - @echo '#elif mips_TARGET_ARCH || mipseb_TARGET_ARCH || mipsel_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Mips' >> $@ - @echo '#elif 0' >> $@ - @echo 'cTargetArch = SH' >> $@ - @echo '#elif ia64_TARGET_ARCH' >> $@ - @echo 'cTargetArch = IA64' >> $@ - @echo '#elif s390_TARGET_ARCH' >> $@ - @echo 'cTargetArch = S390' >> $@ - @echo '#elif alpha_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Alpha' >> $@ - @echo '#elif hppa_TARGET_ARCH || hppa1_1_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Hppa' >> $@ - @echo '#elif rs6000_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Rs6000' >> $@ - @echo '#elif m68k_TARGET_ARCH' >> $@ - @echo 'cTargetArch = M68k' >> $@ - @echo '#elif vax_TARGET_ARCH' >> $@ - @echo 'cTargetArch = Vax' >> $@ - @echo '#else' >> $@ - @echo '#error Unknown target arch' >> $@ - @echo '#endif' >> $@ - @echo >> $@ @echo 'cProjectName :: String' >> $@ @echo 'cProjectName = "$(ProjectName)"' >> $@ @echo 'cProjectVersion :: String' >> $@ @@ -108,8 +70,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cBooterVersion = "$(GhcVersion)"' >> $@ @echo 'cStage :: String' >> $@ @echo 'cStage = show (STAGE :: Int)' >> $@ - @echo 'cCcOpts :: [String]' >> $@ - @echo 'cCcOpts = words "$(CONF_CC_OPTS_STAGE$*)"' >> $@ @echo 'cGccLinkerOpts :: [String]' >> $@ @echo 'cGccLinkerOpts = words "$(CONF_GCC_LINKER_OPTS_STAGE$*)"' >> $@ @echo 'cLdLinkerOpts :: [String]' >> $@ @@ -134,12 +94,12 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ @echo 'cRAWCPP_FLAGS :: String' >> $@ @echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@ - @echo 'cGCC :: String' >> $@ - @echo 'cGCC = "$(WhatGccIsCalled)"' >> $@ @echo 'cMKDLL :: String' >> $@ @echo 'cMKDLL = "$(BLD_DLL)"' >> $@ @echo 'cLdIsGNULd :: String' >> $@ @echo 'cLdIsGNULd = "$(LdIsGNULd)"' >> $@ + @echo 'cLdHasBuildId :: String' >> $@ + @echo 'cLdHasBuildId = "$(LdHasBuildId)"' >> $@ @echo 'cLD_X :: String' >> $@ @echo 'cLD_X = "$(LD_X)"' >> $@ @echo 'cGHC_DRIVER_DIR :: String' >> $@ @@ -152,10 +112,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@ @echo 'cGHC_UNLIT_DIR :: String' >> $@ @echo 'cGHC_UNLIT_DIR = "$(GHC_UNLIT_DIR)"' >> $@ - @echo 'cGHC_MANGLER_PGM :: String' >> $@ - @echo 'cGHC_MANGLER_PGM = "$(GHC_MANGLER_PGM)"' >> $@ - @echo 'cGHC_MANGLER_DIR :: String' >> $@ - @echo 'cGHC_MANGLER_DIR = "$(GHC_MANGLER_DIR)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @echo 'cGHC_SPLIT_PGM = "$(GHC_SPLIT_PGM)"' >> $@ @echo 'cGHC_SPLIT_DIR :: String' >> $@ @@ -164,8 +120,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cGHC_SYSMAN_PGM = "$(GHC_SYSMAN)"' >> $@ @echo 'cGHC_SYSMAN_DIR :: String' >> $@ @echo 'cGHC_SYSMAN_DIR = "$(GHC_SYSMAN_DIR)"' >> $@ - @echo 'cGHC_PERL :: String' >> $@ - @echo 'cGHC_PERL = "$(GHC_PERL)"' >> $@ @echo 'cDEFAULT_TMPDIR :: String' >> $@ @echo 'cDEFAULT_TMPDIR = "$(DEFAULT_TMPDIR)"' >> $@ @echo 'cRelocatableBuild :: Bool' >> $@ @@ -379,12 +333,6 @@ endif endif -ifeq "$(GhcWithNativeCodeGen)" "NO" -# XXX This should logically be a CPP option, but there doesn't seem to -# be a flag for that -compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN -endif - ifeq "$(TargetOS_CPP)" "openbsd" compiler_CONFIGURE_OPTS += --ld-options=-E endif @@ -495,6 +443,18 @@ compiler_stage1_HC_OPTS += $(GhcStage1HcOpts) compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) +ifeq "$(GhcStage1DefaultNewCodegen)" "YES" +compiler_stage1_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage2DefaultNewCodegen)" "YES" +compiler_stage2_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage3DefaultNewCodegen)" "YES" +compiler_stage3_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + ifneq "$(BINDIST)" "YES" compiler_stage2_TAGS_HC_OPTS = -package ghc diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index dfc77e5..af9fbe9 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -30,7 +30,9 @@ import PrimOp import Constants import FastString import SMRep +import DynFlags import Outputable +import Platform import Control.Monad ( foldM ) import Control.Monad.ST ( runST ) @@ -113,14 +115,14 @@ instance Outputable UnlinkedBCO where -- bytecode address in this BCO. -- Top level assembler fn. -assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode -assembleBCOs proto_bcos tycons +assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs dflags proto_bcos tycons = do itblenv <- mkITbls tycons - bcos <- mapM assembleBCO proto_bcos + bcos <- mapM (assembleBCO dflags) proto_bcos return (ByteCode bcos itblenv) -assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) +assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = let -- pass 1: collect up the offsets of the local labels. -- Remember that the first insn starts at offset @@ -152,7 +154,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) ptrs <- return emptySS :: IO (SizedSeq BCOPtr) let init_asm_state = (insns,lits,ptrs) (final_insns, final_lits, final_ptrs) - <- mkBits findLabel init_asm_state instrs + <- mkBits dflags findLabel init_asm_state instrs let asm_insns = ssElts final_insns n_insns = sizeSS final_insns @@ -228,12 +230,13 @@ largeArg w | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" -- This is where all the action is (pass 2 of the assembler) -mkBits :: (Word16 -> Word) -- label finder +mkBits :: DynFlags + -> (Word16 -> Word) -- label finder -> AsmState -> [BCInstr] -- instructions (in) -> IO AsmState -mkBits findLabel st proto_insns +mkBits dflags findLabel st proto_insns = foldM doInstr st proto_insns where doInstr :: AsmState -> BCInstr -> IO AsmState @@ -247,14 +250,14 @@ mkBits findLabel st proto_insns instr2 st2 bci_PUSH_G p PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op) instr2 st2 bci_PUSH_G p - PUSH_BCO proto -> do ul_bco <- assembleBCO proto + PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_G p - PUSH_ALTS proto -> do ul_bco <- assembleBCO proto + PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_ALTS p PUSH_ALTS_UNLIFTED proto pk -> do - ul_bco <- assembleBCO proto + ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 (push_alts pk) p PUSH_UBX (Left lit) nws @@ -395,12 +398,11 @@ mkBits findLabel st proto_insns = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon)) return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) -#ifdef mingw32_TARGET_OS literal st (MachLabel fs (Just sz) _) + | platformOS (targetPlatform dflags) == OSMinGW32 = litlabel st (appendFS fs (mkFastString ('@':show sz))) -- On Windows, stdcall labels have a suffix indicating the no. of -- arg words, e.g. foo@8. testcase: ffi012(ghci) -#endif literal st (MachLabel fs _ _) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index f34ac9c..b888747 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -30,9 +30,7 @@ import CoreFVs import Type import DataCon import TyCon --- import Type import Util --- import DataCon import Var import VarSet import TysPrim @@ -50,38 +48,36 @@ import Data.List import Foreign import Foreign.C --- import GHC.Exts ( Int(..) ) - -import Control.Monad ( when ) +import Control.Monad import Data.Char import UniqSupply import BreakArray import Data.Maybe -import Module -import IdInfo +import Module +import IdInfo import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map -- ----------------------------------------------------------------------------- --- Generating byte code for a complete module +-- Generating byte code for a complete module byteCodeGen :: DynFlags -> [CoreBind] - -> [TyCon] - -> ModBreaks + -> [TyCon] + -> ModBreaks -> IO CompiledByteCode -byteCodeGen dflags binds tycs modBreaks +byteCodeGen dflags binds tycs modBreaks = do showPass dflags "ByteCodeGen" - let flatBinds = [ (bndr, freeVars rhs) - | (bndr, rhs) <- flattenBinds binds] + let flatBinds = [ (bndr, freeVars rhs) + | (bndr, rhs) <- flattenBinds binds] - us <- mkSplitUniqSupply 'y' - (BcM_State _us _final_ctr mallocd _, proto_bcos) - <- runBc us modBreaks (mapM schemeTopBind flatBinds) + us <- mkSplitUniqSupply 'y' + (BcM_State _us _final_ctr mallocd _, proto_bcos) + <- runBc us modBreaks (mapM schemeTopBind flatBinds) when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -89,15 +85,15 @@ byteCodeGen dflags binds tycs modBreaks dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - assembleBCOs proto_bcos tycs - + assembleBCOs dflags proto_bcos tycs + -- ----------------------------------------------------------------------------- -- Generating byte code for an expression --- Returns: (the root BCO for this expression, +-- Returns: (the root BCO for this expression, -- a list of auxilary BCOs resulting from compiling closures) coreExprToBCOs :: DynFlags - -> CoreExpr + -> CoreExpr -> IO UnlinkedBCO coreExprToBCOs dflags expr = do showPass dflags "ByteCodeGen" @@ -106,11 +102,11 @@ coreExprToBCOs dflags expr -- should be harmless, since it's never used for anything let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - + -- the uniques are needed to generate fresh variables when we introduce new -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' - (BcM_State _us _final_ctr mallocd _ , proto_bco) + (BcM_State _us _final_ctr mallocd _ , proto_bco) <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr)) when (notNull mallocd) @@ -118,7 +114,7 @@ coreExprToBCOs dflags expr dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) - assembleBCO proto_bco + assembleBCO dflags proto_bco -- ----------------------------------------------------------------------------- @@ -152,18 +148,18 @@ mkProtoBCO -> Int -> Word16 -> [StgWord] - -> Bool -- True <=> is a return point, rather than a function + -> Bool -- True <=> is a return point, rather than a function -> [BcPtr] -> ProtoBCO name -mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks +mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { - protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, - protoBCOBitmap = bitmap, - protoBCOBitmapSize = bitmap_size, - protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOPtrs = mallocd_blocks + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOPtrs = mallocd_blocks } where -- Overestimate the stack usage (in words) of this BCO, @@ -174,17 +170,17 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. maybe_with_stack_check - | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d - -- don't do stack checks at return points, - -- everything is aggregated up to the top BCO - -- (which must be a function). + | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). -- That is, unless the stack usage is >= AP_STACK_SPLIM, -- see bug #1466. | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH = STKCHECK stack_usage : peep_d | otherwise - = peep_d -- the supposedly common case - + = peep_d -- the supposedly common case + -- We assume that this sum doesn't wrap stack_usage = sum (map bciStackUse peep_d) @@ -214,19 +210,19 @@ argBits (rep : args) schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) +schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do - -- Special case for the worker of a nullary data con. - -- It'll look like this: Nil = /\a -> Nil a - -- If we feed it into schemeR, we'll get - -- Nil = Nil - -- because mkConAppCode treats nullary constructor applications - -- by just re-using the single top-level definition. So - -- for the worker itself, we must allocate it directly. + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise = schemeR [{- No free variables -}] (id, rhs) @@ -242,13 +238,13 @@ schemeTopBind (id, rhs) -- -- Park the resulting BCO in the monad. Also requires the -- variable to which this value was bound, so as to give the --- resulting BCO a name. +-- resulting BCO a name. -schemeR :: [Id] -- Free vars of the RHS, ordered as they - -- will appear in the thunk. Empty for - -- top-level things, which have no free vars. - -> (Id, AnnExpr Id VarSet) - -> BcM (ProtoBCO Name) +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Id, AnnExpr Id VarSet) + -> BcM (ProtoBCO Name) schemeR fvs (nm, rhs) {- | trace (showSDoc ( @@ -269,40 +265,40 @@ collect (_, e) = go [] e go xs (AnnLam x (_,e)) = go (x:xs) e go xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) +schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) - = let - all_args = reverse args ++ fvs - arity = length all_args - -- all_args are the args in reverse order. We're compiling a function - -- \fv1..fvn x1..xn -> e - -- i.e. the fvs come first + = let + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first szsw_args = map (fromIntegral . idSizeW) all_args szw_args = sum szsw_args p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) - -- make the arg bitmap - bits = argBits (reverse (map idCgRep all_args)) - bitmap_size = genericLength bits - bitmap = mkBitmap bits + -- make the arg bitmap + bits = argBits (reverse (map idCgRep all_args)) + bitmap_size = genericLength bits + bitmap = mkBitmap bits in do - body_code <- schemeER_wrk szw_args p_init body - + body_code <- schemeER_wrk szw_args p_init body + emitBc (mkProtoBCO (getName nm) body_code (Right original_body) - arity bitmap_size bitmap False{-not alts-}) + arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList schemeER_wrk d p rhs - | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do - code <- schemeE d 0 p newRhs - arr <- getBreakArray + | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do + code <- schemeE d 0 p newRhs + arr <- getBreakArray let idOffSets = getVarOffSets d p tickInfo let tickNumber = tickInfo_number tickInfo - let breakInfo = BreakInfo + let breakInfo = BreakInfo { breakInfo_module = tickInfo_module tickInfo - , breakInfo_number = tickNumber + , breakInfo_number = tickNumber , breakInfo_vars = idOffSets , breakInfo_resty = exprType (deAnnotate' newRhs) } @@ -310,15 +306,15 @@ schemeER_wrk d p rhs BA arr# -> BRK_FUN arr# (fromIntegral tickNumber) breakInfo return $ breakInstr `consOL` code - | otherwise = schemeE d 0 p rhs + | otherwise = schemeE d 0 p rhs getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)] -getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals +getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16) -getOffSet d env id +getOffSet d env id = case lookupBCEnv_maybe id env of - Nothing -> Nothing + Nothing -> Nothing Just offset -> Just (id, d - offset) fvsToEnv :: BCEnv -> VarSet -> [Id] @@ -330,22 +326,22 @@ fvsToEnv :: BCEnv -> VarSet -> [Id] -- -- The code that constructs the thunk, and the code that executes -- it, have to agree about this layout -fvsToEnv p fvs = [v | v <- varSetElems fvs, - isId v, -- Could be a type variable - v `Map.member` p] +fvsToEnv p fvs = [v | v <- varSetElems fvs, + isId v, -- Could be a type variable + v `Map.member` p] -- ----------------------------------------------------------------------------- -- schemeE -data TickInfo - = TickInfo +data TickInfo + = TickInfo { tickInfo_number :: Int -- the (module) unique number of the tick - , tickInfo_module :: Module -- the origin of the ticked expression + , tickInfo_module :: Module -- the origin of the ticked expression , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression - } + } instance Outputable TickInfo where - ppr info = text "TickInfo" <+> + ppr info = text "TickInfo" <+> parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+> ppr (tickInfo_locals info)) @@ -358,7 +354,7 @@ schemeE d s p e = schemeE d s p e' -- Delegate tail-calls to schemeT. -schemeE d s p e@(AnnApp _ _) +schemeE d s p e@(AnnApp _ _) = schemeT d s p e schemeE d s p e@(AnnVar v) @@ -367,12 +363,12 @@ schemeE d s p e@(AnnVar v) schemeT d s p e | otherwise - = do -- Returning an unlifted value. + = do -- Returning an unlifted value. -- Heave it on the stack, SLIDE, and RETURN. (push, szw) <- pushAtom d p (AnnVar v) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX v_rep) -- go + return (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX v_rep) -- go where v_type = idType v v_rep = typeCgRep v_type @@ -380,17 +376,17 @@ schemeE d s p e@(AnnVar v) schemeE d s p (AnnLit literal) = do (push, szw) <- pushAtom d p (AnnLit literal) let l_rep = typeCgRep (literalType literal) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX l_rep) -- go + return (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX l_rep) -- go schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, Just data_con <- isDataConWorkId_maybe v, dataConRepArity data_con == length args_r_to_l - = do -- Special case for a non-recursive let whose RHS is a - -- saturatred constructor application. - -- Just allocate the constructor and carry on + = do -- Special case for a non-recursive let whose RHS is a + -- saturatred constructor application. + -- Just allocate the constructor and carry on alloc_code <- mkConAppCode d s p data_con args_r_to_l body_code <- schemeE (d+1) s (Map.insert x d p) body return (alloc_code `appOL` body_code) @@ -407,8 +403,8 @@ schemeE d s p (AnnLet binds (_,body)) -- Sizes of free vars sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss - -- the arity of each rhs - arities = map (genericLength . fst . collect) rhss + -- the arity of each rhs + arities = map (genericLength . fst . collect) rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1. d' and p' reflect the stack @@ -421,33 +417,33 @@ schemeE d s p (AnnLet binds (_,body)) -- ToDo: don't build thunks for things with no free variables build_thunk _ [] size bco off arity = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) - where - mkap | arity == 0 = MKAP - | otherwise = MKPAP + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP build_thunk dd (fv:fvs) size bco off arity = do - (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) + (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity return (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 + where mkAlloc sz 0 | is_tick = ALLOC_AP_NOUPD sz | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity sz + mkAlloc sz arity = ALLOC_PAP arity sz - is_tick = case binds of + is_tick = case binds of AnnNonRec id _ -> occNameFS (getOccName id) == tickFS _other -> False - compile_bind d' fvs x rhs size arity off = do - bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off arity + compile_bind d' fvs x rhs size arity off = do + bco <- schemeR fvs (x,rhs) + build_thunk d' fvs size bco off arity - compile_binds = - [ compile_bind d' fvs x rhs size arity n - | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] - ] + compile_binds = + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] in do body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds @@ -464,7 +460,7 @@ schemeE d s p exp@(AnnCase {}) = if isUnLiftedType ty then do -- If the result type is unlifted, then we must generate - -- let f = \s . case tick# of _ -> e + -- let f = \s . case tick# of _ -> e -- in f realWorld# -- When we stop at the breakpoint, _result will have an unlifted -- type and hence won't be bound in the environment, but the @@ -472,7 +468,7 @@ schemeE d s p exp@(AnnCase {}) id <- newId (mkFunTy realWorldStatePrimTy ty) st <- newId realWorldStatePrimTy let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp))) - (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) + (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) (emptyVarSet, AnnVar realWorldPrimId))) schemeE d s p letExp else do @@ -486,42 +482,42 @@ schemeE d s p exp@(AnnCase {}) schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) - -- Convert - -- case .... of x { (# VoidArg'd-thing, a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - -- becuse the return convention for both are identical. - -- - -- Note that it does not matter losing the void-rep thing from the - -- envt (it won't be bound now) because we never look such things up. + -- Convert + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. = --trace "automagic mashing of case alts (# VoidArg, a #)" $ - doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) = --trace "automagic mashing of case alts (# a, VoidArg #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc - -- Similarly, convert - -- case .... of x { (# a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE _ _ _ expr - = pprPanic "ByteCodeGen.schemeE: unhandled case" + = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' expr)) -{- +{- Ticked Expressions ------------------ - + A ticked expression looks like this: case tick var1 ... varN of DEFAULT -> e @@ -535,7 +531,7 @@ schemeE _ _ _ expr otherwise we return Nothing. - The idea is that the "case tick ..." is really just an annotation on + The idea is that the "case tick ..." is really just an annotation on the code. When we find such a thing, we pull out the useful information, and then compile the code as if it was just the expression "e". @@ -544,10 +540,10 @@ schemeE _ _ _ expr isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a) isTickedExp' (AnnCase scrut _bndr _type alts) | Just tickInfo <- isTickedScrut scrut, - [(DEFAULT, _bndr, rhs)] <- alts + [(DEFAULT, _bndr, rhs)] <- alts = Just (tickInfo, rhs) where - isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo + isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo isTickedScrut expr | Var id <- f, Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id @@ -559,7 +555,7 @@ isTickedExp' (AnnCase scrut _bndr _type alts) where (f, args) = collectArgs $ deAnnotate expr idsOfArgs :: [Expr Id] -> [Id] - idsOfArgs = catMaybes . map exprId + idsOfArgs = catMaybes . map exprId exprId :: Expr Id -> Maybe Id exprId (Var id) = Just id exprId _ = Nothing @@ -583,16 +579,16 @@ isTickedExp' _ = Nothing -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. --- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- Split the args into ptrs and non-ptrs, and push the nonptrs, -- then the ptrs, and then do PACK and RETURN. -- -- 4. Otherwise, it must be a function call. Push the args -- right to left, SLIDE and ENTER. schemeT :: Word16 -- Stack depth - -> Sequel -- Sequel depth - -> BCEnv -- stack env - -> AnnExpr' Id VarSet + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> AnnExpr' Id VarSet -> BcM BCInstrList schemeT d s p app @@ -601,13 +597,13 @@ schemeT d s p app -- = panic "schemeT ?!?!" -- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False --- = error "?!?!" +-- = error "?!?!" -- Case 0 | Just (arg, constr_names) <- maybe_is_tagToEnum_call = do (push, arg_words) <- pushAtom d p arg tagToId_sequence <- implement_tagToId constr_names - return (push `appOL` tagToId_sequence + return (push `appOL` tagToId_sequence `appOL` mkSLIDE 1 (d+arg_words-s) `snocOL` ENTER) @@ -619,20 +615,20 @@ schemeT d s p app | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidArgAtom arg1 -> - unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidArgAtom arg2 -> - unboxedTupleReturn d s p arg1 - _other -> unboxedTupleException + [arg1,arg2] | isVoidArgAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVoidArgAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> unboxedTupleException -- Case 3: Ordinary data constructor | Just con <- maybe_saturated_dcon = do alloc_con <- mkConAppCode d s p con args_r_to_l - return (alloc_con `appOL` - mkSLIDE 1 (d - s) `snocOL` - ENTER) + return (alloc_con `appOL` + mkSLIDE 1 (d - s) `snocOL` + ENTER) - -- Case 4: Tail call of function + -- Case 4: Tail call of function | otherwise = doTailCall d s p fn args_r_to_l @@ -641,54 +637,54 @@ schemeT d s p app maybe_is_tagToEnum_call = let extract_constr_Names ty | Just (tyc, _) <- splitTyConApp_maybe (repType ty), - isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.lhs for details. - | otherwise + isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.lhs for details. + | otherwise = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) in case app of (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) -> case isPrimOpId_maybe v of Just TagToEnumOp -> Just (snd arg, extract_constr_Names t) - _ -> Nothing + _ -> Nothing _ -> Nothing - -- Extract the args (R->L) and fn - -- The function will necessarily be a variable, - -- because we are compiling a tail call + -- Extract the args (R->L) and fn + -- The function will necessarily be a variable, + -- because we are compiling a tail call (AnnVar fn, args_r_to_l) = splitApp app -- Only consider this to be a constructor application iff it is -- saturated. Otherwise, we'll call the constructor wrapper. n_args = length args_r_to_l - maybe_saturated_dcon - = case isDataConWorkId_maybe fn of - Just con | dataConRepArity con == n_args -> Just con - _ -> Nothing + maybe_saturated_dcon + = case isDataConWorkId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing -- ----------------------------------------------------------------------------- --- Generate code to build a constructor application, +-- Generate code to build a constructor application, -- leaving it on top of the stack mkConAppCode :: Word16 -> Sequel -> BCEnv - -> DataCon -- The data constructor - -> [AnnExpr' Id VarSet] -- Args, in *reverse* order - -> BcM BCInstrList + -> DataCon -- The data constructor + -> [AnnExpr' Id VarSet] -- Args, in *reverse* order + -> BcM BCInstrList -mkConAppCode _ _ _ con [] -- Nullary constructor +mkConAppCode _ _ _ con [] -- Nullary constructor = ASSERT( isNullaryRepDataCon con ) return (unitOL (PUSH_G (getName (dataConWorkId con)))) - -- Instead of doing a PACK, which would allocate a fresh - -- copy of this constructor, use the single shared version. + -- Instead of doing a PACK, which would allocate a fresh + -- copy of this constructor, use the single shared version. -mkConAppCode orig_d _ p con args_r_to_l +mkConAppCode orig_d _ p con args_r_to_l = ASSERT( dataConRepArity con == length args_r_to_l ) do_pushery orig_d (non_ptr_args ++ ptr_args) where - -- The args are already in reverse order, which is the way PACK - -- expects them to be. We must push the non-ptrs after the ptrs. + -- The args are already in reverse order, which is the way PACK + -- expects them to be. We must push the non-ptrs after the ptrs. (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l do_pushery d (arg:args) @@ -697,8 +693,8 @@ mkConAppCode orig_d _ p con args_r_to_l return (push `appOL` more_push_code) do_pushery d [] = return (unitOL (PACK con n_arg_words)) - where - n_arg_words = d - orig_d + where + n_arg_words = d - orig_d -- ----------------------------------------------------------------------------- @@ -709,42 +705,42 @@ mkConAppCode orig_d _ p con args_r_to_l -- returned, even if it is a pointed type. We always just return. unboxedTupleReturn - :: Word16 -> Sequel -> BCEnv - -> AnnExpr' Id VarSet -> BcM BCInstrList + :: Word16 -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> BcM BCInstrList unboxedTupleReturn d s p arg = do (push, sz) <- pushAtom d p arg - return (push `appOL` - mkSLIDE sz (d-s) `snocOL` - RETURN_UBX (atomRep arg)) + return (push `appOL` + mkSLIDE sz (d-s) `snocOL` + RETURN_UBX (atomRep arg)) -- ----------------------------------------------------------------------------- -- Generate code for a tail-call doTailCall - :: Word16 -> Sequel -> BCEnv - -> Id -> [AnnExpr' Id VarSet] - -> BcM BCInstrList + :: Word16 -> Sequel -> BCEnv + -> Id -> [AnnExpr' Id VarSet] + -> BcM BCInstrList doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do - ASSERT( null reps ) return () + ASSERT( null reps ) return () (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERT( sz == 1 ) return () - return (push_fn `appOL` ( - mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` - unitOL ENTER)) + ASSERT( sz == 1 ) return () + return (push_fn `appOL` ( + mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` + unitOL ENTER)) do_pushes d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps - (these_args, rest_of_args) = splitAt n args + (these_args, rest_of_args) = splitAt n args (next_d, push_code) <- push_seq d these_args - instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps - -- ^^^ for the PUSH_APPLY_ instruction + instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction return (push_code `appOL` (push_apply `consOL` instrs)) push_seq d [] = return (d, nilOL) push_seq d (arg:args) = do - (push_code, sz) <- pushAtom d p arg + (push_code, sz) <- pushAtom d p arg (final_d, more_push_code) <- push_seq (d+sz) args return (final_d, push_code `appOL` more_push_code) @@ -779,10 +775,10 @@ findPushSeq _ -- Case expressions doCase :: Word16 -> Sequel -> BCEnv - -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] - -> Bool -- True <=> is an unboxed tuple case, don't enter the result - -> BcM BCInstrList -doCase d s p (_,scrut) bndr alts is_unboxed_tuple + -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] + -> Bool -- True <=> is an unboxed tuple case, don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) bndr alts is_unboxed_tuple = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. @@ -790,58 +786,58 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- on top of the itbl. ret_frame_sizeW = 2 - -- An unlifted value gets an extra info table pushed on top - -- when it is returned. - unlifted_itbl_sizeW | isAlgCase = 0 - | otherwise = 1 + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_sizeW | isAlgCase = 0 + | otherwise = 1 - -- depth of stack after the return value has been pushed - d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) + -- depth of stack after the return value has been pushed + d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) - -- depth of stack after the extra info table for an unboxed return - -- has been pushed, if any. This is the stack depth at the - -- continuation. + -- depth of stack after the extra info table for an unboxed return + -- has been pushed, if any. This is the stack depth at the + -- continuation. d_alts = d_bndr + unlifted_itbl_sizeW -- Env in which to compile the alts, not including -- any vars bound by the alts themselves p_alts = Map.insert bndr (d_bndr - 1) p - bndr_ty = idType bndr + bndr_ty = idType bndr isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) - = do rhs_code <- schemeE d_alts s p_alts rhs - return (NoDiscr, rhs_code) + codeAlt (DEFAULT, _, (_,rhs)) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) codeAlt alt@(_, bndrs, (_,rhs)) - -- primitive or nullary constructor alt: no need to UNPACK - | null real_bndrs = do - rhs_code <- schemeE d_alts s p_alts rhs + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) - -- algebraic alt with some binders + -- algebraic alt with some binders | otherwise = let - (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs - ptr_sizes = map (fromIntegral . idSizeW) ptrs - nptrs_sizes = map (fromIntegral . idSizeW) nptrs - bind_sizes = ptr_sizes ++ nptrs_sizes - size = sum ptr_sizes + sum nptrs_sizes - -- the UNPACK instruction unpacks in reverse order... - p' = Map.insertList - (zip (reverse (ptrs ++ nptrs)) - (mkStackOffsets d_alts (reverse bind_sizes))) - p_alts - in do + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs + ptr_sizes = map (fromIntegral . idSizeW) ptrs + nptrs_sizes = map (fromIntegral . idSizeW) nptrs + bind_sizes = ptr_sizes ++ nptrs_sizes + size = sum ptr_sizes + sum nptrs_sizes + -- the UNPACK instruction unpacks in reverse order... + p' = Map.insertList + (zip (reverse (ptrs ++ nptrs)) + (mkStackOffsets d_alts (reverse bind_sizes))) + p_alts + in do MASSERT(isAlgCase) - rhs_code <- schemeE (d_alts+size) s p' rhs + rhs_code <- schemeE (d_alts+size) s p' rhs return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code) - where - real_bndrs = filter (not.isTyCoVar) bndrs + where + real_bndrs = filter (not.isTyCoVar) bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) + my_discr (DataAlt dc, _, _) | isUnboxedTupleCon dc = unboxedTupleException | otherwise @@ -854,20 +850,20 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple MachChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) - maybe_ncons + maybe_ncons | not isAlgCase = Nothing - | otherwise + | otherwise = case [dc | (DataAlt dc, _, _) <- alts] of [] -> Nothing (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - -- the bitmap is relative to stack depth d, i.e. before the - -- BCO, info table and return value are pushed on. - -- This bit of code is v. similar to buildLivenessMask in CgBindery, - -- except that here we build the bitmap from the known bindings of - -- things that are pointers, whereas in CgBindery the code builds the - -- bitmap from the free slots and unboxed bindings. - -- (ToDo: merge?) + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) -- -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. -- The bitmap must cover the portion of the stack up to the sequel only. @@ -878,32 +874,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple bitmap_size = d-s bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap bitmap_size'{-size-} + bitmap = intsToReverseBitmap bitmap_size'{-size-} (sortLe (<=) (filter (< bitmap_size') rel_slots)) - where - binds = Map.toList p - rel_slots = map fromIntegral $ concat (map spread binds) - spread (id, offset) - | isFollowableArg (idCgRep id) = [ rel_offset ] - | otherwise = [] - where rel_offset = d - offset - 1 + where + binds = Map.toList p + rel_slots = map fromIntegral $ concat (map spread binds) + spread (id, offset) + | isFollowableArg (idCgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = d - offset - 1 in do alt_stuff <- mapM codeAlt alts alt_final <- mkMultiBranch maybe_ncons alt_stuff - let + let alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) - 0{-no arity-} bitmap_size bitmap True{-is alts-} + 0{-no arity-} bitmap_size bitmap True{-is alts-} -- in -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ --- "\n bitmap = " ++ show bitmap) $ do +-- "\n bitmap = " ++ show bitmap) $ do scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut alt_bco' <- emitBc alt_bco let push_alts - | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) return (push_alts `consOL` scrut_code) @@ -914,17 +910,17 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- deferencing ForeignObj#s and adjusting addrs to point to -- payloads in Ptr/Byte arrays. Then, generate the marshalling -- (machine) code for the ccall, and create bytecodes to call that and --- then return in the right way. +-- then return in the right way. -generateCCall :: Word16 -> Sequel -- stack and sequel depths +generateCCall :: Word16 -> Sequel -- stack and sequel depths -> BCEnv - -> CCallSpec -- where to call - -> Id -- of target, for type info - -> [AnnExpr' Id VarSet] -- args (atoms) + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr' Id VarSet] -- args (atoms) -> BcM BCInstrList generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l - = let + = let -- useful constants addr_sizeW :: Word16 addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg) @@ -935,19 +931,19 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- CgRep of what was actually pushed. pargs _ [] = return [] - pargs d (a:az) + pargs d (a:az) = let arg_ty = repType (exprType (deAnnotate' a)) in case splitTyConApp_maybe arg_ty of -- Don't push the FO; instead push the Addr# it -- contains. - Just (t, _) - | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + Just (t, _) + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a return ((code,AddrRep):rest) - | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a return ((code,AddrRep):rest) @@ -991,18 +987,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of Nothing -> (True, VoidRep) - Just rr -> (False, rr) + Just rr -> (False, rr) {- - Because the Haskell stack grows down, the a_reps refer to + Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call are on the stack. Now push an unboxed Addr# indicating - the C function to call. Then push a dummy placeholder for the - result. Finally, emit a CCALL insn with an offset pointing to the + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the Addr# just pushed, and a literal field holding the mallocville address of the piece of marshalling code we generate. - So, just prior to the CCALL insn, the stack looks like this + So, just prior to the CCALL insn, the stack looks like this (growing down, as usual): - + ... @@ -1010,7 +1006,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l (must be an unboxed type) The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), + in the CCALL insn, passing it (& ), that is, the addr of the topmost word in the stack. When this returns, the placeholder will have been filled in. The placeholder is slid down to the sequel @@ -1053,7 +1049,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- Get the arg reps, zapping the leading Addr# in the dynamic case a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" | is_static = a_reps_pushed_RAW - | otherwise = if null a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW then panic "ByteCodeGen.generateCCall: dyn with no args" else tail a_reps_pushed_RAW @@ -1062,7 +1058,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l | is_static = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW], d_after_args + addr_sizeW) - | otherwise -- is already on the stack + | otherwise -- is already on the stack = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, @@ -1070,17 +1066,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l r_sizeW = fromIntegral (primRepSizeW r_rep) d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep - push_r = (if returns_void - then nilOL + push_r = (if returns_void + then nilOL else unitOL (PUSH_UBX (Left r_lit) r_sizeW)) -- generate the marshalling code we're going to call - -- Offset of the next stack frame down the stack. The CCALL - -- instruction needs to describe the chunk of stack containing - -- the ccall args to the GC, so it needs to know how large it - -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = d_after_r - s + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = d_after_r - s -- in -- the only difference in libffi mode is that we prepare a cif @@ -1119,7 +1115,7 @@ mkDummyLiteral pr _ -> panic "mkDummyLiteral" --- Convert (eg) +-- Convert (eg) -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- @@ -1136,9 +1132,9 @@ mkDummyLiteral pr maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - maybe_r_rep_to_go + maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - (r_tycon, r_reps) + (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of (Just (tyc, tys)) -> (tyc, map typePrimRep tys) Nothing -> blargh @@ -1148,19 +1144,19 @@ maybe_getCCallReturnRep fn_ty && case maybe_r_rep_to_go of Nothing -> True Just r_rep -> r_rep /= PtrRep - -- if it was, it would be impossible - -- to create a valid return value + -- if it was, it would be impossible + -- to create a valid return value -- placeholder on the stack blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" + blargh = pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) - in + in --trace (showSDoc (ppr (a_reps, r_reps))) $ if ok then maybe_r_rep_to_go else blargh -- Compile code which expects an unboxed Int on the top of stack, --- (call it i), and pushes the i'th closure in the supplied list +-- (call it i), and pushes the i'th closure in the supplied list -- as a consequence. implement_tagToId :: [Name] -> BcM BCInstrList implement_tagToId names @@ -1172,13 +1168,13 @@ implement_tagToId names [0 ..] names steps = map (mkStep label_exit) infos return (concatOL steps - `appOL` + `appOL` toOL [LABEL label_fail, CASEFAIL, LABEL label_exit]) where mkStep l_exit (my_label, next_label, n, name_for_n) - = toOL [LABEL my_label, - TESTEQ_I n next_label, - PUSH_G name_for_n, + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, JMP l_exit] @@ -1197,8 +1193,8 @@ implement_tagToId names pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16) -pushAtom d p e - | Just e' <- bcView e +pushAtom d p e + | Just e' <- bcView e = pushAtom d p e' pushAtom d p (AnnVar v) @@ -1214,19 +1210,19 @@ pushAtom d p (AnnVar v) | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable = let l = d - d_v + sz - 2 in return (toOL (genericReplicate sz (PUSH_L l)), sz) - -- d - d_v the number of words between the TOS - -- and the 1st slot of the object - -- - -- d - d_v - 1 the offset from the TOS of the 1st slot - -- - -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot - -- of the object. - -- - -- Having found the last slot, we proceed to copy the right number of - -- slots on to the top of the stack. + -- d - d_v the number of words between the TOS + -- and the 1st slot of the object + -- + -- d - d_v - 1 the offset from the TOS of the 1st slot + -- + -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot + -- of the object. + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. | otherwise -- v must be a global variable - = ASSERT(sz == 1) + = ASSERT(sz == 1) return (unitOL (PUSH_G (getName v)), sz) where @@ -1242,31 +1238,31 @@ pushAtom _ _ (AnnLit lit) MachFloat _ -> code FloatArg MachDouble _ -> code DoubleArg MachChar _ -> code NonPtrArg - MachNullAddr -> code NonPtrArg + MachNullAddr -> code NonPtrArg MachStr s -> pushStr s l -> pprPanic "pushAtom" (ppr l) where code rep = let size_host_words = fromIntegral (cgRepSizeW rep) - in return (unitOL (PUSH_UBX (Left lit) size_host_words), + in return (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) - pushStr s + pushStr s = let getMallocvilleAddr = case s of - FastString _ n _ fp _ -> - -- we could grab the Ptr from the ForeignPtr, - -- but then we have no way to control its lifetime. - -- In reality it'll probably stay alive long enoungh - -- by virtue of the global FastString table, but - -- to be on the safe side we copy the string into - -- a malloc'd area of memory. + FastString _ n _ fp _ -> + -- we could grab the Ptr from the ForeignPtr, + -- but then we have no way to control its lifetime. + -- In reality it'll probably stay alive long enoungh + -- by virtue of the global FastString table, but + -- to be on the safe side we copy the string into + -- a malloc'd area of memory. do ptr <- ioToBc (mallocBytes (n+1)) recordMallocBc ptr ioToBc ( withForeignPtr fp $ \p -> do - memcpy ptr p (fromIntegral n) - pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + memcpy ptr p (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) return ptr ) in do @@ -1278,7 +1274,7 @@ pushAtom d p (AnnCast e _) = pushAtom d p (snd e) pushAtom _ _ expr - = pprPanic "ByteCodeGen.pushAtom" + = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, expr))) foreign import ccall unsafe "memcpy" @@ -1290,14 +1286,14 @@ foreign import ccall unsafe "memcpy" -- of making a multiway branch using a switch tree. -- What a load of hassle! -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt - -- a hint; generates better code - -- Nothing is always safe - -> [(Discr, BCInstrList)] +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] -> BcM BCInstrList mkMultiBranch maybe_ncons raw_ways = let d_way = filter (isNoDiscr.fst) raw_ways - notd_ways = sortLe + notd_ways = sortLe (\w1 w2 -> leAlt (fst w1) (fst w2)) (filter (not.isNoDiscr.fst) raw_ways) @@ -1305,14 +1301,14 @@ mkMultiBranch maybe_ncons raw_ways mkTree [] _range_lo _range_hi = return the_default mkTree [val] range_lo range_hi - | range_lo `eqAlt` range_hi + | range_lo `eqAlt` range_hi = return (snd val) | otherwise = do label_neq <- getLabelBc - return (testEQ (fst val) label_neq - `consOL` (snd val - `appOL` unitOL (LABEL label_neq) - `appOL` the_default)) + return (testEQ (fst val) label_neq + `consOL` (snd val + `appOL` unitOL (LABEL label_neq) + `appOL` the_default)) mkTree vals range_lo range_hi = let n = length vals `div` 2 @@ -1324,11 +1320,11 @@ mkMultiBranch maybe_ncons raw_ways code_lo <- mkTree vals_lo range_lo (dec v_mid) code_hi <- mkTree vals_hi v_mid range_hi return (testLT v_mid label_geq - `consOL` (code_lo - `appOL` unitOL (LABEL label_geq) - `appOL` code_hi)) - - the_default + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default = case d_way of [] -> unitOL CASEFAIL [(_, def)] -> def _ -> panic "mkMultiBranch/the_default" @@ -1353,12 +1349,12 @@ mkMultiBranch maybe_ncons raw_ways = panic "mkMultiBranch: awesome foursome" | otherwise = case fst (head notd_ways) of - DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) - DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) - DiscrF _ -> ( DiscrF minF, DiscrF maxF ) - DiscrD _ -> ( DiscrD minD, DiscrD maxD ) - DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) - NoDiscr -> panic "mkMultiBranch NoDiscr" + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" (algMinBound, algMaxBound) = case maybe_ncons of @@ -1388,8 +1384,8 @@ mkMultiBranch maybe_ncons raw_ways dec (DiscrI i) = DiscrI (i-1) dec (DiscrW w) = DiscrW (w-1) dec (DiscrP i) = DiscrP (i-1) - dec other = other -- not really right, but if you - -- do cases on floating values, you'll get what you deserve + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve -- same snotty comment applies to the following minF, maxF :: Float @@ -1406,7 +1402,7 @@ mkMultiBranch maybe_ncons raw_ways -- Supporting junk for the compilation schemes -- Describes case alts -data Discr +data Discr = DiscrI Int | DiscrW Word | DiscrF Float @@ -1431,9 +1427,9 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id)) -- See bug #1257 unboxedTupleException :: a -unboxedTupleException - = ghcError - (ProgramError +unboxedTupleException + = ghcError + (ProgramError ("Error: bytecode compiler can't handle unboxed tuples.\n"++ " Possibly due to foreign import/export decls in source.\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) @@ -1443,11 +1439,11 @@ mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) - -- The arguments are returned in *right-to-left* order + -- The arguments are returned in *right-to-left* order splitApp e | Just e' <- bcView e = splitApp e' -splitApp (AnnApp (_,f) (_,a)) = case splitApp f of - (f', as) -> (f', a:as) -splitApp e = (e, []) +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) @@ -1456,23 +1452,23 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) -- b) type applications -- c) casts -- d) notes --- Type lambdas *can* occur in random expressions, +-- Type lambdas *can* occur in random expressions, -- whereas value lambdas cannot; that is why they are nuked here -bcView (AnnNote _ (_,e)) = Just e -bcView (AnnCast (_,e) _) = Just e +bcView (AnnNote _ (_,e)) = Just e +bcView (AnnCast (_,e) _) = Just e bcView (AnnLam v (_,e)) | isTyCoVar v = Just e -bcView (AnnApp (_,e) (_, AnnType _)) = Just e -bcView _ = Nothing +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView _ = Nothing isVoidArgAtom :: AnnExpr' Var ann -> Bool isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidArgAtom _ = False +isVoidArgAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = typePrimRep (idType v) -atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) atomRep :: AnnExpr' Id ann -> CgRep @@ -1493,32 +1489,32 @@ mkStackOffsets original_depth szsw type BcPtr = Either ItblPtr (Ptr ()) -data BcM_State - = BcM_State { +data BcM_State + = BcM_State { uniqSupply :: UniqSupply, -- for generating fresh variable names - nextlabel :: Word16, -- for generating local labels - malloced :: [BcPtr], -- thunks malloced for current BCO - -- Should be free()d when it is GCd - breakArray :: BreakArray -- array of breakpoint flags + nextlabel :: Word16, -- for generating local labels + malloced :: [BcPtr], -- thunks malloced for current BCO + -- Should be free()d when it is GCd + breakArray :: BreakArray -- array of breakpoint flags } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io +ioToBc io = BcM $ \st -> do + x <- io return (st, x) runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r) -runBc us modBreaks (BcM m) - = m (BcM_State us 0 [] breakArray) +runBc us modBreaks (BcM m) + = m (BcM_State us 0 [] breakArray) where breakArray = modBreaks_flags modBreaks thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do (st1, q) <- expr st0 - let BcM k = cont q + let BcM k = cont q (st2, r) <- k st1 return (st2, r) @@ -1557,10 +1553,10 @@ getLabelBc getLabelsBc :: Word16 -> BcM [Word16] getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) -getBreakArray :: BcM BreakArray +getBreakArray :: BcM BreakArray getBreakArray = BcM $ \st -> return (st, breakArray st) newUnique :: BcM Unique @@ -1570,7 +1566,7 @@ newUnique = BcM $ in return (newState, uniq) newId :: Type -> BcM Id -newId ty = do +newId ty = do uniq <- newUnique return $ mkSysLocal tickFS uniq ty diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 59f5669..b4068a7 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -569,10 +569,10 @@ newVar = liftTcM . newFlexiTyVarTy type RttiInstantiation = [(TcTyVar, TyVar)] -- Associates the typechecker-world meta type variables -- (which are mutable and may be refined), to their - -- debugger-world RuntimeUnkSkol counterparts. + -- debugger-world RuntimeUnk counterparts. -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the - -- original RuntimeUnkSkol + -- original RuntimeUnk -- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables @@ -1130,9 +1130,9 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk - -- This is where RuntimeUnkSkols are born: + -- This is where RuntimeUnks are born: -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnkSkols as they leave the + -- turned into RuntimeUnks as they leave the -- typechecker's monad ; return (mkTyVarTy tv') } diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index b5e6c41..5933e9d 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts | null stmts = failWith (ptext (sLit "Empty stmt list in do-block")) | otherwise = do { stmts' <- cvtStmts stmts - ; body <- case last stmts' of - L _ (ExprStmt body _ _) -> return body - stmt' -> failWith (bad_last stmt') - ; return $ HsDo do_or_lc (init stmts') body void } + ; let Just (stmts'', last') = snocView stmts' + + ; last'' <- case last' of + L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } where - bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon + bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt , ptext (sLit "(It should be an expression.)") ] @@ -539,7 +542,7 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds ; returnL $ LetStmt ds' } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e080bee..675afa2 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -679,16 +679,12 @@ okInstDclSig (TypeSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns - sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 345ec32..53d2949 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -3,15 +3,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % - - \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details {-# LANGUAGE DeriveDataTypeable #-} -- | Abstract syntax of global declarations. @@ -630,15 +622,15 @@ instance OutputableBndr name (ppr new_or_data <+> (if isJust typats then ptext (sLit "instance") else empty) <+> pp_decl_head (unLoc context) ltycon tyvars typats <+> - ppr_sig mb_sig) + ppr_sigx mb_sig) (pp_condecls condecls) derivings where - ppr_sig Nothing = empty - ppr_sig (Just kind) = dcolon <+> pprKind kind + ppr_sigx Nothing = empty + ppr_sigx (Just kind) = dcolon <+> pprKind kind ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFDs = fds, + tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, tcdATs = ats}) | null sigs && null ats -- No "where" part = top_matter @@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl pprConDecl :: OutputableBndr name => ConDecl name -> SDoc -pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs +pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = ResTyH98, con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] + = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where - ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] - ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) - ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) + ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys @@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG %************************************************************************ %* * -\subsection[InstDecl]{An instance declaration +\subsection[InstDecl]{An instance declaration} %* * %************************************************************************ @@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats %************************************************************************ %* * -\subsection[DerivDecl]{A stand-alone instance deriving declaration +\subsection[DerivDecl]{A stand-alone instance deriving declaration} %* * %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 06616f1..9c88783 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -23,6 +23,8 @@ import Name import BasicTypes import DataCon import SrcLoc +import Util( dropTail ) +import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString @@ -146,8 +148,6 @@ data HsExpr id -- because in this context we never use -- the PatGuard or ParStmt variant [LStmt id] -- "do":one or more stmts - (LHsExpr id) -- The body; the last expression in the - -- 'do' of [ body | ... ] in a list comp PostTcType -- Type of the whole expression | ExplicitList -- syntactic list @@ -439,7 +439,7 @@ ppr_expr (HsLet binds expr) = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body +ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -575,7 +575,7 @@ pprParendExpr expr HsPar {} -> pp_as_was HsBracket {} -> pp_as_was HsBracketOut _ [] -> pp_as_was - HsDo sc _ _ _ + HsDo sc _ _ | isListCompExpr sc -> pp_as_was _ -> parens pp_as_was @@ -830,51 +830,59 @@ type LStmtLR idL idR = Located (StmtLR idL idR) type Stmt id = StmtLR id id --- The SyntaxExprs in here are used *only* for do-notation, which --- has rebindable syntax. Otherwise they are unused. +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. data StmtLR idL idR - = BindStmt (LPat idL) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, + -- and (after the renamer) DoExpr, MDoExpr + -- Not used for GhciStmt, PatGuard, which scope over other stuff + (LHsExpr idR) + (SyntaxExpr idR) -- The return operator, used only for MonadComp + -- For ListComp, PArrComp, we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't appply a 'return' at all + -- See Note [Monad Comprehensions] + | BindStmt (LPat idL) (LHsExpr idR) - (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] PostTcType -- Element type of the RHS (used for arrows) | LetStmt (HsLocalBindsLR idL idR) - -- ParStmts only occur in a list comprehension + -- ParStmts only occur in a list/monad comprehension | ParStmt [([LStmt idL], [idR])] - -- After renaming, the ids are the binders bound by the stmts and used - -- after them - - -- "qs, then f by e" ==> TransformStmt qs binders f (Just e) - -- "qs, then f" ==> TransformStmt qs binders f Nothing - | TransformStmt - [LStmt idL] -- Stmts are the ones to the left of the 'then' - - [idR] -- After renaming, the IDs are the binders occurring - -- within this transform statement that are used after it - - (LHsExpr idR) -- "then f" - - (Maybe (LHsExpr idR)) -- "by e" (optional) - - | GroupStmt - [LStmt idL] -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - [(idR, idR)] -- See Note [GroupStmt binder map] + (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + (SyntaxExpr idR) -- Polymorphic `return` operator + -- with type (forall a. a -> m a) + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_form :: TransForm, + trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] - (Maybe (LHsExpr idR)) -- "by e" (optional) + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e - (Either -- "using f" - (LHsExpr idR) -- Left f => explicit "using f" - (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith' - + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) | RecStmt @@ -905,20 +913,44 @@ data StmtLR idL idR -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, -- so they may be type applications + + , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). } deriving (Data, Typeable) + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e + | GroupFormU -- group using f or group using f by e + | GroupFormB -- group by e + -- In the GroupByFormB, trS_using is filled in with + -- 'groupWith' (list comprehensions) or + -- 'groupM' (monad comprehensions) + deriving (Data, Typeable) \end{code} -Note [GroupStmt binder map] +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see Trac #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a GroupStmt behaves as follows: +The [(idR,idR)] in a TransStmt behaves as follows: * Before renaming: [] * After renaming: [ (x27,x27), ..., (z35,z35) ] These are the variables - bound by the stmts to the left of the 'group' + bound by the stmts to the left of the 'group' and used either in the 'by' clause, or in the stmts following the 'group' Each item is a pair of identical variables. @@ -952,7 +984,13 @@ depends on the context. Consider the following contexts: E :: Bool Translation: if E then fail else ... -Array comprehensions are handled like list comprehensions -=chak + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -993,23 +1031,60 @@ A (RecStmt stmts) types as if you had written where v1..vn are the later_ids r1..rm are the rec_ids +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +ExprStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Grouping/parallel statements require the 'Control.Monad.Group.groupM' and +'Control.Monad.Zip.mzip' functions: + + [ body | stmts, then group by e, rest] + => + groupM [ body | stmts ] >>= \bndrs -> [ body | rest ] + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + \begin{code} instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc +pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] -pprStmt (ExprStmt expr _ _) = ppr expr -pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss) +pprStmt (ExprStmt expr _ _ _) = ppr expr +pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts -pprStmt (TransformStmt stmts bndrs using by) - = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) - -pprStmt (GroupStmt stmts _ by using) - = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) + = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@ -1024,40 +1099,47 @@ pprTransformStmt bndrs using by , nest 2 (ppr using) , nest 2 (pprBy by)] -pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> Either (LHsExpr id) (SyntaxExpr is) +pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) + -> LHsExpr id -> TransForm -> SDoc -pprGroupStmt by using - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)] - where - ppr_using (Right _) = empty - ppr_using (Left e) = ptext (sLit "using") <+> ppr e +pprTransStmt by using ThenForm + = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by _ GroupFormB + = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ] +pprTransStmt by using GroupFormU + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc pprBy Nothing = empty pprBy (Just e) = ptext (sLit "by") <+> ppr e -pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc -pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body -pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body -pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body -pprDo ListComp stmts body = brackets $ pprComp stmts body -pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body -pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc +pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc +pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo PArrComp stmts = pa_brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs -ppr_do_stmts stmts body - = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body]) +ppr_do_stmts stmts + = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] -pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc -pprComp quals body -- Prints: body | qual1, ..., qualn - = hang (ppr body <+> char '|') 2 (interpp'SP quals) +pprComp :: OutputableBndr id => [LStmt id] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | not (null quals) + , L _ (LastStmt body _) <- last quals + = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals)) + | otherwise + = pprPanic "pprComp" (interpp'SP quals) \end{code} %************************************************************************ @@ -1175,26 +1257,33 @@ data HsMatchContext id -- Context of a Match data HsStmtContext id = ListComp - | DoExpr - | GhciStmt -- A command-line Stmt in GHCi pat <- rhs - | MDoExpr -- Recursive do-expression + | MonadComp | PArrComp -- Parallel array comprehension + + | DoExpr -- do { ... } + | MDoExpr -- mdo { ... } ie recursive do-expression + | ArrowExpr -- do-notation in an arrow-command context + + | GhciStmt -- A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt - | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt deriving (Data, Typeable) \end{code} \begin{code} -isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr MDoExpr = True -isDoExpr _ = False - isListCompExpr :: HsStmtContext id -> Bool -isListCompExpr ListComp = True -isListCompExpr PArrComp = True -isListCompExpr _ = False +-- Uses syntax [ e | quals ] +isListCompExpr ListComp = True +isListCompExpr PArrComp = True +isListCompExpr MonadComp = True +isListCompExpr _ = False + +isMonadCompExpr :: HsStmtContext id -> Bool +isMonadCompExpr MonadComp = True +isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr _ = False \end{code} \begin{code} @@ -1231,33 +1320,41 @@ pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") $$ pprStmtContext ctxt -pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +----------------- +pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = ptext (sLit "an") + pp_a = ptext (sLit "a") + article = case ctxt of + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") +pprStmtContext DoExpr = ptext (sLit "'do' block") +pprStmtContext MDoExpr = ptext (sLit "'mdo' block") +pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") +pprStmtContext ListComp = ptext (sLit "list comprehension") +pprStmtContext MonadComp = ptext (sLit "monad comprehension") +pprStmtContext PArrComp = ptext (sLit "array comprehension") +pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) - = sep [ptext (sLit "a parallel branch of"), pprStmtContext c] -pprStmtContext (TransformStmtCtxt c) - = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] -pprStmtContext (PatGuard ctxt) - = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt -pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") -pprStmtContext DoExpr = ptext (sLit "a 'do' expression") -pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression") -pprStmtContext ListComp = ptext (sLit "a list comprehension") -pprStmtContext PArrComp = ptext (sLit "an array comprehension") - -{- -pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun) -pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative") -pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding") -pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda") -pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc") -pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt - --- Used for the result statement of comprehension --- e.g. the 'e' in [ e | ... ] --- or the 'r' in f x = r -pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt -pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other --} + | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c +pprStmtContext (TransStmtCtxt c) + | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc @@ -1268,14 +1365,16 @@ matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") -matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") -matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression") -matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") -matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") +matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") +matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") +matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") +matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} \begin{code} @@ -1286,11 +1385,16 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) => HsStmtContext idL -> StmtLR idL idR -> SDoc -pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) - 4 (ppr_stmt stmt) +pprStmtInCtxt ctxt (LastStmt e _) + | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (ptext (sLit "In the expression:")) 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using - ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by - ppr_stmt stmt = pprStmt stmt + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt \end{code} diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index dd24aed..5015999 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -6,12 +6,6 @@ HsImpExp: Abstract syntax: imports, exports, interfaces \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details {-# LANGUAGE DeriveDataTypeable #-} module HsImpExp where @@ -103,6 +97,7 @@ ieName (IEVar n) = n ieName (IEThingAbs n) = n ieName (IEThingWith n _) = n ieName (IEThingAll n) = n +ieName _ = panic "ieName failed pattern match!" ieNames :: IE a -> [a] ieNames (IEVar n ) = [n] @@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] ppr (IEThingWith thing withs) = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs))) - ppr (IEModuleContents mod) - = ptext (sLit "module") <+> ppr mod + ppr (IEModuleContents mod') + = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("") ppr (IEDoc doc) = ppr doc ppr (IEDocNamed string) = text ("") diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 0874dda..4a565ff 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -63,8 +63,7 @@ instance Eq HsLit where data HsOverLit id -- An overloaded literal = OverLit { ol_val :: OverLitVal, - ol_rebindable :: Bool, -- True <=> rebindable syntax - -- False <=> standard syntax + ol_rebindable :: Bool, -- Note [ol_rebindable] ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] ol_type :: PostTcType } deriving (Data, Typeable) @@ -79,6 +78,19 @@ overLitType :: HsOverLit a -> Type overLitType = ol_type \end{code} +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one + Note [Overloaded literal witnesses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *Before* type checking, the SyntaxExpr in an HsOverLit is the @@ -89,7 +101,7 @@ This witness should replace the literal. This dual role is unusual, because we're replacing 'fromInteger' with a call to fromInteger. Reason: it allows commoning up of the fromInteger -calls, which wouldn't be possible if the desguarar made the application +calls, which wouldn't be possible if the desguarar made the application. The PostTcType in each branch records the type the overload literal is found to have. diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 78b5887..3efcd59 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -122,7 +122,9 @@ data Pat id | LitPat HsLit -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. - | NPat (HsOverLit id) -- ALWAYS positive + | NPat -- Used for all overloaded literals, + -- including overloaded strings with -XOverloadedStrings + (HsOverLit id) -- ALWAYS positive (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise (SyntaxExpr id) -- Equality checker, of type t->t->Bool diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index bf75f4c..5e8dda3 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -21,7 +21,7 @@ module HsUtils( mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, coiToHsWrapper, mkHsLams, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -42,8 +42,8 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -61,7 +61,10 @@ module HsUtils( collectSigTysFromPats, collectSigTysFromPat, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@ -81,8 +84,11 @@ import NameSet import BasicTypes import SrcLoc import FastString +import Outputable import Util import Bag + +import Data.Either \end{code} @@ -184,14 +190,13 @@ mkSimpleHsAlt pat expr mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsFractional :: Rational -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR - +mkLastStmt :: LHsExpr idR -> StmtLR idL idR mkExprStmt :: LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR @@ -206,7 +211,10 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b @@ -214,24 +222,32 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) - +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) -mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) - -mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +emptyTransStmt :: StmtLR idL idR +emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss + , trS_by = Just b, trS_using = u } + +mkLastStmt expr = LastStmt expr noSyntaxExpr +mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr - , recS_rec_rets = [] } + , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -321,8 +337,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id -nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) @@ -490,12 +506,12 @@ collectStmtBinders :: StmtLR idL idR -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ParStmt xs) = collectLStmtsBinders +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -617,6 +633,81 @@ hsConDeclsBinders cons %************************************************************************ %* * + Collecting binders the user did not write +%* * +%************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +\begin{code} +lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (ExprStmt {}) = emptyNameSet + hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + +hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) + = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds] + where + hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + hs_bind _ = emptyNameSet +hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty + +lPatImplicits :: LPat Name -> NameSet +lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg fld + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 +\end{code} + + +%************************************************************************ +%* * Collecting type signatures from patterns %* * %************************************************************************ diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3eae7a3..950021e 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -5,34 +5,34 @@ \begin{code} module IfaceSyn ( - module IfaceType, -- Re-export all this + module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), - IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceInst(..), IfaceFamInst(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), - -- Misc + -- Misc ifaceDeclSubBndrs, visibleIfConDecls, -- Free Names freeNamesIfDecl, freeNamesIfRule, - -- Pretty printing - pprIfaceExpr, pprIfaceDeclHead + -- Pretty printing + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" import IfaceType import CoreSyn( DFunArg, dfunArgExprs ) -import PprCore() -- Printing DFunArgs +import PprCore() -- Printing DFunArgs import Demand import Annotations import Class -import NameSet +import NameSet import Name import CostCentre import Literal @@ -48,74 +48,75 @@ infixl 3 &&& %************************************************************************ -%* * - Data type declarations -%* * +%* * + Data type declarations +%* * %************************************************************************ \begin{code} -data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data info - ifRec :: RecFlag, -- Recursive or not? - ifGadtSyntax :: Bool, -- True <=> declared using - -- GADT syntax - ifGeneric :: Bool, -- True <=> generic converter - -- functions available - -- We need this for imported - -- data decls, since the - -- imported modules may have - -- been compiled with - -- different flags to the - -- current compilation unit +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifGeneric :: Bool, -- True <=> generic converter + -- functions available + -- We need this for imported + -- data decls, since the + -- imported modules may have + -- been compiled with + -- different flags to the + -- current compilation unit ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family - -- Invariant: + -- Invariant: -- ifCons /= IfOpenDataTyCon -- for family instances } - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn - -- Nothing for an open family + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) + ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn + -- Nothing for an open family ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: ifOpenSyn == False -- for family instances } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceDecl], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceDecl], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET - ifExtName :: Maybe FastString } + ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType - -- Nothing => no default method - -- Just False => ordinary polymorphic default method - -- Just True => generic default method + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method data IfaceConDecls - = IfAbstractTyCon -- No info - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] @@ -123,49 +124,49 @@ visibleIfConDecls IfOpenDataTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] -data IfaceConDecl +data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name - ifConWrapper :: Bool, -- True <=> has a wrapper - ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars - ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [HsBang]} -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -data IfaceInst - = IfaceInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] - -- There's always a separate IfaceDecl for the DFun, which gives - -- its IdInfo with its full type and version number. - -- The instance declarations taken together have a version number, - -- and we don't want that to wobble gratuitously - -- If this instance decl is *used*, we'll record a usage on the dfun; - -- and if the head does not change it won't be used if it wasn't before + ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [OccName], -- ...ditto... (field labels) + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + +data IfaceInst + = IfaceInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See Note [Orphans] + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon - , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types - , ifFamInstTyCon :: IfaceTyCon -- Instance decl - } + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl + } data IfaceRule - = IfaceRule { - ifRuleName :: RuleName, - ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } data IfaceAnnotation @@ -187,80 +188,80 @@ data IfaceIdDetails | IfDFunId Int -- Number of silent args data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O -- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. +-- and so gives a new version. data IfaceInfoItem - = HsArity Arity + = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true - IfaceUnfolding -- See Note [Expose recursive functions] + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. -data IfaceUnfolding +data IfaceUnfolding = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding -- Possibly could eliminate the Bool here, the information -- is also in the InlinePragma. - | IfCompulsory IfaceExpr -- Only used for default methods, in fact + | IfCompulsory IfaceExpr -- Only used for default methods, in fact | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring - IfaceExpr + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr - | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) - | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in - -- another module. + | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) + | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in + -- another module. | IfDFunUnfold [DFunArg IfaceExpr] -------------------------------- data IfaceExpr - = IfaceLcl IfLclName + = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] - | IfaceLet IfaceBinding IfaceExpr - | IfaceNote IfaceNote IfaceExpr + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceTupleAlt Boxity - | IfaceLitAlt Literal + | IfaceDataAlt IfExtName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders @@ -299,9 +300,9 @@ complicate the situation though. Consider and suppose we are compiling module X: module X where - import M - data T = ... - instance C Int T where ... + import M + data T = ... + instance C Int T where ... This instance is an orphan, because when compiling a third module Y we might get a constraint (C Int v), and we'd want to improve v to T. So @@ -315,7 +316,7 @@ More precisely, an instance is an orphan iff If there are fundeps, then for every fundep, at least one of the names free in a *non-determined* part of the instance head is - defined in this module. + defined in this module. (Note that these conditions hold trivially if the class is locally defined.) @@ -342,10 +343,10 @@ a functionally-dependent part of the instance decl. E.g. and suppose we are compiling module X: module X where - import M - data S = ... - data T = ... - instance C S T where ... + import M + data S = ... + data T = ... + instance C S T where ... If we base the instance verion on T, I'm worried that changing S to S' would change T's version, but not S or S'. But an importing module might @@ -356,8 +357,8 @@ and it seems deeply obscure, so I'm going to leave it for now. Note [Versioning of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -A rule that is not an orphan has an ifRuleOrph field of (Just n), where -n appears on the LHS of the rule; any change in the rule changes the version of n. +A rule that is not an orphan has an ifRuleOrph field of (Just n), where n +appears on the LHS of the rule; any change in the rule changes the version of n. \begin{code} @@ -380,7 +381,7 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( IfCon { ifConOcc = con_occ }), - ifFamInst = famInst}) + ifFamInst = famInst}) = -- implicit coerion and (possibly) family instance coercion (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ -- data constructor and worker (newtypes don't have a wrapper) @@ -388,8 +389,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) = -- (possibly) family instance coercion; -- there is no implicit coercion for non-newtypes famInstCo famInst tc_occ @@ -398,20 +399,20 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ++ concatMap dc_occs cons where dc_occs con_decl - | has_wrapper = [con_occ, work_occ, wrap_occ] - | otherwise = [con_occ, work_occ] - where - con_occ = ifConOcc con_decl -- DataCon namespace - wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - has_wrapper = ifConWrapper con_decl -- This is the reason for - -- having the ifConWrapper field! - -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) = -- dictionary datatype: -- type constructor - tc_occ : + tc_occ : -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -428,14 +429,14 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] + | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh + is_newtype = n_sigs + n_ctxt == 1 -- Sigh ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) + ifFamInst = famInst}) = famInstCo famInst tc_occ ifaceDeclSubBndrs _ = [] @@ -451,46 +452,46 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdDetails = details, ifIdInfo = info}) - = sep [ ppr var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] + = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr details), + nest 2 (ppr info) ] pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty, +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Just mono_ty, ifFamInst = mbFamInst}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls, - pprFamily mbFamInst]) + pprFamily mbFamInst]) where pp_nd = case condecls of - IfAbstractTyCon -> ptext (sLit "data") - IfOpenDataTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) + IfAbstractTyCon -> ptext (sLit "data") + IfOpenDataTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + +pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifATs = ats, ifSigs = sigs, + ifRec = isrec}) = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) + sep (map ppr ats), + sep (map ppr sigs)]) pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec @@ -508,68 +509,68 @@ instance Outputable IfaceClassOp where pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), + pprIfaceTvBndrs tyvars] pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}") pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls _ IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) + (map (pprIfaceConDecl tc) cs)) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + if is_infix then ptext (sLit "Infix") else empty, + if has_wrap then ptext (sLit "HasWrapper") else empty, + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where - ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang HsNoBang = char '_' -- Want to see these ppr_bang bang = ppr bang - - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + main_payload = ppr name <+> dcolon <+> + pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - -- A bit gruesome this, but we can't form the full con_tau, and ppr it, - -- because we don't have a Name for the tycon, only an OccName + eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + | (tv,ty) <- eq_spec] + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, - ptext (sLit "forall") <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - ptext (sLit "=") <+> ppr rhs]) + ptext (sLit "forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + ptext (sLit "=") <+> ppr rhs]) ] instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) - = hang (ptext (sLit "instance") <+> ppr flag - <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext (sLit "instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstTyCon = tycon_id}) - = hang (ptext (sLit "family instance") <+> - ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ifFamInstTyCon = tycon_id}) + = hang (ptext (sLit "family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr tycon_id) ppr_rough :: Maybe IfaceTyCon -> SDoc @@ -587,9 +588,11 @@ instance Outputable IfaceExpr where pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v @@ -601,100 +604,107 @@ pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) -pprIfaceExpr add_par e@(IfaceLam _ _) +pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] e + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, - pprIfaceExpr noParens rhs <+> char '}']) + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") - <+> ppr bndr <+> char '{', - nest 2 (sep (map ppr_alt alts)) <+> char '}']) + <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, - nest 2 (ptext (sLit "`cast`")), - pprParendIfaceType co] + nest 2 (ptext (sLit "`cast`")), + pprParendIfaceType co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [ptext (sLit "let {"), - nest 2 (ppr_bind (b, rhs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + = add_par (sep [ptext (sLit "let {"), + nest 2 (ppr_bind (b, rhs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) = add_par (sep [ptext (sLit "letrec {"), - nest 2 (sep (map ppr_bind pairs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + nest 2 (sep (map ppr_bind pairs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) -pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body) +pprIfaceExpr add_par (IfaceNote note body) = add_par $ ppr note + <+> pprParendIfaceExpr body ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) -ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) - +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info, rhs) +ppr_bind (IfLetBndr b ty info, rhs) = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), - equals <+> pprIfaceExpr noParens rhs] + equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args) -pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) + ppr (IfaceCoreNote s) = ptext (sLit "__core_note") + <+> pprHsString (mkFastString s) instance Outputable IfaceConAlt where ppr IfaceDefault = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d - ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" + ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ instance Outputable IfaceIdDetails where - ppr IfVanillaId = empty + ppr IfVanillaId = empty ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc - <+> if b then ptext (sLit "") else empty + <+> if b then ptext (sLit "") else empty ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is + <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") + <> ppWhen lb (ptext (sLit "(loop-breaker)")) <> colon <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str - ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), - pprParendIfaceExpr e] + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr @@ -703,7 +713,7 @@ instance Outputable IfaceUnfolding where <+> brackets (pprWithCommas ppr ns) -- ----------------------------------------------------------------------------- --- Finding the Names in IfaceSyn +-- | Finding the Names in IfaceSyn -- This is used for dependency analysis in MkIface, so that we -- fingerprint a declaration before the things that depend on it. It @@ -713,11 +723,11 @@ instance Outputable IfaceUnfolding where -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t d i) = +freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& freeNamesIfIdInfo i &&& freeNamesIfIdDetails d -freeNamesIfDecl IfaceForeign{} = +freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -744,7 +754,7 @@ freeNamesIfSynRhs (Just ty) = freeNamesIfType ty freeNamesIfSynRhs Nothing = emptyNameSet freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet -freeNamesIfTcFam (Just (tc,tys)) = +freeNamesIfTcFam (Just (tc,tys)) = freeNamesIfTc tc &&& fnList freeNamesIfType tys freeNamesIfTcFam Nothing = emptyNameSet @@ -764,15 +774,15 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = +freeNamesIfConDecl c = freeNamesIfTvBndrs (ifConUnivTvs c) &&& freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& + freeNamesIfContext (ifConCtxt c) &&& fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfPredType :: IfacePredType -> NameSet -freeNamesIfPredType (IfaceClassP cl tys) = +freeNamesIfPredType (IfaceClassP cl tys) = unitNameSet cl &&& fnList freeNamesIfType tys freeNamesIfPredType (IfaceIParam _n ty) = freeNamesIfType ty @@ -783,7 +793,7 @@ freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st -freeNamesIfType (IfaceTyConApp tc ts) = +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t @@ -798,7 +808,7 @@ freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b freeNamesIfLetBndr :: IfaceLetBndr -> NameSet -- Remember IfaceLetBndr is used only for *nested* bindings --- The IdInfo can contain an unfolding (in the case of +-- The IdInfo can contain an unfolding (in the case of -- local INLINE pragmas), so look there too freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty &&& freeNamesIfIdInfo info @@ -811,7 +821,7 @@ freeNamesIfIdBndr :: IfaceIdBndr -> NameSet freeNamesIfIdBndr = freeNamesIfTvBndr freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet @@ -827,17 +837,17 @@ freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co -freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r +freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r freeNamesIfExpr (IfaceCase s _ ty alts) - = freeNamesIfExpr s + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts &&& freeNamesIfType ty where @@ -845,10 +855,10 @@ freeNamesIfExpr (IfaceCase s _ ty alts) -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body @@ -883,18 +893,18 @@ fnList f = foldr (&&&) emptyNameSet . map f Note [Tracking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case expression +In a case expression case e of { C a -> ...; ... } You might think that we don't need to include the datacon C -in the free names, because its type will probably show up in +in the free names, because its type will probably show up in the free names of 'e'. But in rare circumstances this may not happen. Here's the one that bit me: - module DynFlags where + module DynFlags where import {-# SOURCE #-} Packages( PackageState ) data DynFlags = DF ... PackageState ... - module Packages where + module Packages where import DynFlags data PackageState = PS ... lookupModule (df :: DynFlags) @@ -905,3 +915,4 @@ not happen. Here's the one that bit me: Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. + diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b940cb1..c327006 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names finsts_mod = mi_finsts iface hash_env = mi_hash_fn iface mod_hash = mi_mod_hash iface - export_hash | depend_on_exports mod = Just (mi_exp_hash iface) - | otherwise = Nothing + export_hash | depend_on_exports = Just (mi_exp_hash iface) + | otherwise = Nothing used_occs = lookupModuleEnv ent_map mod `orElse` [] @@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) Just r -> r - depend_on_exports mod = - case lookupModuleEnv direct_imports mod of - Just _ -> True - -- Even if we used 'import M ()', we have to register a - -- usage on the export list because we are sensitive to - -- changes in orphan instances/rules. - Nothing -> False - -- In GHC 6.8.x the above line read "True", and in - -- fact it recorded a dependency on *all* the - -- modules underneath in the dependency tree. This - -- happens to make orphans work right, but is too - -- expensive: it'll read too many interface files. - -- The 'isNothing maybe_iface' check above saved us - -- from generating many of these usages (at least in - -- one-shot mode), but that's even more bogus! + depend_on_exports = is_direct_import + {- True + Even if we used 'import M ()', we have to register a + usage on the export list because we are sensitive to + changes in orphan instances/rules. + False + In GHC 6.8.x we always returned true, and in + fact it recorded a dependency on *all* the + modules underneath in the dependency tree. This + happens to make orphans work right, but is too + expensive: it'll read too many interface files. + The 'isNothing maybe_iface' check above saved us + from generating many of these usages (at least in + one-shot mode), but that's even more bogus! + -} \end{code} \begin{code} diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 911592b..9f25c08 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -122,34 +122,25 @@ pprInfoTable env count lbl stat then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" else (pprLlvmData ([ldata'], ltypes), llvmUsed) + -- | We generate labels for info tables by converting them to the same label -- as for the entry code but adding this string as a suffix. iTableSuf :: String iTableSuf = "_itable" --- | Create an appropriate section declaration for subsection of text --- WARNING: This technique could fail as gas documentation says it only --- supports up to 8192 subsections per section. Inspection of the source --- code and some test programs seem to suggest it supports more than this --- so we are hoping it does. +-- | Create a specially crafted section declaration that encodes the order this +-- section should be in the final object code. +-- +-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses +-- this section declaration to do its processing. mkLayoutSection :: Int -> LMSection mkLayoutSection n - -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which - -- doesn't support subsections. So we post process the assembly code, this - -- section specifier will be replaced with '.text' by the mangler. - = Just (fsLit $ infoSection ++ show n -#if darwin_TARGET_OS - ) -#else - ++ "#") -#endif + = Just (fsLit $ infoSection ++ show n) --- | The section we are putting info tables and their entry code into + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. infoSection :: String -#if darwin_TARGET_OS -infoSection = "__STRIP,__me" -#else -infoSection = ".text; .text " -#endif +infoSection = "X98A__STRIP,__me" diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 661dc9a..b0c63a4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -38,6 +38,8 @@ lmGlobalReg suf reg VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $"F1" ++ suf FloatReg 2 -> floatGlobal $"F2" ++ suf diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index 7b38ed8..591ef81 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -1,17 +1,21 @@ +{-# OPTIONS -fno-warn-unused-binds #-} -- ----------------------------------------------------------------------------- -- | GHC LLVM Mangler -- -- This script processes the assembly produced by LLVM, rearranging the code --- so that an info table appears before its corresponding function. We also --- use it to fix up the stack alignment, which needs to be 16 byte aligned --- but always ends up off by 4 bytes because GHC sets it to the 'wrong' --- starting value in the RTS. +-- so that an info table appears before its corresponding function. -- --- We only need this for Mac OS X, other targets don't use it. +-- On OSX we also use it to fix up the stack alignment, which needs to be 16 +-- byte aligned but always ends up off by word bytes because GHC sets it to +-- the 'wrong' starting value in the RTS. -- module LlvmMangler ( llvmFixupAsm ) where +#include "HsVersions.h" + +import LlvmCodeGen.Ppr ( infoSection ) + import Control.Exception import qualified Data.ByteString.Char8 as B import Data.Char @@ -19,17 +23,24 @@ import qualified Data.IntMap as I import System.IO -- Magic Strings -infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString -infoSec = B.pack "\t.section\t__STRIP,__me" +secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString +secStmt = B.pack "\t.section\t" +infoSec = B.pack infoSection newInfoSec = B.pack "\n\t.text" newLine = B.pack "\n" -spInst = B.pack ", %esp\n" jmpInst = B.pack "\n\tjmp" -infoLen, spFix, labelStart :: Int -infoLen = B.length infoSec -spFix = 4 -labelStart = B.length jmpInst + 1 +infoLen, labelStart, spFix :: Int +infoLen = B.length infoSec +labelStart = B.length jmpInst + +#if x86_64_TARGET_ARCH +spInst = B.pack ", %rsp\n" +spFix = 8 +#else +spInst = B.pack ", %esp\n" +spFix = 4 +#endif -- Search Predicates eolPred, dollarPred, commaPred :: Char -> Bool @@ -50,25 +61,30 @@ llvmFixupAsm f1 f2 = do {- | Here we process the assembly file one function and data - defenition at a time. When a function is encountered that + definition at a time. When a function is encountered that should have a info table we store it in a map. Otherwise we print it. When an info table is found we retrieve its function from the map and print them both. For all functions we fix up the stack alignment. We also - fix up the section defenition for functions and info tables. + fix up the section definition for functions and info tables. -} fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO () fixTables r w m = do f <- getFun r B.empty if B.null f then return () - else let fun = fixupStack f B.empty - (a,b) = B.breakSubstring infoSec fun - (x,c) = B.break eolPred b - fun' = a `B.append` newInfoSec `B.append` c - n = readInt $ B.drop infoLen x - (bs, m') | B.null b = ([fun], m) + else let fun = fixupStack f B.empty + (a,b) = B.breakSubstring infoSec fun + (a',s) = B.breakEnd eolPred a + -- We search for the section header in two parts as it makes + -- us portable across OS types and LLVM version types since + -- section names are wrapped differently. + secHdr = secStmt `B.isPrefixOf` s + (x,c) = B.break eolPred b + fun' = a' `B.append` newInfoSec `B.append` c + n = readInt $ B.takeWhile isDigit $ B.drop infoLen x + (bs, m') | B.null b || not secHdr = ([fun], m) | even n = ([], I.insert n fun' m) | otherwise = case I.lookup (n+1) m of Just xf' -> ([fun',xf'], m) @@ -88,7 +104,7 @@ getFun r f = do Mac OS X requires that the stack be 16 byte aligned when making a function call (only really required though when making a call that will pass through the dynamic linker). The alignment isn't correctly generated by LLVM as - LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry + LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry (since the function call was 16 byte aligned and the return address should have been pushed, so sub 4). GHC though since it always uses jumps keeps the stack 16 byte aligned on both function calls and function entry. @@ -96,6 +112,11 @@ getFun r f = do We correct the alignment here. -} fixupStack :: B.ByteString -> B.ByteString -> B.ByteString + +#if !darwin_TARGET_OS +fixupStack = const + +#else fixupStack f f' | B.null f' = let -- fixup sub op (a, c) = B.breakSubstring spInst f @@ -114,18 +135,21 @@ fixupStack f f' = (a', n) = B.breakEnd dollarPred a (n', x) = B.break commaPred n num = B.pack $ show $ readInt n' + spFix + -- We need to avoid processing jumps to labels, they are of the form: + -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L... + targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $ + B.drop labelStart c in if B.null c then f' `B.append` f - -- We need to avoid processing jumps to labels, they are of the form: - -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax... - else if B.index c labelStart == 'L' + else if B.head targ == 'L' then fixupStack b $ f' `B.append` a `B.append` l else fixupStack b $ f' `B.append` a' `B.append` num `B.append` x `B.append` l +#endif --- | read an int or error +-- | Read an int or error readInt :: B.ByteString -> Int readInt str | B.all isDigit str = (read . B.unpack) str - | otherwise = error $ "LLvmMangler Cannot read" ++ show str - ++ "as it's not an Int" + | otherwise = error $ "LLvmMangler Cannot read " ++ show str + ++ " as it's not an Int" diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 85f3402..f5e3394 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -8,9 +8,7 @@ module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN -import AsmCodeGen ( nativeCodeGen ) -#endif +import AsmCodeGen ( nativeCodeGen ) import LlvmCodeGen ( llvmCodeGen ) import UniqSupply ( mkSplitUniqSupply ) @@ -30,6 +28,7 @@ import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config +import SysTools import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable @@ -56,7 +55,7 @@ codeOutput :: DynFlags -> ForeignStubs -> [PackageId] -> [RawCmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -148,24 +147,16 @@ outputC dflags filenm flat_absC packages \begin{code} outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO () - -#ifndef OMIT_NATIVE_CODEGEN - outputAsm dflags filenm flat_absC + | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' {-# SCC "OutputAsm" #-} doOutput filenm $ - \f -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags f ncg_uniqs flat_absC - where - -#else /* OMIT_NATIVE_CODEGEN */ + \f -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags f ncg_uniqs flat_absC -outputAsm _ _ _ - = pprPanic "This compiler was built without a native code generator" - (text "Use -fvia-C instead") - -#endif + | otherwise + = panic "This compiler was built without a native code generator" \end{code} @@ -212,18 +203,21 @@ outputJava dflags filenm mod tycons core_binds \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - = case stubs of - NoStubs -> do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> do -- When compiling External Core files, may need to use stub -- files from a previous compilation - stub_c_exists <- doesFileExist stub_c - stub_h_exists <- doesFileExist stub_h - return (stub_h_exists, stub_c_exists) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - ForeignStubs h_code c_code -> do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -232,7 +226,7 @@ outputForeignStubs dflags mod location stubs stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (takeDirectory stub_c) + createDirectoryHierarchy (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -266,10 +260,10 @@ outputForeignStubs dflags mod location stubs -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. - return (stub_h_file_exists, stub_c_file_exists) - where - (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location - + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index e430c6e..1694aba 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -16,7 +16,6 @@ module DriverMkDepend ( #include "HsVersions.h" import qualified GHC --- import GHC ( ModSummary(..), GhcMonad ) import GhcMonad import HsSyn ( ImportDecl(..) ) import DynFlags @@ -35,7 +34,6 @@ import FastString import Exception import ErrUtils --- import MonadUtils ( liftIO ) import System.Directory import System.FilePath diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index d85335f..4702682 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -75,8 +75,8 @@ data Phase | Hsc HscSource | Ccpp | Cc + | Cobjc | HCc -- Haskellised C (as opposed to vanilla C) compilation - | Mangle -- assembly mangling, now done by a separate script. | SplitMangle -- after mangler if splitting | SplitAs | As @@ -85,6 +85,7 @@ data Phase | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. @@ -110,8 +111,8 @@ eqPhase (HsPp _) (HsPp _) = True eqPhase (Hsc _) (Hsc _) = True eqPhase Ccpp Ccpp = True eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True eqPhase HCc HCc = True -eqPhase Mangle Mangle = True eqPhase SplitMangle SplitMangle = True eqPhase SplitAs SplitAs = True eqPhase As As = True @@ -120,6 +121,7 @@ eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True eqPhase StopLn StopLn = True eqPhase _ _ = False @@ -133,27 +135,24 @@ x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y after_x = nextPhase x nextPhase :: Phase -> Phase --- A conservative approximation the next phase, used in happensBefore +-- A conservative approximation to the next phase, used in happensBefore nextPhase (Unlit sf) = Cpp sf nextPhase (Cpp sf) = HsPp sf nextPhase (HsPp sf) = Hsc sf nextPhase (Hsc _) = HCc -nextPhase HCc = Mangle -nextPhase Mangle = SplitMangle nextPhase SplitMangle = As nextPhase As = SplitAs nextPhase LlvmOpt = LlvmLlc -#if darwin_TARGET_OS nextPhase LlvmLlc = LlvmMangle -#else -nextPhase LlvmLlc = As -#endif nextPhase LlvmMangle = As -nextPhase SplitAs = StopLn +nextPhase SplitAs = MergeStub nextPhase Ccpp = As nextPhase Cc = As +nextPhase Cobjc = As nextPhase CmmCpp = Cmm nextPhase Cmm = HCc +nextPhase HCc = As +nextPhase MergeStub = StopLn nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined @@ -170,9 +169,9 @@ startPhase "hc" = HCc startPhase "c" = Cc startPhase "cpp" = Ccpp startPhase "C" = Cc +startPhase "m" = Cobjc startPhase "cc" = Ccpp startPhase "cxx" = Ccpp -startPhase "raw_s" = Mangle startPhase "split_s" = SplitMangle startPhase "s" = As startPhase "S" = As @@ -199,8 +198,8 @@ phaseInputExt (Hsc _) = "hspp" -- intermediate only -- output filename. That could be fixed, but watch out. phaseInputExt HCc = "hc" phaseInputExt Ccpp = "cpp" +phaseInputExt Cobjc = "m" phaseInputExt Cc = "c" -phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" phaseInputExt LlvmOpt = "ll" @@ -209,6 +208,7 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, @@ -217,7 +217,7 @@ haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "m" ] extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 9b3eb6a..2719470 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-cse #-} +{-# LANGUAGE NamedFieldPuns #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -50,11 +51,10 @@ import SrcLoc import FastString import LlvmCodeGen ( llvmFixupAsm ) import MonadUtils +import Platform --- import Data.Either import Exception import Data.IORef ( readIORef ) --- import GHC.Exts ( Int(..) ) import System.Directory import System.FilePath import System.IO @@ -62,6 +62,7 @@ import Control.Monad import Data.List ( isSuffixOf ) import Data.Maybe import System.Environment +import Data.Char -- --------------------------------------------------------------------------- -- Pre-process @@ -78,7 +79,7 @@ preprocess :: HscEnv preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -141,7 +142,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env = hsc_env0 {hsc_dflags = dflags} -- Figure out what lang we're generating - let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + let hsc_lang = hscTarget dflags -- ... and what the next phase should be let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into @@ -158,12 +159,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) source_unchanged = isJust maybe_old_linkable && not force_recomp object_filename = ml_obj_file location - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HscNoRecomp + let handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable @@ -175,22 +171,27 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) return maybe_old_linkable | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- + = do (hs_unlinked, unlinked_time) <- case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) + HscNothing -> + return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. - _other - -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + _other -> do + maybe_stub_o <- case hasStub of + Nothing -> return Nothing + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return (Just stub_o) + _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) + maybe_stub_o -- The object filename comes from the ModLocation - o_time <- getModificationTime object_filename - return ([DotO object_filename], o_time) - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + + let linkable = LM unlinked_time this_mod hs_unlinked return (Just linkable) handleInterpreted HscNoRecomp @@ -200,7 +201,12 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) = ASSERT (isHsBoot src_flavour) return maybe_old_linkable handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) - = do stub_unlinked <- getStubLinkable hasStub + = do stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, @@ -210,7 +216,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- if the source is modified, then the linkable will -- be out of date. let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + (hs_unlinked ++ stub_o) return (Just linkable) let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) @@ -235,31 +241,17 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- The _stub.c file is derived from the haskell source file, possibly taking -- into account the -stubdir option. -- --- Consequently, we derive the _stub.o filename from the haskell object --- filename. --- --- This isn't necessarily the same as the object filename we --- would get if we just compiled the _stub.c file using the pipeline. --- For example: --- --- ghc src/A.hs -odir obj --- --- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with --- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want --- obj/A_stub.o. - -compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath -compileStub hsc_env mod location = do - -- compile the _stub.c file w/ gcc - let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) - (moduleName mod) location +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). - _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing return stub_o - -- --------------------------------------------------------------------------- -- Link @@ -276,11 +268,11 @@ link :: GhcLink -- interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -#ifdef GHCI link LinkInMemory _ _ _ - = do -- Not Linking...(demand linker will do the job) - return Succeeded -#endif + = if cGhcWithInterpreter == "YES" + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory link NoLink _ _ _ = return Succeeded @@ -291,11 +283,6 @@ link LinkBinary dflags batch_attempt_linking hpt link LinkDynLib dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt -#ifndef GHCI --- warning suppression -link other _ _ _ = panicBadLink other -#endif - panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) @@ -391,7 +378,30 @@ linkingNeeded dflags linkables pkg_deps = do let (lib_errs,lib_times) = splitEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else return False + else checkLinkInfo dflags pkg_deps exe_file + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | isWindowsTarget || isDarwinTarget + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file + debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info) + return (Just link_info /= m_exe_link_info) + +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default findHSLib :: [String] -> String -> IO (Maybe FilePath) findHSLib dirs lib = do @@ -436,7 +446,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do ( _, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output - Nothing{-no ModLocation-} + Nothing{-no ModLocation-} Nothing return out_file @@ -482,9 +492,11 @@ runPipeline -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o = do let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn @@ -516,9 +528,17 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo let get_output_fn = getOutputFilename stop_phase output basename -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc + let env = PipeEnv{ stop_phase, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state + + let PipeState{ hsc_env=hsc_env', maybe_loc } = state' + dflags' = hsc_dflags hsc_env' -- Sometimes, a compilation phase doesn't actually generate any output -- (eg. the CPP phase when -fcpp is not turned on). If we end on this @@ -536,38 +556,102 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo copyWithHeader dflags msg line_prag output_fn final_fn return (dflags', final_fn) +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +getDynFlags :: CompPipeline DynFlags +getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +io :: IO a -> CompPipeline a +io m = P $ \_env state -> do a <- m; return (state, a) + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + io $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc - -pipeLoop :: HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> IO (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc - - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) - - | not (phase `happensBefore` stop_phase) +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: Phase -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + PipeEnv{stop_phase} <- getPipeEnv + PipeState{hsc_env} <- getPipeState + case () of + _ | phase `eqPhase` stop_phase -- All done + -> return input_fn + + | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when -- this could happen, so if we reach here it is a panic. -- eg. it might happen if the -C flag is used on a source file that -- has {-# OPTIONS -fasm #-}. - = panic ("pipeLoop: at phase " ++ show phase ++ + -> panic ("pipeLoop: at phase " ++ show phase ++ " but I wanted to stop at phase " ++ show stop_phase) - | otherwise - = do debugTraceMsg (hsc_dflags hsc_env) 4 + | otherwise + -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4 (ptext (sLit "Running phase") <+> ppr phase) - (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc + dflags <- getDynFlags + (next_phase, output_fn) <- runPhase phase input_fn dflags + pipeLoop next_phase output_fn + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. getOutputFilename :: Phase -> PipelineOutput -> String @@ -585,21 +669,19 @@ getOutputFilename stop_phase output basename odir = objectDir dflags osuf = objectSuf dflags keep_hc = dopt Opt_KeepHcFiles dflags - keep_raw_s = dopt Opt_KeepRawSFiles dflags keep_s = dopt Opt_KeepSFiles dflags keep_bc = dopt Opt_KeepLlvmFiles dflags - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other is_last_phase = next_phase `eqPhase` stop_phase -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True As | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True @@ -630,31 +712,23 @@ getOutputFilename stop_phase output basename -- of a source file can change the latter stages of the pipeline from -- taking the via-C route to using the native code generator. -- -runPhase :: Phase -- ^ Do this phase first - -> Phase -- ^ Stop just before this phase - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -- ^ how to calculate the output filename - -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> IO (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename +runPhase :: Phase -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (Phase, -- next phase to run + FilePath) -- output filename -- Invariant: the output filename always contains the output -- Interesting case: Hsc when there is no recompilation to do -- Then the output filename is still a .o file + ------------------------------------------------------------------------------- -- Unlit phase -runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- phaseOutputFilename (Cpp sf) let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -668,56 +742,60 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l , SysTools.FileOption "" output_fn ] - SysTools.runUnlit dflags flags + io $ SysTools.runUnlit dflags flags - return (Cpp sf, dflags, maybe_loc, output_fn) + return (Cpp sf, output_fn) ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- getOptionsFromFile dflags0 input_fn +runPhase (Cpp sf) input_fn dflags0 + = do + src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns + unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (HsPp sf, dflags1, maybe_loc, input_fn) + return (HsPp sf, input_fn) else do - output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc - doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- phaseOutputFilename (HsPp sf) + io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- getOptionsFromFile dflags0 output_fn + src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + io $ checkProcessArgsResult unhandled_flags + unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - checkProcessArgsResult unhandled_flags - return (HsPp sf, dflags2, maybe_loc, output_fn) + setDynFlags dflags2 + + return (HsPp sf, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase (HsPp sf) input_fn dflags + = do if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Hsc sf, dflags, maybe_loc, input_fn) + return (Hsc sf, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- get_output_fn dflags (Hsc sf) maybe_loc - SysTools.runPp dflags + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + io $ SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -726,22 +804,26 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- getOptionsFromFile dflags output_fn + src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags src_opts - handleFlagWarnings dflags1 warns - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags + io $ handleFlagWarnings dflags1 warns - return (Hsc sf, dflags1, maybe_loc, output_fn) + return (Hsc sf, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) input_fn dflags0 = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -753,8 +835,10 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } + setDynFlags dflags + -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- + (hspp_buf,mod_name,imps,src_imps) <- io $ case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn @@ -771,7 +855,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- mkHomeModLocation2 dflags mod_name basename suff + location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -798,6 +882,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma o_file = ml_obj_file location4 -- The real object file + setModLocation location4 -- Figure out if the source has changed, for recompilation avoidance. -- @@ -806,11 +891,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationTime (basename <.> suff) let force_recomp = dopt Opt_ForceRecomp dflags - hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) - source_unchanged <- + hsc_lang = hscTarget dflags + source_unchanged <- io $ if force_recomp || not (isStopLn stop) -- Set source_unchanged to False unconditionally if -- (a) recompilation checker is off, or @@ -827,16 +912,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- get_output_fn dflags next_phase (Just location4) + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + setDynFlags dflags' + PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module - mod <- addHomeModuleToFinder hsc_env' mod_name location4 + mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -852,58 +938,64 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma ms_srcimps = src_imps } -- run the compiler! - result <- hscCompileOneShot hsc_env' + result <- io $ hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info case result of HscNoRecomp - -> do SysTools.touch dflags' "Touching object file" o_file + -> do io $ SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). - return (StopLn, dflags', Just location4, o_file) + return (StopLn, o_file) (HscRecomp hasStub _) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o + -> do case hasStub of + Nothing -> return () + Just stub_c -> + do stub_o <- io $ compileStub hsc_env' stub_c + setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make when (isHsBoot src_flavour) $ - SysTools.touch dflags' "Touching object file" o_file - return (next_phase, dflags', Just location4, output_fn) + io $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags Cmm maybe_loc - doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename Cmm + io $ doCpp dflags False{-not raw-} True{-include CC opts-} + input_fn output_fn + return (Cmm, output_fn) -runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc +runPhase Cmm input_fn dflags = do - let dflags = hsc_dflags hsc_env - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + PipeEnv{src_basename} <- getPipeEnv + let hsc_lang = hscTarget dflags + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- get_output_fn dflags next_phase maybe_loc + + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + extCoreName = src_basename ++ ".hcr" } - hscCompileCmmFile hsc_env' input_fn + setDynFlags dflags' + PipeState{hsc_env} <- getPipeState + + io $ hscCompileCmmFile hsc_env input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: -- --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -911,40 +1003,39 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let dflags = hsc_dflags hsc_env +runPhase cc_phase input_fn dflags + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc + = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them - pkgs <- if hcc then getHCFilePackages input_fn else return [] + pkgs <- if hcc then io $ getHCFilePackages input_fn else return [] -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- getPackageIncludePath dflags pkgs + pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags - gcc_extra_viac_flags <- getExtraViaCOpts dflags + let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- + pkg_extra_cc_opts <- io $ if cc_phase `eqPhase` HCc then return [] else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -959,23 +1050,19 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- Decide next phase - let mangle = dopt Opt_DoAsmMangling dflags - next_phase - | hcc && mangle = Mangle - | otherwise = As - output_fn <- get_output_fn dflags next_phase maybe_loc + let next_phase = As + output_fn <- phaseOutputFilename next_phase let more_hcc_opts = -#if i386_TARGET_ARCH -- on x86 the floating point regs have greater precision -- than a double, which leads to unpredictable results. -- By default, we turn this off with -ffloat-store unless -- the user specified -fexcess-precision. - (if dopt Opt_ExcessPrecision dflags - then [] - else [ "-ffloat-store" ]) ++ -#endif + (if platformArch (targetPlatform dflags) == ArchX86 && + not (dopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ -- gcc's -fstrict-aliasing allows two accesses to memory -- to be considered non-aliasing if they have different types. @@ -983,56 +1070,47 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - SysTools.runCc dflags ( + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" + | otherwise = "c" + io $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a -- -x c option. - [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp - then SysTools.Option "c++" - else SysTools.Option "c"] ++ - [ SysTools.FileOption "" input_fn + [ SysTools.Option "-x", SysTools.Option gcc_lang_opt + , SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn ] ++ map SysTools.Option ( - md_c_flags - ++ pic_c_flags + pic_c_flags -#if defined(mingw32_TARGET_OS) -- Stub files generated for foreign exports references the runIO_closure -- and runNonIO_closure symbols, which are defined in the base package. -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not. - ++ (if thisPackage dflags == basePackageId + ++ (if platformOS (targetPlatform dflags) == OSMinGW32 && + thisPackage dflags == basePackageId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) -#endif -#ifdef sparc_TARGET_ARCH -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction. Note that the user can still override this -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag -- regardless of the ordering. -- -- This is a temporary hack. - ++ ["-mcpu=v9"] -#endif - ++ (if hcc && mangle - then md_regd_c_flags - else []) - ++ (if hcc - then if mangle - then gcc_extra_viac_flags - else filter (=="-fwrapv") - gcc_extra_viac_flags - -- still want -fwrapv even for unreg'd - else []) + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then ["-mcpu=v9"] + else []) + ++ (if hcc - then more_hcc_opts + then gcc_extra_viac_flags ++ more_hcc_opts else []) - ++ [ verb, "-S", "-Wimplicit", cc_opt ] + ++ verbFlags + ++ [ "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] #ifdef darwin_TARGET_OS ++ framework_paths @@ -1043,84 +1121,58 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- --- Mangle phase - -runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - let mangler_opts = getOpts dflags opt_m - -#if i386_TARGET_ARCH - machdep_opts <- return [ show (stolen_x86_regs dflags) ] -#else - machdep_opts <- return [] -#endif - - let split = dopt Opt_SplitObjs dflags - next_phase - | split = SplitMangle - | otherwise = As - output_fn <- get_output_fn dflags next_phase maybe_loc - - SysTools.runMangle dflags (map SysTools.Option mangler_opts - ++ [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option machdep_opts) - - return (next_phase, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ -- Splitting phase -runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc +runPhase SplitMangle input_fn dflags = do -- tmp_pfx is the prefix used for the split .s files - -- We also use it as the file to contain the no. of split .s files (sigh) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" + + split_s_prefix <- io $ SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix - SysTools.runSplit dflags + io $ SysTools.runSplit dflags [ SysTools.FileOption "" input_fn , SysTools.FileOption "" split_s_prefix , SysTools.FileOption "" n_files_fn ] -- Save the number of split files for future references - s <- readFile n_files_fn + s <- io $ readFile n_files_fn let n_files = read s :: Int dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + setDynFlags dflags' + -- Remember to delete all these files - addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags', maybe_loc, "**splitmangle**") + return (SplitAs, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase As input_fn dflags + = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase -- we create directories for the object file, because it -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryHierarchy (takeDirectory output_fn) - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runAs dflags + io $ SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] -#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the -- instruction set. Note that the user can still override this @@ -1128,33 +1180,37 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- regardless of the ordering. -- -- This is a temporary hack. - ++ [ SysTools.Option "-mcpu=v9" ] -#endif + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) + ++ [ SysTools.Option "-c" , SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option md_c_flags) + ]) - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc + -- we'll handle the stub_o file in this phase, so don't MergeStub, + -- just jump straight to StopLn afterwards. + let next_phase = StopLn + output_fn <- phaseOutputFilename next_phase let base_o = dropExtension output_fn osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - createDirectoryHierarchy split_odir + io $ createDirectoryHierarchy split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. - fs <- getDirectoryContents split_odir - mapM_ removeFile $ map (split_odir ) $ filter (osuf `isSuffixOf`) fs + fs <- io $ getDirectoryContents split_odir + io $ mapM_ removeFile $ + map (split_odir ) $ filter (osuf `isSuffixOf`) fs let as_opts = getOpts dflags opt_a @@ -1163,14 +1219,15 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc Just x -> x let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" + + split_obj :: Int -> FilePath split_obj n = split_odir takeFileName base_o ++ "__" ++ show n <.> osuf - let (md_c_flags, _) = machdepCCOpts dflags let assemble_file n = SysTools.runAs dflags (map SysTools.Option as_opts ++ -#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the -- instruction set. Note that the user can still override this @@ -1178,28 +1235,51 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc -- regardless of the ordering. -- -- This is a temporary hack. - [ SysTools.Option "-mcpu=v9" ] ++ -#endif + (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) ++ + [ SysTools.Option "-c" , SysTools.Option "-o" , SysTools.FileOption "" (split_obj n) , SysTools.FileOption "" (split_s n) - ] - ++ map SysTools.Option md_c_flags) - - mapM_ assemble_file [1..n] + ]) + + io $ mapM_ assemble_file [1..n] + + -- Note [pipeline-split-init] + -- If we have a stub file, it may contain constructor + -- functions for initialisation of this module. We can't + -- simply leave the stub as a separate object file, because it + -- will never be linked in: nothing refers to it. We need to + -- ensure that if we ever refer to the data in this module + -- that needs initialisation, then we also pull in the + -- initialisation routine. + -- + -- To that end, we make a DANGEROUS ASSUMPTION here: the data + -- that needs to be initialised is all in the FIRST split + -- object. See Note [codegen-split-init]. + + PipeState{maybe_stub_o} <- getPipeState + case maybe_stub_o of + Nothing -> return () + Just stub_o -> io $ do + tmp_split_1 <- newTempName dflags osuf + let split_1 = split_obj 1 + copyFile split_1 tmp_split_1 + removeFile split_1 + joinObjectFiles dflags [tmp_split_1, stub_o] split_1 -- join them into a single .o file - joinObjectFiles dflags (map split_obj [1..n]) output_fn + io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmOpt input_fn dflags = do - let dflags = hsc_dflags hsc_env let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this for @@ -1210,71 +1290,81 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc then [SysTools.Option (llvmOpts !! opt_lvl)] else [] - output_fn <- get_output_fn dflags LlvmLlc maybe_loc + output_fn <- phaseOutputFilename LlvmLlc - SysTools.runLlvmOpt dflags + io $ SysTools.runLlvmOpt dflags ([ SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag ++ map SysTools.Option lo_opts) - return (LlvmLlc, dflags, maybe_loc, output_fn) + return (LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate llvmOpts = ["-mem2reg", "-O1", "-O2"] - ----------------------------------------------------------------------------- -- LlvmLlc phase -runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmLlc input_fn dflags = do - let dflags = hsc_dflags hsc_env let lc_opts = getOpts dflags opt_lc - let opt_lvl = max 0 (min 2 $ optLevel dflags) -#if darwin_TARGET_OS - let nphase = LlvmMangle -#else - let nphase = As -#endif - let rmodel | opt_PIC = "pic" + opt_lvl = max 0 (min 2 $ optLevel dflags) + rmodel | opt_PIC = "pic" | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- get_output_fn dflags nphase maybe_loc + output_fn <- phaseOutputFilename LlvmMangle - SysTools.runLlvmLlc dflags + io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, dflags, maybe_loc, output_fn) + return (LlvmMangle, output_fn) where -#if darwin_TARGET_OS - llvmOpts = ["-O1", "-O2", "-O2"] -#else - llvmOpts = ["-O1", "-O2", "-O3"] -#endif - + -- Bug in LLVM at O3 on OSX. + llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin + then ["-O1", "-O2", "-O2"] + else ["-O1", "-O2", "-O3"] ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmMangle input_fn _dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags As maybe_loc - llvmFixupAsm input_fn output_fn - return (As, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename As + io $ llvmFixupAsm input_fn output_fn + return (As, output_fn) +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase MergeStub input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + io $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (StopLn, output_fn) -- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = +runPhase other _input_fn _dflags = panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1306,35 +1396,83 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> [String] -> IO FilePath +mkExtraCObj :: DynFlags -> String -> IO FilePath mkExtraCObj dflags xs = do cFile <- newTempName dflags "c" oFile <- newTempName dflags "o" - writeFile cFile $ unlines xs + writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId - (md_c_flags, _) = machdepCCOpts dflags SysTools.runCc dflags ([Option "-c", FileOption "" cFile, Option "-o", FileOption "" oFile] ++ - map (FileOption "-I") (includeDirs rtsDetails) ++ - map Option md_c_flags) + map (FileOption "-I") (includeDirs rtsDetails)) return oFile -mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath] -mkRtsOptionsLevelObj dflags - = do let mkRtsEnabledObj val - = do fn <- mkExtraCObj dflags - ["#include \"Rts.h\"", - "#include \"RtsOpts.h\"", - "const rtsOptsEnabledEnum rtsOptsEnabled = " - ++ val ++ ";"] - return [fn] - case rtsOptsEnabled dflags of - RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone" - RtsOptsSafeOnly -> return [] -- The default - RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll" +mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath +mkExtraObjToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled, + extra_rts_opts, + link_opts link_info] + <> char '\n')) -- final newline, to + -- keep gcc happy + + where + mk_rts_opts_enabled val + = vcat [text "#include \"Rts.h\"", + text "#include \"RtsOpts.h\"", + text "const RtsOptsEnabledEnum rtsOptsEnabled = " <> + text val <> semi ] + + rts_opts_enabled = case rtsOptsEnabled dflags of + RtsOptsNone -> mk_rts_opts_enabled "RtsOptsNone" + RtsOptsSafeOnly -> empty -- The default + RtsOptsAll -> mk_rts_opts_enabled "RtsOptsAll" + + extra_rts_opts = case rtsOpts dflags of + Nothing -> empty + Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi + + link_opts info + | isDarwinTarget = empty + | isWindowsTarget = empty + | otherwise = hcat [ + text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, + text ",\\\"\\\",@note\\n", + text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + where + -- we need to escape twice: once because we're inside a C string, + -- and again because we're inside an asm string. + info' = text $ (escape.escape) info + + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + +-- The "link info" is a string representing the parameters of the +-- link. We save this information in the binary, and the next time we +-- link, if nothing else has changed, we use the link info stored in +-- the existing binary to decide whether to re-link or not. +getLinkInfo :: DynFlags -> [PackageId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages +#ifdef darwin_TARGET_OS + pkg_frameworks <- getPackageFrameworks dflags dep_packages +#endif + extra_ld_inputs <- readIORef v_Ld_inputs + let + link_info = (package_link_opts, +#ifdef darwin_TARGET_OS + pkg_frameworks, +#endif + rtsOpts dflags, + rtsOptsEnabled dflags, + dopt Opt_NoHsMain dflags, + extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) -- generates a Perl skript starting a parallel prg under PVM mk_pvm_wrapper_script :: String -> String -> String -> String @@ -1421,7 +1559,7 @@ getHCFilePackages filename = linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () linkBinary dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags output_fn = exeFileName dflags -- get the full list of packages to link with, by combining the @@ -1446,15 +1584,8 @@ linkBinary dflags o_files dep_packages = do let no_hs_main = dopt Opt_NoHsMain dflags let main_lib | no_hs_main = [] | otherwise = [ "-lHSrtsmain" ] - rtsEnabledObj <- mkRtsOptionsLevelObj dflags - rtsOptsObj <- case rtsOpts dflags of - Just opts -> - do fn <- mkExtraCObj dflags - -- We assume that the Haskell "show" does - -- the right thing here - ["char *ghc_rts_opts = " ++ show opts ++ ";"] - return [fn] - Nothing -> return [] + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1504,20 +1635,20 @@ linkBinary dflags o_files dep_packages = do rc_objs <- maybeCreateManifest dflags output_fn - let (md_c_flags, _) = machdepCCOpts dflags SysTools.runLink dflags ( - [ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags + [] -#ifdef mingw32_TARGET_OS -- Permit the linker to auto link _symbol to _imp_symbol. -- This lets us link against DLLs without needing an "import library". - ++ ["-Wl,--enable-auto-import"] -#endif + ++ (if platformOS (targetPlatform dflags) == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + ++ o_files ++ extra_ld_inputs ++ lib_path_opts @@ -1529,8 +1660,7 @@ linkBinary dflags o_files dep_packages = do #endif ++ pkg_lib_path_opts ++ main_lib - ++ rtsEnabledObj - ++ rtsOptsObj + ++ [extraLinkObj] ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts @@ -1549,19 +1679,15 @@ linkBinary dflags o_files dep_packages = do exeFileName :: DynFlags -> FilePath exeFileName dflags | Just s <- outputFile dflags = -#if defined(mingw32_HOST_OS) - if null (takeExtension s) - then s <.> "exe" - else s -#else - s -#endif + if platformOS (targetPlatform dflags) == OSMinGW32 + then if null (takeExtension s) + then s <.> "exe" + else s + else s | otherwise = -#if defined(mingw32_HOST_OS) - "main.exe" -#else - "a.out" -#endif + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else "a.out" maybeCreateManifest :: DynFlags @@ -1623,7 +1749,7 @@ maybeCreateManifest dflags exe_filename = do linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let o_file = outputFile dflags pkgs <- getPreloadPackagesAnd dflags dep_packages @@ -1657,10 +1783,9 @@ linkDynLib dflags o_files dep_packages = do -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - let (md_c_flags, _) = machdepCCOpts dflags let extra_ld_opts = getOpts dflags opt_l - rtsEnabledObj <- mkRtsOptionsLevelObj dflags + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages #if defined(mingw32_HOST_OS) ----------------------------------------------------------------------------- @@ -1668,28 +1793,27 @@ linkDynLib dflags o_files dep_packages = do ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - ] ++ - [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | dopt Opt_SharedImplib dflags - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags + ] ++ map (SysTools.FileOption "") o_files ++ map SysTools.Option ( - md_c_flags -- Permit the linker to auto link _symbol to _imp_symbol -- This lets us link against DLLs without needing an "import library" - ++ ["-Wl,--enable-auto-import"] + ["-Wl,--enable-auto-import"] ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #elif defined(darwin_TARGET_OS) @@ -1728,15 +1852,14 @@ linkDynLib dflags o_files dep_packages = do Nothing -> do pwd <- getCurrentDirectory return $ pwd `combine` output_fn - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags - ++ o_files + o_files ++ [ "-undefined", "dynamic_lookup", "-single_module", #if !defined(x86_64_TARGET_ARCH) "-Wl,-read_only_relocs,suppress", @@ -1746,7 +1869,7 @@ linkDynLib dflags o_files dep_packages = do ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #else @@ -1764,14 +1887,13 @@ linkDynLib dflags o_files dep_packages = do -- non-PIC intra-package-relocations ["-Wl,-Bsymbolic"] - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags - ++ o_files + o_files ++ [ "-shared" ] ++ bsymbolicFlag -- Set the library soname. We use -h rather than -soname as @@ -1781,7 +1903,7 @@ linkDynLib dflags o_files dep_packages = do ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #endif @@ -1797,14 +1919,11 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let cc_opts - | not include_cc_opts = [] - | otherwise = (optc ++ md_c_flags) - where - optc = getOpts dflags opt_c - (md_c_flags, _) = machdepCCOpts dflags + | include_cc_opts = getOpts dflags opt_c + | otherwise = [] let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -1817,7 +1936,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do -- remember, in code we *compile*, the HOST is the same our TARGET, -- and BUILD is the same as our HOST. - cpp_prog ([SysTools.Option verb] + cpp_prog ( map SysTools.Option verbFlags ++ map SysTools.Option include_paths ++ map SysTools.Option hsSourceCppOpts ++ map SysTools.Option target_defs @@ -1852,16 +1971,21 @@ joinObjectFiles dflags o_files output_fn = do SysTools.Option "-nostdlib", SysTools.Option "-nodefaultlibs", SysTools.Option "-Wl,-r", + SysTools.Option ld_build_id, SysTools.Option ld_x_flag, SysTools.Option "-o", SysTools.FileOption "" output_fn ] - ++ map SysTools.Option md_c_flags ++ args) + ld_x_flag | null cLD_X = "" | otherwise = "-Wl,-x" - (md_c_flags, _) = machdepCCOpts dflags - + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none" + | otherwise = "" + if cLdIsGNULd == "YES" then do script <- newTempName dflags "ldscript" @@ -1885,19 +2009,3 @@ hscNextPhase dflags _ hsc_lang = HscInterpreted -> StopLn _other -> StopLn - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop _ current_hsc_lang - = hsc_lang - where - keep_hc = dopt Opt_KeepHcFiles dflags - hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - - -- force -fvia-C if we are being asked for a .hc file - | HCc <- stop = HscC - | keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9eac33c..e405aea 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -w #-} --- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@ -35,12 +32,21 @@ module DynFlags ( DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_windres, opt_lo, opt_lc, + + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, @@ -54,14 +60,13 @@ module DynFlags ( supportedLanguagesAndExtensions, -- ** DynFlag C compiler options - machdepCCOpts, picCCOpts, + picCCOpts, -- * Configuration of the stg-to-stg passes StgToDo(..), getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@ -72,9 +77,7 @@ module DynFlags ( #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN import Platform -#endif import Module import PackageConfig import PrelNames ( mAIN ) @@ -90,10 +93,14 @@ import Maybes ( orElse ) import SrcLoc import FastString import Outputable +#ifdef GHCI import Foreign.C ( CInt ) +#endif import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +#ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) +#endif import Data.IORef import Control.Monad ( when ) @@ -101,7 +108,6 @@ import Data.Char import Data.List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@ -252,7 +258,6 @@ data DynFlag | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@ -289,7 +294,6 @@ data DynFlag | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@ -353,6 +357,7 @@ data ExtensionFlag | Opt_KindSignatures | Opt_ParallelListComp | Opt_TransformListComp + | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo | Opt_DoRec @@ -395,10 +400,7 @@ data DynFlags = DynFlags { floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches -#ifndef OMIT_NATIVE_CODEGEN - targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. -#endif - stolen_x86_regs :: Int, + targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG. cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@ -443,42 +445,13 @@ data DynFlags = DynFlags { libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, hpcDir :: String, -- ^ Path to store the .mix files - -- options for particular phases - opt_L :: [String], - opt_P :: [String], - opt_F :: [String], - opt_c :: [String], - opt_m :: [String], - opt_a :: [String], - opt_l :: [String], - opt_windres :: [String], - opt_lo :: [String], -- LLVM: llvm optimiser - opt_lc :: [String], -- LLVM: llc static compiler - - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_m :: (String,[Option]), - pgm_s :: (String,[Option]), - pgm_a :: (String,[Option]), - pgm_l :: (String,[Option]), - pgm_dll :: (String,[Option]), - pgm_T :: String, - pgm_sysman :: String, - pgm_windres :: String, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@ -488,8 +461,6 @@ data DynFlags = DynFlags { -- Package flags extraPkgConfs :: [FilePath], - topDir :: FilePath, -- filled in by SysTools - systemPackageConfig :: FilePath, -- ditto -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. @@ -524,6 +495,105 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_m :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String] -- LLVM: llc static compiler + + } + +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = sOpt_P (settings dflags) +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = sOpt_c (settings dflags) +opt_m :: DynFlags -> [String] +opt_m dflags = sOpt_m (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@ -556,6 +626,14 @@ data HscTarget | HscNothing -- ^ Don't generate any code. See notes above. deriving (Eq, Show) +showHscTargetFlag :: HscTarget -> String +showHscTargetFlag HscC = "-fvia-c" +showHscTargetFlag HscAsm = "-fasm" +showHscTargetFlag HscLlvm = "-fllvm" +showHscTargetFlag HscJava = panic "No flag for HscJava" +showHscTargetFlag HscInterpreted = "-fbyte-code" +showHscTargetFlag HscNothing = "-fno-code" + -- | Will this target result in an object file on the disk? isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True @@ -618,8 +696,9 @@ defaultHscTarget = defaultObjectTarget -- object files on the current platform. defaultObjectTarget :: HscTarget defaultObjectTarget + | cGhcUnregisterised == "YES" = HscC | cGhcWithNativeCodeGen == "YES" = HscAsm - | otherwise = HscC + | otherwise = HscLlvm data DynLibLoader = Deployable @@ -627,6 +706,7 @@ data DynLibLoader deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@ -645,8 +725,8 @@ initDynFlags dflags = do -- | The normal 'DynFlags'. Note that they is not suitable for use in this form -- and must be fully initialized by 'GHC.newSession' first. -defaultDynFlags :: DynFlags -defaultDynFlags = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, @@ -665,10 +745,7 @@ defaultDynFlags = floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], -#ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, -#endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@ -697,25 +774,11 @@ defaultDynFlags = libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, hpcDir = ".hpc", - opt_L = [], - opt_P = (if opt_PIC - then ["-D__PIC__", "-U __PIC__"] -- this list is reversed - else []), - opt_F = [], - opt_c = [], - opt_a = [], - opt_m = [], - opt_l = [], - opt_windres = [], - opt_lo = [], - opt_lc = [], - extraPkgConfs = [], packageFlags = [], pkgDatabase = Nothing, @@ -724,26 +787,7 @@ defaultDynFlags = buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - pgm_L = panic "defaultDynFlags: No pgm_L", - pgm_P = panic "defaultDynFlags: No pgm_P", - pgm_F = panic "defaultDynFlags: No pgm_F", - pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_m = panic "defaultDynFlags: No pgm_m", - pgm_s = panic "defaultDynFlags: No pgm_s", - pgm_a = panic "defaultDynFlags: No pgm_a", - pgm_l = panic "defaultDynFlags: No pgm_l", - pgm_dll = panic "defaultDynFlags: No pgm_dll", - pgm_T = panic "defaultDynFlags: No pgm_T", - pgm_sysman = panic "defaultDynFlags: No pgm_sysman", - pgm_windres = panic "defaultDynFlags: No pgm_windres", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values + settings = mySettings, -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@ -878,10 +922,10 @@ getOpts dflags opts = reverse (opts dflags) -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlag :: DynFlags -> String -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, @@ -917,9 +961,9 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. -setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} -addOptl f d = d{ opt_l = f : opt_l d} -addOptP f d = d{ opt_P = f : opt_P d} +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) setDepMakefile :: FilePath -> DynFlags -> DynFlags @@ -1057,16 +1101,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - let (pic_warns, dflags2) -#if !(x86_64_TARGET_ARCH && linux_TARGET_OS) - | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm - = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" - ++ "dynamic on this platform;\n ignoring -fllvm"], - dflags1{ hscTarget = HscAsm }) -#endif - | otherwise = ([], dflags1) - - return (dflags2, leftover, pic_warns ++ warns) + return (dflags1, leftover, warns) {- ********************************************************************** @@ -1100,30 +1135,30 @@ dynamic_flags = [ ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f})) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) - , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d})) - , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d})) + , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f d -> d{ opt_F = f : opt_F d})) - , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d})) - , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d})) - , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d})) + , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) , Flag "split-objs" (NoArg (if can_split @@ -1177,8 +1212,8 @@ dynamic_flags = [ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural @@ -1289,9 +1324,9 @@ dynamic_flags = [ ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- @@ -1304,10 +1339,11 @@ dynamic_flags = [ , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArg (setOptLevel 1)) - , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead") - , Flag "Odph" (noArg setDPHOpt) - , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) + , Flag "O" (noArgM (setOptLevel 1)) + , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , Flag "Odph" (noArgM setDPHOpt) + , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) @@ -1322,7 +1358,7 @@ dynamic_flags = [ , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) - , Flag "ffloat-all-lams" (intSuffix (\n d -> d{ floatLamArgs = Nothing })) + , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- @@ -1478,7 +1514,6 @@ fFlags = [ ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@ -1575,6 +1610,7 @@ xFlags = [ ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), ( "ParallelListComp", Opt_ParallelListComp, nop ), ( "TransformListComp", Opt_TransformListComp, nop ), + ( "MonadComprehensions", Opt_MonadComprehensions, nop), ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), @@ -1583,9 +1619,9 @@ xFlags = [ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, + ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), + ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), @@ -1650,10 +1686,12 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, @@ -1837,18 +1875,20 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt rtsIsProfiled :: Bool rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0 +#endif checkTemplateHaskellOk :: Bool -> DynP () -checkTemplateHaskellOk turn_on +#ifdef GHCI +checkTemplateHaskellOk turn_on | turn_on && rtsIsProfiled = addErr "You can't use Template Haskell with a profiled compiler" | otherwise = return () #else --- In stage 1 we don't know that the RTS has rts_isProfiled, +-- In stage 1 we don't know that the RTS has rts_isProfiled, -- so we simply say "ok". It doesn't matter because TH isn't -- available in stage 1 anyway. -checkTemplateHaskellOk turn_on = return () +checkTemplateHaskellOk _ = return () #endif {- ********************************************************************** @@ -1860,13 +1900,21 @@ checkTemplateHaskellOk turn_on = return () type DynP = EwM (CmdLineP DynFlags) upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do { dfs <- getCmdLineState - ; putCmdLineState $! (f dfs) }) +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' --------------- Constructor functions for OptKind ----------------- noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) noArg fn = NoArg (upd fn) +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) noArgDF fn deprec = NoArg (upd fn >> deprecate deprec) @@ -1880,6 +1928,10 @@ hasArgDF fn deprec = HasArg (\s -> do { upd (fn s) intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) @@ -1905,6 +1957,10 @@ unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f) -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag = do { setDynFlag dump_flag @@ -1974,20 +2030,43 @@ setTarget l = upd set -- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () -setObjTarget l = upd set +setObjTarget l = updM set where - set dfs - | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l } - | otherwise = dfs - -setOptLevel :: Int -> DynFlags -> DynFlags + set dflags + | isObjectTarget (hscTarget dflags) + = case l of + HscC + | cGhcUnregisterised /= "YES" -> + do addWarn ("Compiler not unregisterised, so ignoring " ++ flag) + return dflags + HscAsm + | cGhcWithNativeCodeGen /= "YES" -> + do addWarn ("Compiler has no native codegen, so ignoring " ++ + flag) + return dflags + HscLlvm + | cGhcUnregisterised == "YES" -> + do addWarn ("Compiler unregisterised, so ignoring " ++ flag) + return dflags + | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && + (not opt_Static || opt_PIC) + -> + do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") + return dflags + _ -> return $ dflags { hscTarget = l } + | otherwise = return dflags + where platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + flag = showHscTargetFlag l + +setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags | hscTarget dflags == HscInterpreted && n > 0 - = dflags - -- not in IO any more, oh well: - -- putStr "warning: -O conflicts with --interactive; -O ignored.\n" + = do addWarn "-O conflicts with --interactive; -O ignored." + return dflags | otherwise - = updOptLevel n dflags + = return (updOptLevel n dflags) -- -Odph is equivalent to @@ -1996,7 +2075,7 @@ setOptLevel n dflags -- -fmax-simplifier-iterations20 this is necessary sometimes -- -fsimplifier-phases=3 we use an additional simplifier phase for fusion -- -setDPHOpt :: DynFlags -> DynFlags +setDPHOpt :: DynFlags -> DynP DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , simplPhases = 3 }) @@ -2119,7 +2198,7 @@ splitPathList s = filter notNull (splitUp s) -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = normalise dir } +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@ -2144,103 +2223,14 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} -- There are some options that we need to pass to gcc when compiling -- Haskell code via C, but are only supported by recent versions of -- gcc. The configure script decides which of these options we need, --- and puts them in the file "extra-gcc-opts" in $topdir, which is --- read before each via-C compilation. The advantage of having these --- in a separate file is that the file can be created at install-time --- depending on the available gcc version, and even re-generated later --- if gcc is upgraded. +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. -- -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) - -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags -#if alpha_TARGET_ARCH - = ( ["-w", "-mieee" -#ifdef HAVE_THREADED_RTS_SUPPORT - , "-D_REENTRANT" -#endif - ], [] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif hppa_TARGET_ARCH - -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! - -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) - -#elif i386_TARGET_ARCH - -- -fno-defer-pop : basically the same game as for m68k - -- - -- -fomit-frame-pointer : *must* in .hc files; because we're stealing - -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) -#else - = ( [], [] ) -#endif - picCCOpts :: DynFlags -> [String] picCCOpts _dflags #if darwin_TARGET_OS @@ -2283,30 +2273,34 @@ can_split = cSupportsSplitObjs == "YES" -- ----------------------------------------------------------------------------- -- Compiler Info -data Printable = String String - | FromDynFlags (DynFlags -> String) - -compilerInfo :: [(String, Printable)] -compilerInfo = [("Project name", String cProjectName), - ("Project version", String cProjectVersion), - ("Booter version", String cBooterVersion), - ("Stage", String cStage), - ("Build platform", String cBuildPlatformString), - ("Host platform", String cHostPlatformString), - ("Target platform", String cTargetPlatformString), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting supported", String cSupportsSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Support SMP", String cGhcWithSMP), - ("Unregisterised", String cGhcUnregisterised), - ("Tables next to code", String cGhcEnableTablesNextToCode), - ("RTS ways", String cGhcRTSWays), - ("Leading underscore", String cLeadingUnderscore), - ("Debug on", String (show debugIsOn)), - ("LibDir", FromDynFlags topDir), - ("Global Package DB", FromDynFlags systemPackageConfig), - ("C compiler flags", String (show cCcOpts)), - ("Gcc Linker flags", String (show cGccLinkerOpts)), - ("Ld Linker flags", String (show cLdLinkerOpts)) - ] +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : rawSettings dflags + ++ [("Project version", cProjectVersion), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", cSupportsSplitObjs), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Unregisterised", cGhcUnregisterised), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + ("Global Package DB", systemPackageConfig dflags), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ] diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index d8a6271..3ac3a47 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -37,21 +37,21 @@ import PrelNames ( gHC_PRIM ) import DynFlags import Outputable import UniqFM -import Maybes ( expectJust ) +import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text import Distribution.Package hiding (PackageId) -import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) +import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import System.Time ( ClockTime ) +import System.Time ( ClockTime ) import Data.List ( partition ) -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file -- ----------------------------------------------------------------------------- -- The Finder @@ -74,9 +74,9 @@ flushFinderCaches hsc_env = do writeIORef fc_ref emptyUFM flushModLocationCache this_pkg mlc_ref where - this_pkg = thisPackage (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - mlc_ref = hsc_MLC hsc_env + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + mlc_ref = hsc_MLC hsc_env flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do @@ -84,7 +84,7 @@ flushModLocationCache this_pkg ref = do _ <- evaluate =<< readIORef ref return () where is_ext mod _ | modulePackageId mod /= this_pkg = True - | otherwise = False + | otherwise = False addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () addToFinderCache ref key val = @@ -103,7 +103,7 @@ removeFromModLocationCache ref key = atomicModifyIORef ref $ \c -> (delModuleEnv c key, ()) lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) -lookupFinderCache ref key = do +lookupFinderCache ref key = do c <- readIORef ref return $! lookupUFM c key @@ -125,30 +125,30 @@ lookupModLocationCache ref key = do findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findImportedModule hsc_env mod_name mb_pkg = case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import where home_import = findHomeModule hsc_env mod_name pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule hsc_env mod_name Nothing + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out -- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, +-- reading the interface for a module mentioned by another interface, -- for example (a "system import"). findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env in - if modulePackageId mod == thisPackage dflags - then findHomeModule hsc_env (moduleName mod) - else findPackageModule hsc_env mod + let dflags = hsc_dflags hsc_env + in if modulePackageId mod == thisPackage dflags + then findHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- -- Helpers @@ -175,15 +175,15 @@ orIfNotFound this or_this = do homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult homeSearchCache hsc_env mod_name do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod_name - case m of + case m of Just result -> return result Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod_name result - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod_name result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult @@ -229,10 +229,10 @@ modLocationCache hsc_env mod do_this = do Just loc -> return (Found loc mod) Nothing -> do result <- do_this - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result where mlc = hsc_MLC hsc_env @@ -250,7 +250,7 @@ uncacheModule hsc_env mod = do removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod) -- ----------------------------------------------------------------------------- --- The internal workers +-- The internal workers -- | Search for a module in the home package only. findHomeModule :: HscEnv -> ModuleName -> IO FindResult @@ -262,60 +262,58 @@ findHomeModule hsc_env mod_name = hisuf = hiSuf dflags mod = mkModule (thisPackage dflags) mod_name - source_exts = + source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") ] - - hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts + | otherwise = source_exts in -- special case for GHC.Prim; we won't find it in the filesystem. -- This is important only when compiling the base package (where GHC.Prim -- is a home module). - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else - - searchPathExts home_path mod exts + else searchPathExts home_path mod exts -- | Search for a module in external packages only. findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let - dflags = hsc_dflags hsc_env - pkg_id = modulePackageId mod - pkg_map = pkgIdMap (pkgState dflags) + dflags = hsc_dflags hsc_env + pkg_id = modulePackageId mod + pkg_map = pkgIdMap (pkgState dflags) -- case lookupPackage pkg_map pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf - + findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult -findPackageModule_ hsc_env mod pkg_conf = +findPackageModule_ hsc_env mod pkg_conf = modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else + else let dflags = hsc_dflags hsc_env tag = buildTag dflags - -- hi-suffix for packages depends on the build tag. + -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" + | otherwise = tag ++ "_hi" mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf @@ -337,38 +335,38 @@ findPackageModule_ hsc_env mod pkg_conf = -- General path searching searchPathExts - :: [FilePath] -- paths to search - -> Module -- module name + :: [FilePath] -- paths to search + -> Module -- module name -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action ) - ] + ] -> IO FindResult -searchPathExts paths mod exts +searchPathExts paths mod exts = do result <- search to_search {- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result where basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] search [] = return (NotFound { fr_paths = map fst to_search , fr_pkg = Just (modulePackageId mod) @@ -377,12 +375,12 @@ searchPathExts paths mod exts search ((file, mk_result) : rest) = do b <- doesFileExist file - if b - then do { loc <- mk_result; return (Found loc mod) } - else search rest + if b + then do { loc <- mk_result; return (Found loc mod) } + else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation + -> FilePath -> BaseName -> IO ModLocation mkHomeModLocationSearched dflags mod suff path basename = do mkHomeModLocation2 dflags mod (path basename) suff @@ -417,7 +415,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do -- (b) and (c): The filename of the source file, minus its extension -- -- ext --- The filename extension of the source file (usually "hs" or "lhs"). +-- The filename extension of the source file (usually "hs" or "lhs"). mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation mkHomeModLocation dflags mod src_filename = do @@ -425,10 +423,10 @@ mkHomeModLocation dflags mod src_filename = do mkHomeModLocation2 dflags mod basename extension mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = moduleNameSlashes mod @@ -436,37 +434,37 @@ mkHomeModLocation2 dflags mod src_basename ext = do hi_fn <- mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn }) + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation + -> IO ModLocation mkHiOnlyModLocation dflags hisuf path basename = do let full_basename = path basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn } -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkObjPath dflags basename mod_basename = do let - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename return (obj_basename <.> osuf) @@ -474,16 +472,16 @@ mkObjPath dflags basename mod_basename -- Does /not/ check whether the .hi file exists mkHiPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkHiPath dflags basename mod_basename = do let - hidir = hiDir dflags - hisuf = hiSuf dflags + hidir = hiDir dflags + hisuf = hiSuf dflags - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename return (hi_basename <.> hisuf) @@ -498,14 +496,14 @@ mkStubPaths :: DynFlags -> ModuleName -> ModLocation - -> (FilePath,FilePath,FilePath) + -> FilePath mkStubPaths dflags mod location = let stubdir = stubDir dflags mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" + src_basename = dropExtension $ expectJust "mkStubPaths" (ml_hs_file location) stub_basename0 @@ -513,37 +511,27 @@ mkStubPaths dflags mod location | otherwise = src_basename stub_basename = stub_basename0 ++ "_stub" - - obj = ml_obj_file location - osuf = objectSuf dflags - stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub" - -- NB. not takeFileName, see #3093 in - (stub_basename <.> "c", - stub_basename <.> "h", - stub_obj_base <.> objectSuf dflags) + stub_basename <.> "h" -- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, +-- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) -- Make an object linkable when we know the object file exists, and we know -- its modification time. findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = do - let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o" - stub_exist <- doesFileExist stub_fn - if stub_exist - then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) - else return (LM obj_time mod [DotO obj_fn]) +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) -- ----------------------------------------------------------------------------- -- Error messages @@ -561,7 +549,7 @@ cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageIdString) pkgs)] + hsep (map (text.packageIdString) pkgs)] ) cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) @@ -572,15 +560,15 @@ cantFindErr cannot_find _ dflags mod_name find_result more_info = case find_result of - NoPackage pkg - -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> - ptext (sLit "was found") + NoPackage pkg + -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> + ptext (sLit "was found") NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= thisPackage dflags - -> not_found_in_package pkg files + | Just pkg <- mb_pkg, pkg /= thisPackage dflags + -> not_found_in_package pkg files | not (null suggest) -> pp_suggestions suggest $$ tried_these files @@ -588,8 +576,8 @@ cantFindErr cannot_find _ dflags mod_name find_result | null files && null mod_hiddens && null pkg_hiddens -> ptext (sLit "It is not a module in the current program, or in any known package.") - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ vcat (map mod_hidden mod_hiddens) $$ tried_these files @@ -616,10 +604,10 @@ cantFindErr cannot_find _ dflags mod_name find_result tried_these files | null files = empty | verbosity dflags < 3 = - ptext (sLit "Use -v to see a list of the files searched for.") + ptext (sLit "Use -v to see a list of the files searched for.") | otherwise = hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) - + pkg_hidden pkg = ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkg) <> dot $$ cabal_pkg_hidden_hint pkg diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0d94ade..a9e652d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -431,8 +431,8 @@ initGhcMonad mb_top_dir = do liftIO $ StaticFlags.initStaticOpts - dflags0 <- liftIO $ initDynFlags defaultDynFlags - dflags <- liftIO $ initSysTools mb_top_dir dflags0 + mySettings <- liftIO $ initSysTools mb_top_dir + dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings) env <- liftIO $ newHscEnv dflags setSession env @@ -756,9 +756,7 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: [CoreBind], - -- | Imports - cm_imports :: ![Module] + cm_binds :: [CoreBind] } instance Outputable CoreModule where @@ -857,11 +855,11 @@ compileCore simplify fn = do gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule (Left (cg, md)) = CoreModule { cm_module = cg_module cg, cm_types = md_types md, - cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + cm_binds = cg_binds cg } gutsToCoreModule (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = mg_types mg, - cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + cm_binds = mg_binds mg } -- %************************************************************************ diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5f9380a..ab65894 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,1463 +1,1475 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005 --- --- This module deals with --make --- ----------------------------------------------------------------------------- - -module GhcMake( - depanal, - load, LoadHowMuch(..), - - topSortModuleGraph, - - noModError, cyclicModuleErr - ) where - -#include "HsVersions.h" - -#ifdef GHCI -import qualified Linker ( unload ) -#endif - -import DriverPipeline -import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils -import DynFlags -import HsSyn hiding ((<.>)) -import Finder -import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) - -import Exception ( evaluate, tryIO ) -import Panic -import SysTools -import BasicTypes -import SrcLoc -import Util -import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer -import FastString -import Outputable -import UniqFM - -import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) - -import System.Directory ( doesFileExist, getModificationTime ) -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.Time ( ClockTime ) -import System.FilePath -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.List as List - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compilating --- and loading may result in files being created on disk. --- --- Calls the 'reportModuleCompilationResult' callback after each compiling --- each module, whether successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the callback. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - hsc_env1 <- getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - --- Finish up after a load. - --- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag - -> m SuccessFlag -loadFinish _all_ok Failed - = do hsc_env <- getSession - liftIO $ unload hsc_env [] - modifySession discardProg - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } - return all_ok - - --- Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } - --- used to fish out the preprocess output files for the purposes of --- cleaning up. The preprocessed file *might* be the same as the --- source file, but that doesn't do any harm. -ppFilesFromSummaries :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - -#if defined(mingw32_HOST_OS) - -- we must add the .exe extention unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name_exe = fmap (<.> "exe") name -#else - name_exe = name -#endif - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } - --- ----------------------------------------------------------------------------- - --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - For non-stable modules: --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. - -pruneHomePackageTable - :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapUFM prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - - is_stable m = m `elem` stable_obj || m `elem` stable_bco - --- ----------------------------------------------------------------------------- - --- Return (names of) all those in modsDone who are part of a cycle --- as defined by theGraph. -findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] -findPartiallyCompletedCycles modsDone theGraph - = chew theGraph - where - chew [] = [] - chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. - chew ((CyclicSCC vs):rest) - = let names_in_this_cycle = nub (map ms_mod vs) - mods_in_this_cycle - = nub ([done | done <- modsDone, - done `elem` names_in_this_cycle]) - chewed_rest = chew rest - in - if notNull mods_in_this_cycle - && length mods_in_this_cycle < length names_in_this_cycle - then mods_in_this_cycle ++ chewed_rest - else chewed_rest - - --- --------------------------------------------------------------------------- --- Unloading - -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of -#ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables -#else - LinkInMemory -> panic "unload: no interpreter" - -- urgh. avoid warnings: - hsc_env stable_linkables -#endif - _other -> return () - --- ----------------------------------------------------------------------------- - -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. --} - -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO - -checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs - where - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (scc_mods ++ stable_obj, stable_bco) - | stableBCOs = (stable_obj, scc_mods ++ stable_bco) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - - bco_ok ms - = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - --- ----------------------------------------------------------------------------- - --- | The upsweep --- --- This is where we compile each module in the module graph, in a pass --- from the bottom to the top of the graph. --- --- There better had not be any cyclic groups here -- we check for them. - -upsweep - :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) - -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' in the monad has an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep old_hpt stable_mods cleanup sccs = do - (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) - return (res, reverse done) - where - - upsweep' _old_hpt done - [] _ _ - = return (Succeeded, done) - - upsweep' _old_hpt done - (CyclicSCC ms:_) _ _ - = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) - return (Failed, done) - - upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger - - hsc_env <- getSession - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - liftIO cleanup -- Remove unwanted tmp files between compilations - - case mb_mod_info of - Nothing -> return (Failed, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod - - done' = mod:done - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. See reTypecheckLoop, below. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' - setSession hsc_env2 - - upsweep' old_hpt1 done' mods (mod_index+1) nmods - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> IO HomeModInfo - -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - - old_hmi = lookupUFM old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fvia-C to -fasm and vice-versa, otherwise we could - -- end up trying to link object code to byte code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: Maybe Linkable -> IO HomeModInfo - compile_it mb_linkable = - compile hsc_env summary' mod_index nmods - mb_old_iface mb_linkable - - compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo - compile_it_discard_iface mb_linkable = - compile hsc_env summary' mod_index nmods - Nothing mb_linkable - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing - - - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops - -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | not (isBootSummary ms) && - any (\m -> ms_mod m == this_mod && isBootSummary m) graph - = do - let mss = reachableBackwards (ms_mod_name ms) graph - non_boot = filter (not.isBootSummary) mss - debugTraceMsg (hsc_dflags hsc_env) 2 $ - text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) - typecheckLoop hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - where - this_mod = ms_mod ms - -typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop hsc_env mods = do - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToUFM old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = ghcError (ProgramError "module does not exist") - in graphFromEdgedVertices (seq root (reachableG graph root)) - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey (_, k, _) = k - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary (s, _, _) = s - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ (s, key, out_keys) - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False - - -type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) - ------------------------------------------------------------------------------ --- Downsweep (dependency analysis) - --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. - --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. - -downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do - rootSummaries <- mapM getRootSummary roots - let root_map = mkRootMap rootSummaries - checkDuplicates root_map - summs <- loop (concatMap msDeps rootSummaries) root_map - return summs - where - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: [(Located ModuleName,IsBootInterface)] - -- Work list: process these modules - -> NodeMap [ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO [ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr summs; return [] } - | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) - --- XXX Does the (++) here need to be flipped? -mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [s]) | s <- summaries ] - Map.empty - -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] --- (msDeps s) returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] - -home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) - -> IO ModSummary - -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file - = do - let location = ms_location old_summary - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationTime may fail, but that's the right - -- behaviour. - - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False - else return Nothing - return old_summary{ ms_obj_date = obj_timestamp } - else - new_summary - - | otherwise - = new_summary - where - new_summary = do - let dflags = hsc_dflags hsc_env - - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- getMofificationTime may fail - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) - -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary -findSummaryBySourceFile summaries file - = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e - - | otherwise = find_it - where - dflags = hsc_dflags hsc_env - - hsc_src = if is_boot then HsBootFile else HsSrcFile - - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp - - find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> noModError dflags loc wanted_mod err - -- Not found - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t - - - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - return (Just (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) - - -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) -getObjTimestamp location is_boot - = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - -- case we bypass the preprocessing stage? - let - local_opts = getOptions dflags buf src_fn - -- - (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts - checkProcessArgsResult leftovers - handleFlagWarnings dflags' warns - - let - needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt Opt_Cpp dflags' = True - | dopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - - return (dflags', src_fn, buf) - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: SrcSpan -> String -> IO a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path - -packageModErr :: ModuleName -> IO a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -cyclicModuleErr :: [ModSummary] -> SDoc -cyclicModuleErr ms - = hang (ptext (sLit "Module imports form a cycle for modules:")) - 2 (vcat (map show_one ms)) - where - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- + +module GhcMake( + depanal, + load, LoadHowMuch(..), + + topSortModuleGraph, + + noModError, cyclicModuleErr + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker ( unload ) +#endif + +import DriverPipeline +import DriverPhases +import GhcMonad +import Module +import HscTypes +import ErrUtils +import DynFlags +import HsSyn hiding ((<.>)) +import Finder +import HeaderInfo +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import RdrName ( RdrName ) + +import Exception ( evaluate, tryIO ) +import Panic +import SysTools +import BasicTypes +import SrcLoc +import Util +import Digraph +import Bag ( listToBag ) +import Maybes ( expectJust, mapCatMaybes ) +import StringBuffer +import FastString +import Outputable +import UniqFM + +import qualified Data.Map as Map +import qualified FiniteMap as Map( insertListWith) + +import System.Directory ( doesFileExist, getModificationTime ) +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) +import System.Time ( ClockTime ) +import System.FilePath +import Control.Monad +import Data.Maybe +import Data.List +import qualified Data.List as List + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] + -> m SuccessFlag +load2 how_much mod_graph = do + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag + -> m SuccessFlag +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + return all_ok + + +-- Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = hsc_env { hsc_mod_graph = emptyMG, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable } + +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- + +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapUFM prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- + +-- Return (names of) all those in modsDone who are part of a cycle +-- as defined by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] +findPartiallyCompletedCycles modsDone theGraph + = chew theGraph + where + chew [] = [] + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. + chew ((CyclicSCC vs):rest) + = let names_in_this_cycle = nub (map ms_mod vs) + mods_in_this_cycle + = nub ([done | done <- modsDone, + done `elem` names_in_this_cycle]) + chewed_rest = chew rest + in + if notNull mods_in_this_cycle + && length mods_in_this_cycle < length names_in_this_cycle + then mods_in_this_cycle ++ chewed_rest + else chewed_rest + + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- + +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + + bco_ok ms + = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +-- ----------------------------------------------------------------------------- + +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. + +upsweep + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) + -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) + where + + upsweep' _old_hpt done + [] _ _ + = return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:_) _ _ + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 + + upsweep' old_hpt1 done' mods (mod_index+1) nmods + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo + +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable + + compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo + compile_it_discard_iface mb_linkable = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing + + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- Topological sort of the module graph + +type SummaryNode = (ModSummary, Int, [Int]) + +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False + + +type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + +----------------------------------------------------------------------------- +-- Downsweep (dependency analysis) + +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. + +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. + +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return summs + where + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr summs; return [] } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + +-- XXX Does the (++) here need to be flipped? +mkRootMap :: [ModSummary] -> NodeMap [ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty + +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] +-- (msDeps s) returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps s = + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env + + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- getMofificationTime may fail + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, ClockTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + hsc_src = if is_boot then HsBootFile else HsSrcFile + + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr loc src_fn + Just t -> new_summary location' mod src_fn t + + + new_summary location mod src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + -- Find the object timestamp, and return the summary + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) + = do + let dflags = hsc_dflags hsc_env + let local_opts = getOptions dflags buf src_fn + + (dflags', leftovers, warns) + <- parseDynamicNoPackageFlags dflags local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns + + let needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | xopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: SrcSpan -> String -> IO a +noHsFileErr loc path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr :: ModuleName -> IO a +packageModErr mod + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +cyclicModuleErr :: [ModSummary] -> SDoc +cyclicModuleErr ms + = hang (ptext (sLit "Module imports form a cycle for modules:")) + 2 (vcat (map show_one ms)) + where + mods_in_cycle = map ms_mod_name ms + imp_modname = unLoc . ideclName . unLoc + just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) + + show_one ms = + vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> + maybe empty (parens . text) (ml_hs_file (ms_location ms)), + nest 2 $ ptext (sLit "imports:") <+> vcat [ + pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), + pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] + ] + show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) + pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 711259c..4c72f14 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -15,11 +15,11 @@ module GhcMonad ( reflectGhc, reifyGhc, getSessionDynFlags, liftIO, - Session(..), withSession, modifySession, withTempSession, + Session(..), withSession, modifySession, withTempSession, -- ** Warnings logWarnings, printException, printExceptionAndWarnings, - WarnErrLogger, defaultWarnErrLogger + WarnErrLogger, defaultWarnErrLogger ) where import MonadUtils diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 37c65bb..6a5552f 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -109,7 +109,8 @@ import CoreToStg ( coreToStg ) import qualified StgCmm ( codeGen ) import StgSyn import CostCentre -import TyCon ( TyCon, isDataTyCon ) +import ProfInit +import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -460,7 +461,8 @@ error. This is the only thing that isn't caught by the type-system. data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- Has stub files. This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we just return True -- if we want the caller to compile them for us. a @@ -596,14 +598,14 @@ hscOneShotCompiler = , hscBackend = \ tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp False ()) + HscNothing -> return (HscRecomp Nothing ()) _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -649,7 +651,7 @@ hscBatchCompiler = , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -681,7 +683,7 @@ hscInteractiveCompiler = , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -710,7 +712,7 @@ hscNothingCompiler = , hscBackend = \tc_result _mod_summary mb_old_iface -> do handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -852,7 +854,7 @@ hscWriteIface iface no_change mod_summary -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc Bool -- ^ @True@ <=> stub.c exists + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv @@ -862,8 +864,7 @@ hscGenHardCode cgguts mod_summary cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_dir_imps = dir_imps, - cg_foreign = foreign_stubs, + cg_foreign = foreign_stubs0, cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env @@ -882,16 +883,19 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds + let prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + ------------------ Code generation ------------------ cmms <- if dopt Opt_TryNewCodeGen dflags then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- @@ -962,15 +966,15 @@ hscCompileCmmFile hsc_env filename -------------------- Stuff for new code gen --------------------- -tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module] +tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [(StgBinding,[(Id,[Id])])] -> HpcInfo -> IO [Cmm] -tryNewCodeGen hsc_env this_mod data_tycons imported_mods +tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do { let dflags = hsc_dflags hsc_env - ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods + ; prog <- StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" (pprCmms prog) @@ -1128,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it) hscTcExpr hsc_env expr = runHsc hsc_env $ do maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _)) -> - ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr - _ -> - liftIO $ throwIO $ mkSrcErr $ unitBag $ - mkPlainErrMsg noSrcSpan - (text "not an expression:" <+> quotes (text expr)) + Just (L _ (ExprStmt expr _ _ _)) -> + ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr + _ -> + liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan + (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type hscKcType diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3673b3e..11f1a8b 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -14,7 +14,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, @@ -25,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -76,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -494,6 +495,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -713,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is dicarded. +-- 'ModDetails' are extracted and the ModGuts is discarded. data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled @@ -795,11 +799,7 @@ data CgGuts -- data constructor workers; reason: we we regard them -- as part of the code-gen of tycons - cg_dir_imps :: ![Module], - -- ^ Directly-imported modules; used to generate - -- initialisation code - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -819,6 +819,10 @@ data ForeignStubs = NoStubs -- ^ We don't have any stubs -- -- 2) C stubs to use when calling -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) \end{code} \begin{code} @@ -1790,6 +1794,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5e265e8..451f78d 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -36,7 +36,7 @@ where #include "HsVersions.h" import PackageConfig -import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) ) +import DynFlags import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 54f0a92..5767a52 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -210,7 +210,6 @@ unregFlags :: [Located String] unregFlags = map (mkGeneralLocated "in unregFlags") [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" , "-funregisterised" ] ----------------------------------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 049b61f..732224b 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -167,7 +167,7 @@ try_read sw str = case reads str of ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arugments + -- ToDo: hack alert. We should really parse the arguments -- and announce errors in a more civilised way. @@ -192,16 +192,12 @@ opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") -- debugging options -- | Suppress all that is suppressable in core dumps. +-- Except for uniques, as some simplifier phases introduce new varibles that +-- have otherwise identical names. opt_SuppressAll :: Bool opt_SuppressAll = lookUp (fsLit "-dsuppress-all") --- | Suppress unique ids on variables. -opt_SuppressUniques :: Bool -opt_SuppressUniques - = lookUp (fsLit "-dsuppress-all") - || lookUp (fsLit "-dsuppress-uniques") - -- | Suppress all coercions, them replacing with '...' opt_SuppressCoercions :: Bool opt_SuppressCoercions @@ -232,10 +228,16 @@ opt_SuppressTypeSignatures = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-type-signatures") +-- | Suppress unique ids on variables. +-- Except for uniques, as some simplifier phases introduce new variables that +-- have otherwise identical names. +opt_SuppressUniques :: Bool +opt_SuppressUniques + = lookUp (fsLit "-dsuppress-uniques") -- | Display case expressions with a single alternative as strict let bindings opt_PprCaseAsLet :: Bool -opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") +opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") -- | Set the maximum width of the dumps -- If GHC's command line options are bad then the options parser uses the diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index d33fd6c..436cfa6 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,7 @@ ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS -fno-warn-unused-do-bind #-} module SysTools ( -- Initialisation initSysTools, @@ -14,17 +15,17 @@ module SysTools ( -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () + runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, runLlvmOpt, runLlvmLlc, + readElfSection, touch, -- String -> String -> IO () copy, copyWithHeader, - getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -45,6 +46,7 @@ import ErrUtils import Panic import Util import DynFlags +import StaticFlags import Exception import Data.IORef @@ -58,6 +60,8 @@ import System.Directory import Data.Char import Data.List import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -144,25 +148,47 @@ stuff. \begin{code} initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) - - -> DynFlags - -> IO DynFlags -- Set all the mutable variables above, holding + -> IO Settings -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message - - -initSysTools mbMinusB dflags0 +initSysTools mbMinusB = do { top_dir <- findTopDir mbMinusB -- see [Note topdir] -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated - ; let installed :: FilePath -> FilePath + ; let settingsFile = top_dir "settings" + installed :: FilePath -> FilePath installed file = top_dir file installed_mingw_bin file = top_dir ".." "mingw" "bin" file installed_perl_bin file = top_dir ".." "perl" file + ; settingsStr <- readFile settingsFile + ; mySettings <- case maybeReadFuzzy settingsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ show settingsFile) + ; let getSetting key = case lookup key mySettings of + Just xs -> + return xs + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc" + else getSetting "C compiler command" + ; gcc_args_str <- if isWindowsHost then return [] + else getSetting "C compiler flags" + ; let gcc_args = map Option (words gcc_args_str) + ; perl_path <- if isWindowsHost + then return $ installed_perl_bin "perl" + else getSetting "perl command" + ; let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" ghci_usage_msg_path = installed "ghci-usage.txt" @@ -171,30 +197,20 @@ initSysTools mbMinusB dflags0 -- architecture-specific stuff is done when building Config.hs unlit_path = installed cGHC_UNLIT_PGM - -- split and mangle are Perl scripts + -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - mangle_script = installed cGHC_MANGLER_PGM windres_path = installed_mingw_bin "windres" ; tmpdir <- getTemporaryDirectory - ; let dflags1 = setTmpDir tmpdir dflags0 - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin ; let - gcc_prog - | isWindowsHost = installed_mingw_bin "gcc" - | otherwise = cGCC - perl_path - | isWindowsHost = installed_perl_bin cGHC_PERL - | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows touch_path | isWindowsHost = installed cGHC_TOUCHY_PGM | otherwise = "touch" -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split and mangle. + -- a call to Perl to get the invocation of split. -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the -- front of the script at installation time, so we don't want @@ -202,9 +218,6 @@ initSysTools mbMinusB dflags0 (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mangle_prog, mangle_args) - | isWindowsHost = (perl_path, [Option mangle_script]) - | otherwise = (mangle_script, []) (mkdll_prog, mkdll_args) | not isWindowsHost = panic "Can't build DLLs on a non-Win32 system" @@ -214,38 +227,57 @@ initSysTools mbMinusB dflags0 -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - ; let cpp_path = (gcc_prog, - (Option "-E"):(map Option (words cRAWCPP_FLAGS))) + ; let cpp_prog = gcc_prog + cpp_args = Option "-E" + : map Option (words cRAWCPP_FLAGS) + ++ gcc_args -- Other things being equal, as and ld are simply gcc ; let as_prog = gcc_prog + as_args = gcc_args ld_prog = gcc_prog + ld_args = gcc_args - -- figure out llvm location. (TODO: Acutally implement). + -- We just assume on command line ; let lc_prog = "llc" lo_prog = "opt" - ; return dflags1{ - ghcUsagePath = ghc_usage_msg_path, - ghciUsagePath = ghci_usage_msg_path, - topDir = top_dir, - systemPackageConfig = pkgconfig_path, - pgm_L = unlit_path, - pgm_P = cpp_path, - pgm_F = "", - pgm_c = (gcc_prog,[]), - pgm_m = (mangle_prog,mangle_args), - pgm_s = (split_prog,split_args), - pgm_a = (as_prog,[]), - pgm_l = (ld_prog,[]), - pgm_dll = (mkdll_prog,mkdll_args), - pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", - pgm_windres = windres_path, - pgm_lo = (lo_prog,[]), - pgm_lc = (lc_prog,[]) + ; return $ Settings { + sTmpDir = normalise tmpdir, + sGhcUsagePath = ghc_usage_msg_path, + sGhciUsagePath = ghci_usage_msg_path, + sTopDir = top_dir, + sRawSettings = mySettings, + sExtraGccViaCFlags = words myExtraGccViaCFlags, + sSystemPackageConfig = pkgconfig_path, + sPgm_L = unlit_path, + sPgm_P = (cpp_prog, cpp_args), + sPgm_F = "", + sPgm_c = (gcc_prog, gcc_args), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog, as_args), + sPgm_l = (ld_prog, ld_args), + sPgm_dll = (mkdll_prog,mkdll_args), + sPgm_T = touch_path, + sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + sPgm_windres = windres_path, + sPgm_lo = (lo_prog,[]), + sPgm_lc = (lc_prog,[]), -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others + sOpt_L = [], + sOpt_P = (if opt_PIC + then -- this list gets reversed + ["-D__PIC__", "-U __PIC__"] + else []), + sOpt_F = [], + sOpt_c = [], + sOpt_a = [], + sOpt_m = [], + sOpt_l = [], + sOpt_windres = [], + sOpt_lo = [], + sOpt_lc = [] } } \end{code} @@ -372,11 +404,6 @@ getGccEnv opts = = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -runMangle :: DynFlags -> [Option] -> IO () -runMangle dflags args = do - let (p,args0) = pgm_m dflags - runSomething dflags "Mangler" p (args0++args) - runSplit :: DynFlags -> [Option] -> IO () runSplit dflags args = do let (p,args0) = pgm_s dflags @@ -454,10 +481,26 @@ copyWithHeader dflags purpose maybe_header from to = do hClose hout hClose hin -getExtraViaCOpts :: DynFlags -> IO [String] -getExtraViaCOpts dflags = do - f <- readFile (topDir dflags "extra-gcc-opts") - return (words f) +-- | read the contents of the named section in an ELF object as a +-- String. +readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) +readElfSection _dflags section exe = do + let + prog = "readelf" + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) "" + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces; + munch (const True) \end{code} %************************************************************************ @@ -489,8 +532,8 @@ cleanTempFilesExcept dflags dont_delete $ do let ref = filesToClean dflags files <- readIORef ref let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles dflags to_delete writeIORef ref to_keep + removeTmpFiles dflags to_delete -- find a temporary name that doesn't already exist. @@ -512,8 +555,9 @@ newTempName dflags extn -- return our temporary directory within tmp_dir, creating one if we -- don't have one yet getTempDir :: DynFlags -> IO FilePath -getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) +getTempDir dflags = do let ref = dirsToClean dflags + tmp_dir = tmpDir dflags mapping <- readIORef ref case Map.lookup tmp_dir mapping of Nothing -> diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b78c0db..f23280b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -292,8 +292,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, mg_binds = binds, mg_rules = imp_rules, mg_vect_info = vect_info, - mg_dir_imps = dir_imps, - mg_anns = anns, + mg_anns = anns, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -363,13 +362,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, <+> int (cs_ty cs) <+> int (cs_co cs) )) - ; let dir_imp_mods = moduleEnvKeys dir_imps - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_dir_imps = dir_imp_mods, - cg_foreign = foreign_stubs, + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, diff --git a/compiler/nativeGen/Alpha/CodeGen.hs b/compiler/nativeGen/Alpha/CodeGen.hs deleted file mode 100644 index 4ce774f..0000000 --- a/compiler/nativeGen/Alpha/CodeGen.hs +++ /dev/null @@ -1,789 +0,0 @@ -module Alpha.CodeGen () - -where - -{- - -getRegister :: CmmExpr -> NatM Register - -#if !x86_64_TARGET_ARCH - -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured - -- register, it can only be used for rip-relative addressing. -getRegister (CmmReg (CmmGlobal PicBaseReg)) - = do - reg <- getPicBaseNat wordSize - return (Fixed wordSize reg nilOL) -#endif - -getRegister (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) - - -#if WORD_SIZE_IN_BITS==32 - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -#endif - --- end of machine-"independent" bit; here we go on the rest... - - -getRegister (StDouble d) - = getBlockIdNat `thenNat` \ lbl -> - getNewRegNat PtrRep `thenNat` \ tmp -> - let code dst = mkSeqInstrs [ - LDATA RoDataSegment lbl [ - DATA TF [ImmLab (rational d)] - ], - LDA tmp (AddrImm (ImmCLbl lbl)), - LD TF dst (AddrReg tmp)] - in - return (Any FF64 code) - -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEG Q False) x - - NotOp -> trivialUCode NOT x - - FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x - DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x - - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x - - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP pr x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP pr x - - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode x - - other_op -> getRegister (StCall fn CCallConv FF64 [x]) - where - fn = case other_op of - FloatExpOp -> fsLit "exp" - FloatLogOp -> fsLit "log" - FloatSqrtOp -> fsLit "sqrt" - FloatSinOp -> fsLit "sin" - FloatCosOp -> fsLit "cos" - FloatTanOp -> fsLit "tan" - FloatAsinOp -> fsLit "asin" - FloatAcosOp -> fsLit "acos" - FloatAtanOp -> fsLit "atan" - FloatSinhOp -> fsLit "sinh" - FloatCoshOp -> fsLit "cosh" - FloatTanhOp -> fsLit "tanh" - DoubleExpOp -> fsLit "exp" - DoubleLogOp -> fsLit "log" - DoubleSqrtOp -> fsLit "sqrt" - DoubleSinOp -> fsLit "sin" - DoubleCosOp -> fsLit "cos" - DoubleTanOp -> fsLit "tan" - DoubleAsinOp -> fsLit "asin" - DoubleAcosOp -> fsLit "acos" - DoubleAtanOp -> fsLit "atan" - DoubleSinhOp -> fsLit "sinh" - DoubleCoshOp -> fsLit "cosh" - DoubleTanhOp -> fsLit "tanh" - where - pr = panic "MachCode.getRegister: no primrep needed for Alpha" - -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> trivialCode (CMP LTT) y x - CharGeOp -> trivialCode (CMP LE) y x - CharEqOp -> trivialCode (CMP EQQ) x y - CharNeOp -> int_NE_code x y - CharLtOp -> trivialCode (CMP LTT) x y - CharLeOp -> trivialCode (CMP LE) x y - - IntGtOp -> trivialCode (CMP LTT) y x - IntGeOp -> trivialCode (CMP LE) y x - IntEqOp -> trivialCode (CMP EQQ) x y - IntNeOp -> int_NE_code x y - IntLtOp -> trivialCode (CMP LTT) x y - IntLeOp -> trivialCode (CMP LE) x y - - WordGtOp -> trivialCode (CMP ULT) y x - WordGeOp -> trivialCode (CMP ULE) x y - WordEqOp -> trivialCode (CMP EQQ) x y - WordNeOp -> int_NE_code x y - WordLtOp -> trivialCode (CMP ULT) x y - WordLeOp -> trivialCode (CMP ULE) x y - - AddrGtOp -> trivialCode (CMP ULT) y x - AddrGeOp -> trivialCode (CMP ULE) y x - AddrEqOp -> trivialCode (CMP EQQ) x y - AddrNeOp -> int_NE_code x y - AddrLtOp -> trivialCode (CMP ULT) x y - AddrLeOp -> trivialCode (CMP ULE) x y - - FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y - FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y - FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y - FloatLeOp -> cmpF_code (FCMP TF LE) NE x y - - DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y - DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y - DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y - DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y - - IntAddOp -> trivialCode (ADD Q False) x y - IntSubOp -> trivialCode (SUB Q False) x y - IntMulOp -> trivialCode (MUL Q False) x y - IntQuotOp -> trivialCode (DIV Q False) x y - IntRemOp -> trivialCode (REM Q False) x y - - WordAddOp -> trivialCode (ADD Q False) x y - WordSubOp -> trivialCode (SUB Q False) x y - WordMulOp -> trivialCode (MUL Q False) x y - WordQuotOp -> trivialCode (DIV Q True) x y - WordRemOp -> trivialCode (REM Q True) x y - - FloatAddOp -> trivialFCode W32 (FADD TF) x y - FloatSubOp -> trivialFCode W32 (FSUB TF) x y - FloatMulOp -> trivialFCode W32 (FMUL TF) x y - FloatDivOp -> trivialFCode W32 (FDIV TF) x y - - DoubleAddOp -> trivialFCode W64 (FADD TF) x y - DoubleSubOp -> trivialFCode W64 (FSUB TF) x y - DoubleMulOp -> trivialFCode W64 (FMUL TF) x y - DoubleDivOp -> trivialFCode W64 (FDIV TF) x y - - AddrAddOp -> trivialCode (ADD Q False) x y - AddrSubOp -> trivialCode (SUB Q False) x y - AddrRemOp -> trivialCode (REM Q True) x y - - AndOp -> trivialCode AND x y - OrOp -> trivialCode OR x y - XorOp -> trivialCode XOR x y - SllOp -> trivialCode SLL x y - SrlOp -> trivialCode SRL x y - - ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll" - ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" - ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - - FloatPowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y]) - DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y]) - where - {- ------------------------------------------------------------ - Some bizarre special code for getting condition codes into - registers. Integer non-equality is a test for equality - followed by an XOR with 1. (Integer comparisons always set - the result register to 0 or 1.) Floating point comparisons of - any kind leave the result in a floating point register, so we - need to wrangle an integer register out of things. - -} - int_NE_code :: StixTree -> StixTree -> NatM Register - - int_NE_code x y - = trivialCode (CMP EQQ) x y `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) - in - return (Any IntRep code__2) - - {- ------------------------------------------------------------ - Comments for int_NE_code also apply to cmpF_code - -} - cmpF_code - :: (Reg -> Reg -> Reg -> Instr) - -> Cond - -> StixTree -> StixTree - -> NatM Register - - cmpF_code instr cond x y - = trivialFCode pr instr x y `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - getBlockIdNat `thenNat` \ lbl -> - let - code = registerCode register tmp - result = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - OR zeroh (RIImm (ImmInt 1)) dst, - BF cond result (ImmCLbl lbl), - OR zeroh (RIReg zeroh) dst, - NEWBLOCK lbl] - in - return (Any IntRep code__2) - where - pr = panic "trivialU?FCode: does not use PrimRep on Alpha" - ------------------------------------------------------------ - -getRegister (CmmLoad pk mem) - = getAmode mem `thenNat` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = primRepToSize pk - code__2 dst = code . mkSeqInstr (LD size dst src) - in - return (Any pk code__2) - -getRegister (StInt i) - | fits8Bits i - = let - code dst = mkSeqInstr (OR zeroh (RIImm src) dst) - in - return (Any IntRep code) - | otherwise - = let - code dst = mkSeqInstr (LDI Q dst src) - in - return (Any IntRep code) - where - src = ImmInt (fromInteger i) - -getRegister leaf - | isJust imm - = let - code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) - in - return (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - - -getAmode :: CmmExpr -> NatM Amode -getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if alpha_TARGET_ARCH - -getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - return (Amode (AddrRegImm reg off) code) - -getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - return (Amode (AddrRegImm reg off) code) - -getAmode leaf - | isJust imm - = return (Amode (AddrImm imm__2) id) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -getAmode other - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister other `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - in - return (Amode (AddrReg reg) code) - -#endif /* alpha_TARGET_ARCH */ - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock - - -assignIntCode pk (CmmLoad dst _) src - = getNewRegNat IntRep `thenNat` \ tmp -> - getAmode dst `thenNat` \ amode -> - getRegister src `thenNat` \ register -> - let - code1 = amodeCode amode [] - dst__2 = amodeAddr amode - code2 = registerCode register tmp [] - src__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - return code__2 - -assignIntCode pk dst src - = getRegister dst `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> - let - dst__2 = registerName register1 zeroh - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) - else code - in - return code__2 - -assignFltCode pk (CmmLoad dst _) src - = getNewRegNat pk `thenNat` \ tmp -> - getAmode dst `thenNat` \ amode -> - getRegister src `thenNat` \ register -> - let - code1 = amodeCode amode [] - dst__2 = amodeAddr amode - code2 = registerCode register tmp [] - src__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - return code__2 - -assignFltCode pk dst src - = getRegister dst `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> - let - dst__2 = registerName register1 zeroh - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code . mkSeqInstr (FMOV src__2 dst__2) - else code - in - return code__2 - - --- ----------------------------------------------------------------------------- --- Generating an non-local jump - --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -genJump (CmmLabel lbl) - | isAsmTemp lbl = returnInstr (BR target) - | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0] - where - target = ImmCLbl lbl - -genJump tree - = getRegister tree `thenNat` \ register -> - getNewRegNat PtrRep `thenNat` \ tmp -> - let - dst = registerName register pv - code = registerCode register pv - target = registerName register pv - in - if isFixed register then - returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0] - else - return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) - - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock - -genBranch = return . toOL . mkBranchInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -ALPHA: For comparisons with 0, we're laughing, because we can just do -the desired conditional branch. - --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -genCondJump id (StPrim op [x, StInt 0]) - = getRegister x `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerRep register - target = ImmCLbl lbl - in - returnSeq code [BI (cmpOp op) value target] - where - cmpOp CharGtOp = GTT - cmpOp CharGeOp = GE - cmpOp CharEqOp = EQQ - cmpOp CharNeOp = NE - cmpOp CharLtOp = LTT - cmpOp CharLeOp = LE - cmpOp IntGtOp = GTT - cmpOp IntGeOp = GE - cmpOp IntEqOp = EQQ - cmpOp IntNeOp = NE - cmpOp IntLtOp = LTT - cmpOp IntLeOp = LE - cmpOp WordGtOp = NE - cmpOp WordGeOp = ALWAYS - cmpOp WordEqOp = EQQ - cmpOp WordNeOp = NE - cmpOp WordLtOp = NEVER - cmpOp WordLeOp = EQQ - cmpOp AddrGtOp = NE - cmpOp AddrGeOp = ALWAYS - cmpOp AddrEqOp = EQQ - cmpOp AddrNeOp = NE - cmpOp AddrLtOp = NEVER - cmpOp AddrLeOp = EQQ - -genCondJump lbl (StPrim op [x, StDouble 0.0]) - = getRegister x `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerRep register - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BF (cmpOp op) value target)) - where - cmpOp FloatGtOp = GTT - cmpOp FloatGeOp = GE - cmpOp FloatEqOp = EQQ - cmpOp FloatNeOp = NE - cmpOp FloatLtOp = LTT - cmpOp FloatLeOp = LE - cmpOp DoubleGtOp = GTT - cmpOp DoubleGeOp = GE - cmpOp DoubleEqOp = EQQ - cmpOp DoubleNeOp = NE - cmpOp DoubleLtOp = LTT - cmpOp DoubleLeOp = LE - -genCondJump lbl (StPrim op [x, y]) - | fltCmpOp op - = trivialFCode pr instr x y `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BF cond result target)) - where - pr = panic "trivialU?FCode: does not use PrimRep on Alpha" - - fltCmpOp op = case op of - FloatGtOp -> True - FloatGeOp -> True - FloatEqOp -> True - FloatNeOp -> True - FloatLtOp -> True - FloatLeOp -> True - DoubleGtOp -> True - DoubleGeOp -> True - DoubleEqOp -> True - DoubleNeOp -> True - DoubleLtOp -> True - DoubleLeOp -> True - _ -> False - (instr, cond) = case op of - FloatGtOp -> (FCMP TF LE, EQQ) - FloatGeOp -> (FCMP TF LTT, EQQ) - FloatEqOp -> (FCMP TF EQQ, NE) - FloatNeOp -> (FCMP TF EQQ, EQQ) - FloatLtOp -> (FCMP TF LTT, NE) - FloatLeOp -> (FCMP TF LE, NE) - DoubleGtOp -> (FCMP TF LE, EQQ) - DoubleGeOp -> (FCMP TF LTT, EQQ) - DoubleEqOp -> (FCMP TF EQQ, NE) - DoubleNeOp -> (FCMP TF EQQ, EQQ) - DoubleLtOp -> (FCMP TF LTT, NE) - DoubleLeOp -> (FCMP TF LE, NE) - -genCondJump lbl (StPrim op [x, y]) - = trivialCode instr x y `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BI cond result target)) - where - (instr, cond) = case op of - CharGtOp -> (CMP LE, EQQ) - CharGeOp -> (CMP LTT, EQQ) - CharEqOp -> (CMP EQQ, NE) - CharNeOp -> (CMP EQQ, EQQ) - CharLtOp -> (CMP LTT, NE) - CharLeOp -> (CMP LE, NE) - IntGtOp -> (CMP LE, EQQ) - IntGeOp -> (CMP LTT, EQQ) - IntEqOp -> (CMP EQQ, NE) - IntNeOp -> (CMP EQQ, EQQ) - IntLtOp -> (CMP LTT, NE) - IntLeOp -> (CMP LE, NE) - WordGtOp -> (CMP ULE, EQQ) - WordGeOp -> (CMP ULT, EQQ) - WordEqOp -> (CMP EQQ, NE) - WordNeOp -> (CMP EQQ, EQQ) - WordLtOp -> (CMP ULT, NE) - WordLeOp -> (CMP ULE, NE) - AddrGtOp -> (CMP ULE, EQQ) - AddrGeOp -> (CMP ULT, EQQ) - AddrEqOp -> (CMP EQQ, NE) - AddrNeOp -> (CMP EQQ, EQQ) - AddrLtOp -> (CMP ULT, NE) - AddrLeOp -> (CMP ULE, NE) - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) - -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -ccallResultRegs = - -genCCall fn cconv result_regs args - = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenNat` \ ((unused,_), argCode) -> - let - nRegs = length allArgRegs - length unused - code = asmSeqThen (map ($ []) argCode) - in - returnSeq code [ - LDA pv (AddrImm (ImmLab (ptext fn))), - JSR ra (AddrReg pv) nRegs, - LDGP gp (AddrReg ra)] - where - ------------------------ - {- Try to get a value into a specific register (or registers) for - a call. The first 6 arguments go into the appropriate - argument register (separate registers for integer and floating - point arguments, but used in lock-step), and the remaining - arguments are dumped to the stack, beginning at 0(sp). Our - first argument is a pair of the list of remaining argument - registers to be assigned for this call and the next stack - offset to use for overflowing arguments. This way, - @get_Arg@ can be applied to all of a call's arguments using - @mapAccumLNat@. - -} - get_arg - :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code - - -- We have to use up all of our argument registers first... - - get_arg ((iDst,fDst):dsts, offset) arg - = getRegister arg `thenNat` \ register -> - let - reg = if isFloatType pk then fDst else iDst - code = registerCode register reg - src = registerName register reg - pk = registerRep register - in - return ( - if isFloatType pk then - ((dsts, offset), if isFixed register then - code . mkSeqInstr (FMOV src fDst) - else code) - else - ((dsts, offset), if isFixed register then - code . mkSeqInstr (OR src (RIReg src) iDst) - else code)) - - -- Once we have run out of argument registers, we move to the - -- stack... - - get_arg ([], offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerRep register - sz = primRepToSize pk - in - return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) - -trivialCode instr x (StInt y) - | fits8Bits y - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src1 = registerName register tmp - src2 = ImmInt (fromInteger y) - code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) - in - return (Any IntRep code__2) - -trivialCode instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> - let - code1 = registerCode register1 tmp1 [] - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] - src2 = registerName register2 tmp2 - code__2 dst = asmSeqThen [code1, code2] . - mkSeqInstr (instr src1 (RIReg src2) dst) - in - return (Any IntRep code__2) - ------------- -trivialUCode instr x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) - in - return (Any IntRep code__2) - ------------- -trivialFCode _ instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat FF64 `thenNat` \ tmp1 -> - getNewRegNat FF64 `thenNat` \ tmp2 -> - let - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - code__2 dst = asmSeqThen [code1 [], code2 []] . - mkSeqInstr (instr src1 src2 dst) - in - return (Any FF64 code__2) - -trivialUFCode _ instr x - = getRegister x `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) - in - return (Any FF64 code__2) - -#if alpha_TARGET_ARCH - -coerceInt2FP _ x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ reg -> - let - code = registerCode register reg - src = registerName register reg - - code__2 dst = code . mkSeqInstrs [ - ST Q src (spRel 0), - LD TF dst (spRel 0), - CVTxy Q TF dst dst] - in - return (Any FF64 code__2) - -------------- -coerceFP2Int x - = getRegister x `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - CVTxy TF Q src tmp, - ST TF tmp (spRel 0), - LD Q dst (spRel 0)] - in - return (Any IntRep code__2) - -#endif /* alpha_TARGET_ARCH */ - - --} - - - - - diff --git a/compiler/nativeGen/Alpha/Instr.hs b/compiler/nativeGen/Alpha/Instr.hs deleted file mode 100644 index 990ea8b..0000000 --- a/compiler/nativeGen/Alpha/Instr.hs +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -module Alpha.Instr ( --- Cond(..), --- Instr(..), --- RI(..) -) - -where - -{- -import BlockId -import Regs -import Cmm -import FastString -import CLabel - -data Cond - = ALWAYS -- For BI (same as BR) - | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name) - | GE -- For BI only - | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name) - | LE -- For CMP and BI - | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name) - | NE -- For BI only - | NEVER -- For BI (null instruction) - | ULE -- For CMP only - | ULT -- For CMP only - deriving Eq - - --- ----------------------------------------------------------------------------- --- Machine's assembly language - --- We have a few common "instructions" (nearly all the pseudo-ops) but --- mostly all of 'Instr' is machine-specific. - --- Register or immediate -data RI - = RIReg Reg - | RIImm Imm - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section [CmmStatic] - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for - -- benefit of subsequent passes - | DELTA Int - - -- | spill this reg to a stack slot - | SPILL Reg Int - - -- | reload this reg from a stack slot - | RELOAD Int Reg - - -- Loads and stores. - | LD Size Reg AddrMode -- size, dst, src - | LDA Reg AddrMode -- dst, src - | LDAH Reg AddrMode -- dst, src - | LDGP Reg AddrMode -- dst, src - | LDI Size Reg Imm -- size, dst, src - | ST Size Reg AddrMode -- size, src, dst - - -- Int Arithmetic. - | CLR Reg -- dst - | ABS Size RI Reg -- size, src, dst - | NEG Size Bool RI Reg -- size, overflow, src, dst - | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SADD Size Size Reg RI Reg -- size, scale, src, src, dst - | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst - | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst - | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst - | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst - - -- Simple bit-twiddling. - | NOT RI Reg - | AND Reg RI Reg - | ANDNOT Reg RI Reg - | OR Reg RI Reg - | ORNOT Reg RI Reg - | XOR Reg RI Reg - | XORNOT Reg RI Reg - | SLL Reg RI Reg - | SRL Reg RI Reg - | SRA Reg RI Reg - - | ZAP Reg RI Reg - | ZAPNOT Reg RI Reg - - | NOP - - -- Comparison - | CMP Cond Reg RI Reg - - -- Float Arithmetic. - | FCLR Reg - | FABS Reg Reg - | FNEG Size Reg Reg - | FADD Size Reg Reg Reg - | FDIV Size Reg Reg Reg - | FMUL Size Reg Reg Reg - | FSUB Size Reg Reg Reg - | CVTxy Size Size Reg Reg - | FCMP Size Cond Reg Reg Reg - | FMOV Reg Reg - - -- Jumping around. - | BI Cond Reg Imm - | BF Cond Reg Imm - | BR Imm - | JMP Reg AddrMode Int - | BSR Imm Int - | JSR Reg AddrMode Int - - -- Alpha-specific pseudo-ops. - | FUNBEGIN CLabel - | FUNEND CLabel - - --} diff --git a/compiler/nativeGen/Alpha/Ppr.hs-old b/compiler/nativeGen/Alpha/Ppr.hs-old deleted file mode 100644 index c14eef2..0000000 --- a/compiler/nativeGen/Alpha/Ppr.hs-old +++ /dev/null @@ -1,562 +0,0 @@ - -module Alpha.Ppr ( -{- - pprReg, - pprSize, - pprCond, - pprAddr, - pprSectionHeader, - pprTypeAndSizeDecl, - pprRI, - pprRegRIReg, - pprSizeRegRegReg --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import BlockId -import Cmm -import Regs -- may differ per-platform -import Instrs - -import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, - labelDynamic, mkAsmTempLabel, entryLblToInfoLbl ) - -#if HAVE_SUBSECTIONS_VIA_SYMBOLS -import CLabel ( mkDeadStripPreventer ) -#endif - -import Panic ( panic ) -import Unique ( pprUnique ) -import Pretty -import FastString -import qualified Outputable -import Outputable ( Outputable, pprPanic, ppr, docToSDoc) - -import Data.Array.ST -import Data.Word ( Word8 ) -import Control.Monad.ST -import Data.Char ( chr, ord ) -import Data.Maybe ( isJust ) - - - -pprReg :: Reg -> Doc -pprReg r - = case r of - RealReg i -> ppr_reg_no i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) - where - ppr_reg_no :: Int -> Doc - ppr_reg_no i = ptext - (case i of { - 0 -> sLit "$0"; 1 -> sLit "$1"; - 2 -> sLit "$2"; 3 -> sLit "$3"; - 4 -> sLit "$4"; 5 -> sLit "$5"; - 6 -> sLit "$6"; 7 -> sLit "$7"; - 8 -> sLit "$8"; 9 -> sLit "$9"; - 10 -> sLit "$10"; 11 -> sLit "$11"; - 12 -> sLit "$12"; 13 -> sLit "$13"; - 14 -> sLit "$14"; 15 -> sLit "$15"; - 16 -> sLit "$16"; 17 -> sLit "$17"; - 18 -> sLit "$18"; 19 -> sLit "$19"; - 20 -> sLit "$20"; 21 -> sLit "$21"; - 22 -> sLit "$22"; 23 -> sLit "$23"; - 24 -> sLit "$24"; 25 -> sLit "$25"; - 26 -> sLit "$26"; 27 -> sLit "$27"; - 28 -> sLit "$28"; 29 -> sLit "$29"; - 30 -> sLit "$30"; 31 -> sLit "$31"; - 32 -> sLit "$f0"; 33 -> sLit "$f1"; - 34 -> sLit "$f2"; 35 -> sLit "$f3"; - 36 -> sLit "$f4"; 37 -> sLit "$f5"; - 38 -> sLit "$f6"; 39 -> sLit "$f7"; - 40 -> sLit "$f8"; 41 -> sLit "$f9"; - 42 -> sLit "$f10"; 43 -> sLit "$f11"; - 44 -> sLit "$f12"; 45 -> sLit "$f13"; - 46 -> sLit "$f14"; 47 -> sLit "$f15"; - 48 -> sLit "$f16"; 49 -> sLit "$f17"; - 50 -> sLit "$f18"; 51 -> sLit "$f19"; - 52 -> sLit "$f20"; 53 -> sLit "$f21"; - 54 -> sLit "$f22"; 55 -> sLit "$f23"; - 56 -> sLit "$f24"; 57 -> sLit "$f25"; - 58 -> sLit "$f26"; 59 -> sLit "$f27"; - 60 -> sLit "$f28"; 61 -> sLit "$f29"; - 62 -> sLit "$f30"; 63 -> sLit "$f31"; - _ -> sLit "very naughty alpha register" - }) - - -pprSize :: Size -> Doc -pprSize x = ptext (case x of - B -> sLit "b" - Bu -> sLit "bu" --- W -> sLit "w" UNUSED --- Wu -> sLit "wu" UNUSED - L -> sLit "l" - Q -> sLit "q" --- FF -> sLit "f" UNUSED --- DF -> sLit "d" UNUSED --- GF -> sLit "g" UNUSED --- SF -> sLit "s" UNUSED - TF -> sLit "t" - - -pprCond :: Cond -> Doc -pprCond c - = ptext (case c of - EQQ -> sLit "eq" - LTT -> sLit "lt" - LE -> sLit "le" - ULT -> sLit "ult" - ULE -> sLit "ule" - NE -> sLit "ne" - GTT -> sLit "gt" - GE -> sLit "ge") - - -pprAddr :: AddrMode -> Doc -pprAddr (AddrReg r) = parens (pprReg r) -pprAddr (AddrImm i) = pprImm i -pprAddr (AddrRegImm r1 i) - = (<>) (pprImm i) (parens (pprReg r1)) - - -pprSectionHeader Text - = ptext (sLit "\t.text\n\t.align 3") - -pprSectionHeader Data - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader ReadOnlyData - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader RelocatableReadOnlyData - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader UninitialisedData - = ptext (sLit "\t.bss\n\t.align 3") - -pprSectionHeader ReadOnlyData16 - = ptext (sLit "\t.data\n\t.align 4") - -pprSectionHeader (OtherSection sec) - = panic "PprMach.pprSectionHeader: unknown section" - - -pprTypeAndSizeDecl :: CLabel -> Doc -pprTypeAndSizeDecl lbl - = empty - - - -pprInstr :: Instr -> Doc - -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -pprInstr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char '\t', - pprReg reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char '\t', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprReg reg] - -pprInstr (LD size reg addr) - = hcat [ - ptext (sLit "\tld"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDA reg addr) - = hcat [ - ptext (sLit "\tlda\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDAH reg addr) - = hcat [ - ptext (sLit "\tldah\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDGP reg addr) - = hcat [ - ptext (sLit "\tldgp\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDI size reg imm) - = hcat [ - ptext (sLit "\tldi"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprImm imm - ] - -pprInstr (ST size reg addr) - = hcat [ - ptext (sLit "\tst"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (CLR reg) - = hcat [ - ptext (sLit "\tclr\t"), - pprReg reg - ] - -pprInstr (ABS size ri reg) - = hcat [ - ptext (sLit "\tabs"), - pprSize size, - char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (NEG size ov ri reg) - = hcat [ - ptext (sLit "\tneg"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (ADD size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tadd"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SADD size scale reg1 ri reg2) - = hcat [ - ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}), - ptext (sLit "add"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SUB size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tsub"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SSUB size scale reg1 ri reg2) - = hcat [ - ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}), - ptext (sLit "sub"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (MUL size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tmul"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (DIV size uns reg1 ri reg2) - = hcat [ - ptext (sLit "\tdiv"), - pprSize size, - if uns then ptext (sLit "u\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (REM size uns reg1 ri reg2) - = hcat [ - ptext (sLit "\trem"), - pprSize size, - if uns then ptext (sLit "u\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (NOT ri reg) - = hcat [ - ptext (sLit "\tnot"), - char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2 -pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2 -pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2 -pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2 -pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2 -pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2 - -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2 - -pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2 -pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2 - -pprInstr (NOP) = ptext (sLit "\tnop") - -pprInstr (CMP cond reg1 ri reg2) - = hcat [ - ptext (sLit "\tcmp"), - pprCond cond, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (FCLR reg) - = hcat [ - ptext (sLit "\tfclr\t"), - pprReg reg - ] - -pprInstr (FABS reg1 reg2) - = hcat [ - ptext (sLit "\tfabs\t"), - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FNEG size reg1 reg2) - = hcat [ - ptext (sLit "\tneg"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3 -pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3 -pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3 -pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3 - -pprInstr (CVTxy size1 size2 reg1 reg2) - = hcat [ - ptext (sLit "\tcvt"), - pprSize size1, - case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2}, - char '\t', - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FCMP size cond reg1 reg2 reg3) - = hcat [ - ptext (sLit "\tcmp"), - pprSize size, - pprCond cond, - char '\t', - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - -pprInstr (FMOV reg1 reg2) - = hcat [ - ptext (sLit "\tfmov\t"), - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab) - -pprInstr (BI NEVER reg lab) = empty - -pprInstr (BI cond reg lab) - = hcat [ - ptext (sLit "\tb"), - pprCond cond, - char '\t', - pprReg reg, - comma, - pprImm lab - ] - -pprInstr (BF cond reg lab) - = hcat [ - ptext (sLit "\tfb"), - pprCond cond, - char '\t', - pprReg reg, - comma, - pprImm lab - ] - -pprInstr (BR lab) - = (<>) (ptext (sLit "\tbr\t")) (pprImm lab) - -pprInstr (JMP reg addr hint) - = hcat [ - ptext (sLit "\tjmp\t"), - pprReg reg, - comma, - pprAddr addr, - comma, - int hint - ] - -pprInstr (BSR imm n) - = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm) - -pprInstr (JSR reg addr n) - = hcat [ - ptext (sLit "\tjsr\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (FUNBEGIN clab) - = hcat [ - if (externallyVisibleCLabel clab) then - hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n'] - else - empty, - ptext (sLit "\t.ent "), - pp_lab, - char '\n', - pp_lab, - pp_ldgp, - pp_lab, - pp_frame - ] - where - pp_lab = pprCLabel_asm clab - - -- NEVER use commas within those string literals, cpp will ruin your day - pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ] - pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',', - ptext (sLit "4240"), char ',', - ptext (sLit "$26"), char ',', - ptext (sLit "0\n\t.prologue 1") ] - -pprInstr (FUNEND clab) - = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab) - - -pprRI :: RI -> Doc - -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - -pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc -pprRegRIReg name reg1 ri reg2 - = hcat [ - char '\t', - ptext name, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 - = hcat [ - char '\t', - ptext name, - pprSize size, - char '\t', - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - --} - - - diff --git a/compiler/nativeGen/Alpha/RegInfo.hs b/compiler/nativeGen/Alpha/RegInfo.hs deleted file mode 100644 index 7fdde4d..0000000 --- a/compiler/nativeGen/Alpha/RegInfo.hs +++ /dev/null @@ -1,218 +0,0 @@ - ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - -module Alpha.RegInfo ( -{- - RegUsage(..), - noUsage, - regUsage, - patchRegs, - jumpDests, - isJumpish, - patchJump, - isRegRegMove, - - JumpDest, canShortcut, shortcutJump, shortcutStatic, - - maxSpillSlots, - mkSpillInstr, - mkLoadInstr, - mkRegRegMoveInstr, - mkBranchInstr --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" - - -import BlockId -import Cmm -import CLabel -import Instrs -import Regs -import Outputable -import Constants ( rESERVED_C_STACK_BYTES ) -import FastBool - -data RegUsage = RU [Reg] [Reg] - -noUsage :: RegUsage -noUsage = RU [] [] - -regUsage :: Instr -> RegUsage - -regUsage instr = case instr of - SPILL reg slot -> usage ([reg], []) - RELOAD slot reg -> usage ([], [reg]) - LD B reg addr -> usage (regAddr addr, [reg, t9]) - LD Bu reg addr -> usage (regAddr addr, [reg, t9]) --- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED --- LD Wu reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED - LD sz reg addr -> usage (regAddr addr, [reg]) - LDA reg addr -> usage (regAddr addr, [reg]) - LDAH reg addr -> usage (regAddr addr, [reg]) - LDGP reg addr -> usage (regAddr addr, [reg]) - LDI sz reg imm -> usage ([], [reg]) - ST B reg addr -> usage (reg : regAddr addr, [t9, t10]) --- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED - ST sz reg addr -> usage (reg : regAddr addr, []) - CLR reg -> usage ([], [reg]) - ABS sz ri reg -> usage (regRI ri, [reg]) - NEG sz ov ri reg -> usage (regRI ri, [reg]) - ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - NOT ri reg -> usage (regRI ri, [reg]) - AND r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2]) - FCLR reg -> usage ([], [reg]) - FABS r1 r2 -> usage ([r1], [r2]) - FNEG sz r1 r2 -> usage ([r1], [r2]) - FADD sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3]) - CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2]) - FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV r1 r2 -> usage ([r1], [r2]) - - - -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line. - BI cond reg lbl -> usage ([reg], []) - BF cond reg lbl -> usage ([reg], []) - JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet - - BSR _ n -> RU (argRegSet n) callClobberedRegSet - JSR reg addr n -> RU (argRegSet n) callClobberedRegSet - - _ -> noUsage - - where - usage (src, dst) = RU (mkRegSet (filter interesting src)) - (mkRegSet (filter interesting dst)) - - interesting (FixedReg _) = False - interesting _ = True - - regAddr (AddrReg r1) = [r1] - regAddr (AddrRegImm r1 _) = [r1] - regAddr (AddrImm _) = [] - - regRI (RIReg r) = [r] - regRI _ = [] - - -patchRegs :: Instr -> (Reg -> Reg) -> Instr -patchRegs instr env = case instr of - SPILL reg slot -> SPILL (env reg) slot - RELOAD slot reg -> RELOAD slot (env reg) - LD sz reg addr -> LD sz (env reg) (fixAddr addr) - LDA reg addr -> LDA (env reg) (fixAddr addr) - LDAH reg addr -> LDAH (env reg) (fixAddr addr) - LDGP reg addr -> LDGP (env reg) (fixAddr addr) - LDI sz reg imm -> LDI sz (env reg) imm - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - CLR reg -> CLR (env reg) - ABS sz ar reg -> ABS sz (fixRI ar) (env reg) - NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg) - ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2) - SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2) - SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2) - SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2) - MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2) - DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2) - REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2) - NOT ar reg -> NOT (fixRI ar) (env reg) - AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2) - ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2) - OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2) - ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2) - XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2) - XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2) - ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2) - CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2) - FCLR reg -> FCLR (env reg) - FABS r1 r2 -> FABS (env r1) (env r2) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2) - FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3) - FMOV r1 r2 -> FMOV (env r1) (env r2) - BI cond reg lbl -> BI cond (env reg) lbl - BF cond reg lbl -> BF cond (env reg) lbl - JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint - JSR reg addr i -> JSR (env reg) (fixAddr addr) i - _ -> instr - where - fixAddr (AddrReg r1) = AddrReg (env r1) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - fixAddr other = other - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - -mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -mkSpillInstr reg delta slot - = let off = spillSlotToOffset slot - in - -- Alpha: spill below the stack pointer (?) - ST sz dyn (spRel (- (off `div` 8))) - - -mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr -mkLoadInstr reg delta slot - = let off = spillSlotToOffset slot - in - LD sz dyn (spRel (- (off `div` 8))) - - -mkBranchInstr - :: BlockId - -> [Instr] - -mkBranchInstr id = [BR id] - --} - - - - diff --git a/compiler/nativeGen/Alpha/Regs.hs b/compiler/nativeGen/Alpha/Regs.hs deleted file mode 100644 index ee49050..0000000 --- a/compiler/nativeGen/Alpha/Regs.hs +++ /dev/null @@ -1,323 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- Alpha support is rotted and incomplete. --- ----------------------------------------------------------------------------- - - -module Alpha.Regs ( -{- - Size(..), - AddrMode(..), - fits8Bits, - fReg, - gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" -#include "../includes/stg/MachRegs.h" - -import RegsBase - -import BlockId -import Cmm -import CLabel ( CLabel, mkMainCapabilityLabel ) -import Pretty -import Outputable ( Outputable(..), pprPanic, panic ) -import qualified Outputable -import Unique -import UniqSet -import Constants -import FastTypes -import FastBool -import UniqFM - - -data Size - = B -- byte - | Bu --- | W -- word (2 bytes): UNUSED --- | Wu -- : UNUSED - | L -- longword (4 bytes) - | Q -- quadword (8 bytes) --- | FF -- VAX F-style floating pt: UNUSED --- | GF -- VAX G-style floating pt: UNUSED --- | DF -- VAX D-style floating pt: UNUSED --- | SF -- IEEE single-precision floating pt: UNUSED - | TF -- IEEE double-precision floating pt - deriving Eq - - -data AddrMode - = AddrImm Imm - | AddrReg Reg - | AddrRegImm Reg Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - _ -> panic "MachMisc.addrOffset not defined for Alpha" - -fits8Bits :: Integer -> Bool -fits8Bits i = i >= -256 && i < 256 - - --- The Alpha has 64 registers of interest; 32 integer registers and 32 floating --- point registers. The mapping of STG registers to alpha machine registers --- is defined in StgRegs.h. We are, of course, prepared for any eventuality. - -fReg :: Int -> RegNo -fReg x = (32 + x) - -v0, f0, ra, pv, gp, sp, zeroh :: Reg -v0 = realReg 0 -f0 = realReg (fReg 0) -ra = FixedReg ILIT(26) -pv = t12 -gp = FixedReg ILIT(29) -sp = FixedReg ILIT(30) -zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method) - -t9, t10, t11, t12 :: Reg -t9 = realReg 23 -t10 = realReg 24 -t11 = realReg 25 -t12 = realReg 27 - - -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 - - --- allMachRegs is the complete set of machine regs. -allMachRegNos :: [RegNo] -allMachRegNos = [0..63] - - --- these are the regs which we cannot assume stay alive over a --- C call. -callClobberedRegs :: [Reg] -callClobberedRegs - = [0, 1, 2, 3, 4, 5, 6, 7, 8, - 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, - fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15, - fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23, - fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30] - - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. -argRegs :: RegNo -> [Reg] - -argRegs 0 = [] -argRegs 1 = freeMappedRegs [16, fReg 16] -argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17] -argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18] -argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19] -argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20] -argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21] -argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!" - - --- all of the arg regs ?? -allArgRegs :: [(Reg, Reg)] -allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]] - - --- horror show ----------------------------------------------------------------- - -freeReg :: RegNo -> FastBool - -freeReg 26 = fastBool False -- return address (ra) -freeReg 28 = fastBool False -- reserved for the assembler (at) -freeReg 29 = fastBool False -- global pointer (gp) -freeReg 30 = fastBool False -- stack pointer (sp) -freeReg 31 = fastBool False -- always zero (zeroh) -freeReg 63 = fastBool False -- always zero (f31) - -#ifdef REG_Base -freeReg REG_Base = fastBool False -#endif -#ifdef REG_R1 -freeReg REG_R1 = fastBool False -#endif -#ifdef REG_R2 -freeReg REG_R2 = fastBool False -#endif -#ifdef REG_R3 -freeReg REG_R3 = fastBool False -#endif -#ifdef REG_R4 -freeReg REG_R4 = fastBool False -#endif -#ifdef REG_R5 -freeReg REG_R5 = fastBool False -#endif -#ifdef REG_R6 -freeReg REG_R6 = fastBool False -#endif -#ifdef REG_R7 -freeReg REG_R7 = fastBool False -#endif -#ifdef REG_R8 -freeReg REG_R8 = fastBool False -#endif -#ifdef REG_F1 -freeReg REG_F1 = fastBool False -#endif -#ifdef REG_F2 -freeReg REG_F2 = fastBool False -#endif -#ifdef REG_F3 -freeReg REG_F3 = fastBool False -#endif -#ifdef REG_F4 -freeReg REG_F4 = fastBool False -#endif -#ifdef REG_D1 -freeReg REG_D1 = fastBool False -#endif -#ifdef REG_D2 -freeReg REG_D2 = fastBool False -#endif -#ifdef REG_Sp -freeReg REG_Sp = fastBool False -#endif -#ifdef REG_Su -freeReg REG_Su = fastBool False -#endif -#ifdef REG_SpLim -freeReg REG_SpLim = fastBool False -#endif -#ifdef REG_Hp -freeReg REG_Hp = fastBool False -#endif -#ifdef REG_HpLim -freeReg REG_HpLim = fastBool False -#endif -freeReg n = fastBool True - - --- | Returns 'Nothing' if this global register is not stored --- in a real machine register, otherwise returns @'Just' reg@, where --- reg is the machine register it is stored in. - -globalRegMaybe :: GlobalReg -> Maybe Reg - -#ifdef REG_Base -globalRegMaybe BaseReg = Just (RealReg REG_Base) -#endif -#ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10) -#endif -#ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (RealReg REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealReg REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (RealReg REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealReg REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing - --} diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 0ce95ef..07acbbb 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -13,13 +13,7 @@ module AsmCodeGen ( nativeCodeGen ) where #include "nativeGen/NCG.h" -#if alpha_TARGET_ARCH -import Alpha.CodeGen -import Alpha.Regs -import Alpha.RegInfo -import Alpha.Instr - -#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH +#if i386_TARGET_ARCH || x86_64_TARGET_ARCH import X86.CodeGen import X86.Regs import X86.Instr @@ -64,7 +58,7 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) import OldPprCmm import CLabel @@ -92,7 +86,6 @@ import Data.List import Data.Maybe import Control.Monad import System.IO -import Distribution.System {- The native-code generator has machine-independent and @@ -378,37 +371,48 @@ cmmNativeGen dflags us cmm count , Nothing , mPprStats) + ---- x86fp_kludge. This pass inserts ffree instructions to clear + ---- the FPU stack on x86. The x86 ABI requires that the FPU stack + ---- is clear, and library functions can return odd results if it + ---- isn't. + ---- + ---- NB. must happen before shortcutBranches, because that + ---- generates JXX_GBLs which we can't fix up in x86fp_kludge. + let kludged = +#if i386_TARGET_ARCH + {-# SCC "x86fp_kludge" #-} + map x86fp_kludge alloced +#else + alloced +#endif + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables kludged + ---- shortcut branches let shorted = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags alloced + shortcutBranches dflags tabled ---- sequence blocks let sequenced = {-# SCC "sequenceBlocks" #-} map sequenceTop shorted - ---- x86fp_kludge - let kludged = -#if i386_TARGET_ARCH - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced -#else - sequenced -#endif - - ---- expansion of SPARC synthetic instrs + ---- expansion of SPARC synthetic instrs #if sparc_TARGET_ARCH let expanded = {-# SCC "sparc_expand" #-} - map expandTop kludged + map expandTop sequenced dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" (vcat $ map (docToSDoc . pprNatCmmTop) expanded) #else let expanded = - kludged + sequenced #endif return ( usAlloc @@ -609,6 +613,18 @@ makeFarBranches = id #endif -- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: [NatCmmTop Instr] -> [NatCmmTop Instr] +generateJumpTables xs = concatMap f xs + where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs) + +-- ----------------------------------------------------------------------------- -- Shortcut branches shortcutBranches @@ -718,10 +734,9 @@ Here we do: and position independent refs (ii) compile a list of imported symbols -Ideas for other things we could do (ToDo): +Ideas for other things we could do: - shortcut jumps-to-jumps - - eliminate dead code blocks - simple CSE: if an expr is assigned to a temp, then replace later occs of that expr with the temp, until the expr is no longer valid (can push through temp assignments, and certain assigns to mem...) @@ -730,7 +745,7 @@ Ideas for other things we could do (ToDo): cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) + blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks)) return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -807,8 +822,10 @@ cmmStmtConFold stmt cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr - = case expr of +cmmExprConFold referenceKind expr = do + dflags <- getDynFlagsCmmOpt + let arch = platformArch (targetPlatform dflags) + case expr of CmmLoad addr rep -> do addr' <- cmmExprConFold DataReference addr return $ CmmLoad addr' rep @@ -821,11 +838,9 @@ cmmExprConFold referenceKind expr CmmLit (CmmLabel lbl) -> do - dflags <- getDynFlagsCmmOpt cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dflags <- getDynFlagsCmmOpt dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, @@ -836,15 +851,15 @@ cmmExprConFold referenceKind expr -- to use the register table, so we replace these registers -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | cTargetArch == PPC && not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 29b9a54..c96badd 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -15,6 +15,7 @@ module PPC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -798,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR []) + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) -- ----------------------------------------------------------------------------- @@ -1126,22 +1127,12 @@ genSwitch expr ids dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef - let - jumpTable = map jumpTableEntryRel ids - - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` t_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), LD II32 tmp (AddrRegReg tableReg tmp), ADD tmp tmp (RIReg tableReg), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code | otherwise @@ -1149,19 +1140,27 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat II32 lbl <- getNewLabelNat - let - jumpTable = map jumpTableEntry ids - - code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), ADDIS tmp tmp (HA (ImmCLbl lbl)), LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (BCTR ids (Just lbl)) = + let jumpTable + | opt_PIC = map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) +generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 6aeccd3..0288f1b 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -104,7 +104,7 @@ data Instr | JMP CLabel -- same as branch, -- but with CLabel instead of block ID | MTCTR Reg - | BCTR [BlockId] -- with list of local destinations + | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary | BL CLabel [Reg] -- with list of argument regs | BCTRL [Reg] @@ -184,7 +184,7 @@ ppc_regUsageOfInstr instr BCC _ _ -> noUsage BCCFAR _ _ -> noUsage MTCTR reg -> usage ([reg],[]) - BCTR _ -> noUsage + BCTR _ _ -> noUsage BL _ params -> usage (params, callClobberedRegs) BCTRL params -> usage (params, callClobberedRegs) ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) @@ -257,7 +257,7 @@ ppc_patchRegsOfInstr instr env BCC cond lbl -> BCC cond lbl BCCFAR cond lbl -> BCCFAR cond lbl MTCTR reg -> MTCTR (env reg) - BCTR targets -> BCTR targets + BCTR targets lbl -> BCTR targets lbl BL imm argRegs -> BL imm argRegs -- argument regs BCTRL argRegs -> BCTRL argRegs -- cannot be remapped ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri) @@ -326,7 +326,7 @@ ppc_jumpDestsOfInstr insn = case insn of BCC _ id -> [id] BCCFAR _ id -> [id] - BCTR targets -> targets + BCTR targets _ -> [id | Just id <- targets] _ -> [] @@ -338,7 +338,7 @@ ppc_patchJumpInstr insn patchF = case insn of BCC cc id -> BCC cc (patchF id) BCCFAR cc id -> BCCFAR cc (patchF id) - BCTR _ -> error "Cannot patch BCTR" + BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl _ -> insn diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 9fb86c0..8d8b16a 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -12,7 +12,6 @@ module PPC.Ppr ( pprSectionHeader, pprData, pprInstr, - pprUserReg, pprSize, pprImm, pprDataItem, @@ -157,9 +156,6 @@ instance Outputable Instr where ppr instr = Outputable.docToSDoc $ pprInstr instr -pprUserReg :: Reg -> Doc -pprUserReg = pprReg - pprReg :: Reg -> Doc pprReg r @@ -545,7 +541,7 @@ pprInstr (MTCTR reg) = hcat [ char '\t', pprReg reg ] -pprInstr (BCTR _) = hcat [ +pprInstr (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 73e0c20..7a2a84b 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -209,7 +209,6 @@ spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. -- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. argRegs :: RegNo -> [Reg] argRegs 0 = [] argRegs 1 = map regSingle [3] diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 903082f..ef6ae9b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -190,7 +190,7 @@ joinToTargets_again _ -> let instr' = patchJumpInstr instr (\bid -> if bid == dest then mkBlockId fixup_block_id - else dest) + else bid) -- no change! in joinToTargets' block_live (block : new_blocks) block_id instr' dests diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 5fab944..473b549 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -48,7 +48,7 @@ The algorithm is roughly: (c) Update the current assignment - (d) If the intstruction is a branch: + (d) If the instruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. @@ -331,7 +331,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr instr of Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), @@ -497,7 +497,7 @@ releaseRegs regs = do saveClobberedTemps - :: Instruction instr + :: (Outputable instr, Instruction instr) => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM [instr] -- return: instructions to spill any temps that will @@ -536,7 +536,7 @@ saveClobberedTemps clobbered dying --- | Mark all these regal regs as allocated, +-- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- clobberRegs :: [RealReg] -> RegM () @@ -571,6 +571,16 @@ clobberRegs clobbered -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). @@ -579,7 +589,7 @@ clobberRegs clobbered -- the list of free registers and free stack slots. allocateRegsAndSpill - :: Instruction instr + :: (Outputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -593,13 +603,14 @@ allocateRegsAndSpill _ _ spills alloc [] allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be + -- NB1. if we're writing this register, update its assignment to be -- InReg, because the memory value is no longer valid. -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. @@ -608,10 +619,22 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew -allocRegsAndSpill_spill reading keep spills alloc r rs loc assig +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs @@ -620,19 +643,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp reading r loc my_reg spills - - let new_loc - -- if the tmp was in a slot, then now its in a reg as well - | Just (InMem slot) <- loc - , reading - = InBoth my_reg slot + do spills' <- loadTemp r spill_loc my_reg spills - -- tmp has been loaded into a reg - | otherwise - = InReg my_reg - - setAssigR (addToUFM assig r $! new_loc) + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ allocateReg my_reg freeRegs allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs @@ -662,9 +675,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp reading r loc my_reg spills + = do spills' <- loadTemp r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs @@ -684,11 +697,11 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- update the register assignment let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') @@ -707,22 +720,28 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig result --- | Load up a spilled temporary if we need to. +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: Instruction instr - => Bool - -> VirtualReg -- the temp being loaded - -> Maybe Loc -- the current location of this temp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] -loadTemp True vreg (Just (InMem slot)) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index d08d10d..beb48d6 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -8,6 +8,7 @@ module SPARC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -299,15 +300,11 @@ genSwitch expr ids dst <- getNewRegNat II32 label <- getNewLabelNat - let jumpTable = map jumpTableEntry ids return $ e_code `appOL` toOL - -- the jump table - [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable) - - -- load base of jump table - , SETHI (HI (ImmCLbl label)) base_reg + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg -- the addrs in the table are 32 bits wide.. @@ -315,6 +312,11 @@ genSwitch expr ids -- load and jump to the destination , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids] + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (JMP_TBL _ ids label) = + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) +generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 79b4629..93f4d27 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -37,6 +37,7 @@ import RegClass import Reg import Size +import CLabel import BlockId import OldCmm import FastString @@ -194,7 +195,7 @@ data Instr -- With a tabled jump we know all the possible destinations. -- We also need this info so we can work out what regs are live across the jump. -- - | JMP_TBL AddrMode [BlockId] + | JMP_TBL AddrMode [Maybe BlockId] CLabel | CALL (Either Imm Reg) Int Bool -- target, args, terminal @@ -247,7 +248,7 @@ sparc_regUsageOfInstr instr FxTOy _ _ r1 r2 -> usage ([r1], [r2]) JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) CALL (Left _ ) _ True -> noUsage CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) @@ -315,7 +316,7 @@ sparc_patchRegsOfInstr instr env = case instr of FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l CALL (Left i) n t -> CALL (Left i) n t CALL (Right r) n t -> CALL (Right (env r)) n t @@ -345,7 +346,7 @@ sparc_jumpDestsOfInstr insn = case insn of BI _ _ id -> [id] BF _ _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ -> [id | Just id <- ids] _ -> [] @@ -354,6 +355,7 @@ sparc_patchJumpInstr insn patchF = case insn of BI cc annul id -> BI cc annul (patchF id) BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l _ -> insn diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index a63661f..c5a3314 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -12,7 +12,6 @@ module SPARC.Ppr ( pprSectionHeader, pprData, pprInstr, - pprUserReg, pprSize, pprImm, pprDataItem @@ -141,12 +140,6 @@ instance Outputable Instr where -- | Pretty print a register. --- This is an alias of pprReg for legacy reasons, should remove it. -pprUserReg :: Reg -> Doc -pprUserReg = pprReg - - --- | Pretty print a register. pprReg :: Reg -> Doc pprReg reg = case reg of @@ -543,7 +536,7 @@ pprInstr (BF cond b blockid) ] pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr) -pprInstr (JMP_TBL op _) = pprInstr (JMP op) +pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) n _) = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 86ecbf9..a6cc36f 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -20,6 +20,7 @@ module X86.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -431,7 +432,7 @@ getRegister (CmmReg reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - return (Fixed sz (getRegisterReg use_sse2 reg) nilOL) + return (Fixed size (getRegisterReg use_sse2 reg) nilOL) getRegister tree@(CmmRegOff _ _) @@ -1932,16 +1933,7 @@ genSwitch expr ids dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef - let - jumpTable = map jumpTableEntryRel ids - - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just blockid) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel (getUnique blockid) - - op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) #if x86_64_TARGET_ARCH @@ -1954,8 +1946,7 @@ genSwitch expr ids code = e_code `appOL` t_code `appOL` toOL [ ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ], - LDATA Text (CmmDataLabel lbl : jumpTable) + JMP_TBL (OpReg tableReg) ids Text lbl ] #else -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 @@ -1965,20 +1956,18 @@ genSwitch expr ids -- conjunction with the hack in PprMach.hs/pprDataItem once -- binutils 2.17 is standard. code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), MOVSxL II32 (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0))) (OpReg reg), ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif #else code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif return code @@ -1987,15 +1976,28 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat let - jumpTable = map jumpTableEntry ids op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), - JMP_TBL op [ id | Just id <- ids ] + JMP_TBL op ids ReadOnlyData lbl ] -- in return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) +generateJumpTableForInstr _ = Nothing + +createJumpTable ids section lbl + = let jumpTable + | opt_PIC = + let jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + in CmmData section (CmmDataLabel lbl : jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index a96452b..92655d1 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -289,7 +289,11 @@ data Instr | JMP Operand | JXX Cond BlockId -- includes unconditional branches | JXX_GBL Cond Imm -- non-local version of JXX - | JMP_TBL Operand [BlockId] -- table jump + -- Table jump + | JMP_TBL Operand -- Address to jump to + [Maybe BlockId] -- Blocks in the jump table + Section -- Data section jump table should be put in + CLabel -- Label of jump table | CALL (Either Imm Reg) [Reg] -- Other things. @@ -350,7 +354,7 @@ x86_regUsageOfInstr instr JXX _ _ -> mkRU [] [] JXX_GBL _ _ -> mkRU [] [] JMP op -> mkRUR (use_R op) - JMP_TBL op _ -> mkRUR (use_R op) + JMP_TBL op _ _ _ -> mkRUR (use_R op) CALL (Left _) params -> mkRU params callClobberedRegs CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs CLTD _ -> mkRU [eax] [edx] @@ -482,7 +486,7 @@ x86_patchRegsOfInstr instr env POP sz op -> patch1 (POP sz) op SETCC cond op -> patch1 (SETCC cond) op JMP op -> patch1 JMP op - JMP_TBL op ids -> patch1 JMP_TBL op $ ids + JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl GMOV src dst -> GMOV (env src) (env dst) GLD sz src dst -> GLD sz (lookupAddr src) (env dst) @@ -579,7 +583,7 @@ x86_jumpDestsOfInstr x86_jumpDestsOfInstr insn = case insn of JXX _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ _ -> [id | Just id <- ids] _ -> [] @@ -589,7 +593,8 @@ x86_patchJumpInstr x86_patchJumpInstr insn patchF = case insn of JXX cc id -> JXX cc (patchF id) - JMP_TBL _ _ -> error "Cannot patch JMP_TBL" + JMP_TBL op ids section lbl + -> JMP_TBL op (map (fmap patchF) ids) section lbl _ -> insn @@ -741,7 +746,7 @@ i386_insert_ffrees blocks where p insn r = case insn of CALL _ _ -> GFREE : insn : r JMP _ -> GFREE : insn : r - JXX_GBL _ _ -> GFREE : insn : r + JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL" _ -> insn : r -- if you ever add a new FP insn to the fake x86 FP insn set, diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 5fe78e1..a9ed036 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -12,7 +12,6 @@ module X86.Ppr ( pprSectionHeader, pprData, pprInstr, - pprUserReg, pprSize, pprImm, pprDataItem, @@ -34,7 +33,6 @@ import PprBase import OldCmm import CLabel -import Config import Unique ( pprUnique, Uniquable(..) ) import Pretty import FastString @@ -42,7 +40,6 @@ import qualified Outputable import Outputable (panic, Outputable) import Data.Word -import Distribution.System #if i386_TARGET_ARCH && darwin_TARGET_OS import Data.Bits @@ -87,7 +84,17 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) else empty #endif + $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl) +-- | Output the ELF .size directive. +pprSizeDecl :: CLabel -> Doc +#if elf_OBJ_FORMAT +pprSizeDecl lbl = + ptext (sLit "\t.size") <+> pprCLabel_asm lbl + <> ptext (sLit ", .-") <> pprCLabel_asm lbl +#else +pprSizeDecl _ = empty +#endif pprBasicBlock :: NatBasicBlock Instr -> Doc pprBasicBlock (BasicBlock blockid instrs) = @@ -162,12 +169,6 @@ instance Outputable Instr where ppr instr = Outputable.docToSDoc $ pprInstr instr -pprUserReg :: Reg -> Doc -pprUserReg - | cTargetArch == I386 = pprReg II32 - | cTargetArch == X86_64 = pprReg II64 - | otherwise = panic "X86.Ppr.pprUserReg: not defined" - pprReg :: Size -> Reg -> Doc pprReg s r @@ -626,7 +627,7 @@ pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op) -pprInstr (JMP_TBL op _) = pprInstr (JMP op) +pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 094b74d..28d148c 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -249,7 +249,6 @@ floatregnos = fakeregnos ++ xmmregnos; -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. -- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. argRegs :: RegNo -> [Reg] argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" @@ -333,10 +332,24 @@ fake5 = regSingle 21 {- AMD x86_64 architecture: -- Registers 0-16 have 32-bit counterparts (eax, ebx etc.) -- Registers 0-7 have 16-bit counterparts (ax, bx etc.) -- Registers 0-3 have 8 bit counterparts (ah, bh etc.) - +- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: + + 8 16 32 64 + --------------------- + al ax eax rax + bl bx ebx rbx + cl cx ecx rcx + dl dx edx rdx + sil si esi rsi + dil si edi rdi + bpl bp ebp rbp + spl sp esp rsp + r10b r10w r10d r10 + r11b r11w r11d r11 + r12b r12w r12d r12 + r13b r13w r13d r13 + r14b r14w r14d r14 + r15b r15w r15d r15 -} rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5c41d72..46f7488 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) { mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, @@ -1873,34 +1873,35 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = genericsBit `setBitIf` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + bitmap = genericsBit `setBitIf` xopt Opt_Generics flags + .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bfadfba..aa20ea6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1283,14 +1283,9 @@ exp10 :: { LHsExpr RdrName } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } - | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)) } - | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo MDoExpr - [L loc (mkRecStmt stmts)] - body)) } + | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } + | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } + | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1465,7 +1460,10 @@ list :: { LHsExpr RdrName } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return (sL (comb2 $1 $>) $ + mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@ -1480,7 +1478,7 @@ flattenedpquals :: { Located [LStmt RdrName] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -1537,7 +1535,7 @@ parr :: { LHsExpr RdrName } (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } + | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 } -- We are reusing `lexps' and `flattenedpquals' from the list case. diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 47abf23..3b14990 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -40,8 +40,7 @@ module RdrHsSyn ( checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] - checkDo, -- [Stmt] -> P [Stmt] - checkMDo, -- [Stmt] -> P [Stmt] + checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -54,6 +53,7 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer @@ -611,34 +611,6 @@ checkPred (L spn ty) check loc _ _ = parseErrorSDoc loc (text "malformed class assertion:" <+> ppr ty) ---------------------------------------------------------------------------- --- Checking statements in a do-expression --- We parse do { e1 ; e2 ; } --- as [ExprStmt e1, ExprStmt e2] --- checkDo (a) checks that the last thing is an ExprStmt --- (b) returns it separately --- same comments apply for mdo as well - -checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) - -checkDo = checkDoMDo "a " "'do'" -checkMDo = checkDoMDo "an " "'mdo'" - -checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) -checkDoMDo pre nm _ ss = do - check ss - where - check [] = panic "RdrHsSyn:checkDoMDo" - check [L _ (ExprStmt e _ _)] = return ([], e) - check [L l e] = parseErrorSDoc l - (text ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression:") - $$ ppr e) - check (s:ss) = do - (ss',e') <- check ss - return ((s:ss'),e') - -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -912,6 +884,20 @@ isFunLhs e = go e [] _ -> return Nothing } go _ _ = return Nothing + +--------------------------------------------------------------------------- +-- Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a `MonadComp' context, +-- otherwise use the usual `ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + --------------------------------------------------------------------------- -- Miscellaneous utilities diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 24756d5..e1d287a 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -160,6 +160,7 @@ basicKnownKeyNames -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, failMName, bindMName, thenMName, returnMName, + fmapName, -- MonadRec stuff mfixName, @@ -221,6 +222,12 @@ basicKnownKeyNames -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName + + -- Monad comprehensions + , guardMName + , liftMName + , groupMName + , mzipName ] genericTyConNames :: [Name] @@ -262,8 +269,9 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, - dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE, - gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module + dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") @@ -311,6 +319,8 @@ gHC_INT = mkBaseModule (fsLit "GHC.Int") gHC_WORD = mkBaseModule (fsLit "GHC.Word") mONAD = mkBaseModule (fsLit "Control.Monad") mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group") +mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") aRROW = mkBaseModule (fsLit "Control.Arrow") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") @@ -597,12 +607,13 @@ inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) -eqClassName, eqName, ordClassName, geName, functorClassName :: Name +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name @@ -834,6 +845,14 @@ appAName = varQual aRROW (fsLit "app") appAIdKey choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey loopAName = varQual aRROW (fsLit "loop") loopAIdKey +-- Monad comprehensions +guardMName, liftMName, groupMName, mzipName :: Name +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +groupMName = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey +mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + -- Annotation type checking toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey @@ -1280,7 +1299,8 @@ unboundKey = mkPreludeMiscIdUnique 101 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey + failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, + fmapClassOpKey :: Unique fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 @@ -1295,6 +1315,7 @@ negateClassOpKey = mkPreludeMiscIdUnique 111 failMClassOpKey = mkPreludeMiscIdUnique 112 bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 115 returnMClassOpKey = mkPreludeMiscIdUnique 117 -- Recursive do notation @@ -1325,6 +1346,14 @@ realToFracIdKey = mkPreludeMiscIdUnique 128 toIntegerClassOpKey = mkPreludeMiscIdUnique 129 toRationalClassOpKey = mkPreludeMiscIdUnique 130 +-- Monad comprehensions +guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 131 +liftMIdKey = mkPreludeMiscIdUnique 132 +groupMIdKey = mkPreludeMiscIdUnique 133 +mzipIdKey = mkPreludeMiscIdUnique 134 + + ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 ----------------------------------------------------- diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index b37556b..8f2d21f 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it like that, so we use a BuiltinRule instead, so that we can match in any two literal values. So the rule is really more like - (Lit 4) +# (Lit y) = Lit (x+#y) + (Lit x) +# (Lit y) = Lit (x+#y) where the (+#) on the rhs is done at compile time That is why these rules are built in here. Other rules diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 777e83f..49f7a97 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1121,6 +1121,12 @@ primop AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp out_of_line = True has_side_effects = True +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) + with + out_of_line = True + has_side_effects = True + ------------------------------------------------------------------------ section "Exceptions" ------------------------------------------------------------------------ @@ -1732,9 +1738,19 @@ primtype Any a but never enters a function value. It's also used to instantiate un-constrained type variables after type - checking. For example + checking. For example, {\tt length} has type + + {\tt length :: forall a. [a] -> Int} + + and the list datacon for the empty list has type + + {\tt [] :: forall a. [a]} + + In order to compose these two terms as {\tt length []} a type + application is required, but there is no constraint on the + choice. In this situation GHC uses {\tt Any}: - {\tt length Any []} + {\tt length Any ([] Any)} Annoyingly, we sometimes need {\tt Any}s of other kinds, such as {\tt (* -> *)} etc. This is a bit like tuples. We define a couple of useful ones here, diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs new file mode 100644 index 0000000..7e223f8 --- /dev/null +++ b/compiler/profiling/ProfInit.hs @@ -0,0 +1,45 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- Generate code to initialise cost centres +-- +-- ----------------------------------------------------------------------------- + +module ProfInit (profilingInitCode) where + +import CLabel +import CostCentre +import Outputable +import StaticFlags +import FastString +import Module + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = empty + | otherwise + = vcat + [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat ( + map emitRegisterCC local_CCs ++ + map emitRegisterCCS singleton_CCSs + )) + ] + where + emitRegisterCC cc = + ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi + where cc_lbl = ppr (mkCCLabel cc) + emitRegisterCCS ccs = + ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi + where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 0b10764..dc7ea96 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -306,7 +306,10 @@ rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs) (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs } rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -357,7 +360,9 @@ rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- let x = x in 3 -- should report 'x' unused ; let real_uses = findUses dus result_fvs - ; warnUnusedLocalBinds bound_names real_uses + -- Insert fake uses for variables introduced implicitly by wildcards (#4404) + implicit_uses = hsValBindsImplicits binds' + ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses) ; let -- The variables "used" in the val binds are: @@ -697,7 +702,7 @@ renameSig _ (SpecInstSig ty) -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike alll other signatures +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig mb_names sig@(SpecSig v ty inl) = do { new_v <- case mb_names of Just {} -> lookupSigOccRn mb_names sig v @@ -784,9 +789,9 @@ rnGRHS' ctxt (GRHS guards rhs) -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (ExprStmt _ _ _)] = True - is_standard_guard _ = False + is_standard_guard [] = True + is_standard_guard [L _ (ExprStmt _ _ _ _)] = True + is_standard_guard _ = False \end{code} %************************************************************************ diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 97f4ab3..c4ad95a 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -12,7 +12,7 @@ module RnEnv ( lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, + lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -754,6 +754,17 @@ We treat the orignal (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. \begin{code} +lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr Name)) return type +lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 6d425d0..46eef67 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -40,7 +40,7 @@ import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List -import Util ( isSingleton ) +import Util ( isSingleton, snocView ) import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -224,10 +224,9 @@ rnExpr (HsLet binds expr) rnLExpr expr `thenM` \ (expr',fvExpr) -> return (HsLet binds' expr', fvExpr) -rnExpr (HsDo do_or_lc stmts body _) - = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ -> - rnLExpr body - ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } +rnExpr (HsDo do_or_lc stmts _) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -268,13 +267,10 @@ rnExpr (ExprWithTySig expr pty) rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; rebind <- xoptM Opt_RebindableSyntax - ; if not rebind - then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))) - ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }} + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> @@ -444,9 +440,9 @@ convertOpFormsCmd (HsIf f exp c1 c2) convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts body ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) - (convertOpFormsLCmd body) ty +convertOpFormsCmd (HsDo DoExpr stmts ty) + = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty + -- Mark the HsDo as begin the body of an arrow command -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -456,8 +452,8 @@ convertOpFormsCmd c = c convertOpFormsStmt :: StmtLR id id -> StmtLR id id convertOpFormsStmt (BindStmt pat cmd _ _) = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr -convertOpFormsStmt (ExprStmt cmd _ _) - = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType +convertOpFormsStmt (ExprStmt cmd _ _ _) + = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts }) = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts } convertOpFormsStmt stmt = stmt @@ -498,14 +494,10 @@ methodNamesCmd (HsPar c) = methodNamesLCmd c methodNamesCmd (HsIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet _ c) = methodNamesLCmd c - -methodNamesCmd (HsDo _ stmts body _) - = methodNamesStmts stmts `plusFV` methodNamesLCmd body - -methodNamesCmd (HsApp c _) = methodNamesLCmd c - -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsLet _ c) = methodNamesLCmd c +methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts +methodNamesCmd (HsApp c _) = methodNamesLCmd c +methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@ -541,14 +533,14 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name -> FreeVars -methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd +methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt _) = emptyFVs -methodNamesStmt (ParStmt _) = emptyFVs -methodNamesStmt (TransformStmt {}) = emptyFVs -methodNamesStmt (GroupStmt {}) = emptyFVs - -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error +methodNamesStmt (ParStmt _ _ _ _) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@ -591,14 +583,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr n) = do { name <- lookupOccRn n - ; this_mod <- getModule - ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the - ; return () } -- only way that is going to happen - ; return (VarBr name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") +rnBracket (VarBr n) + = do { name <- lookupOccRn n + ; this_mod <- getModule + ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes + do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and + ; return () } -- this is the only way that is going + -- to happen + ; return (VarBr name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@ -628,7 +622,8 @@ rnBracket (DecBrL decls) rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" @@ -642,44 +637,72 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \begin{code} rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars --- --- Renaming a single RecStmt can give a sequence of smaller Stmts -rnStmts _ [] thing_inside - = do { (res, fvs) <- thing_inside [] - ; return (([], res), fvs) } +rnStmts ctxt [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmts MDoExpr stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts + +rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt lstmt' thing_inside } -rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside + | otherwise = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ - rnStmt ctxt stmt $ \ bndrs1 -> - rnStmts ctxt stmts $ \ bndrs2 -> - thing_inside (bndrs1 ++ bndrs2) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt lstmt $ \ bndrs1 -> + rnStmts ctxt lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } - -rnStmt :: HsStmtContext Name -> LStmt RdrName +---------------------- +rnStmt :: HsStmtContext Name + -> LStmt RdrName -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside +rnStmt ctxt (L loc (LastStmt expr _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; (thing, fvs2) <- thing_inside [] - ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2) } + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt expr' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside + = do { (expr', fv_expr) <- rnLExpr expr + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), @@ -687,15 +710,13 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (L loc (LetStmt binds)) thing_inside - = do { checkLetStmt ctxt binds - ; rnLocalBindsAndThen binds $ \binds' -> do +rnStmt _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { checkRecStmt ctxt - + = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the -- finally-returned free-vars.) @@ -710,9 +731,9 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupSyntaxName returnMName - ; (mfix_op, fvs2) <- lookupSyntaxName mfixName - ; (bind_op, fvs3) <- lookupSyntaxName bindMName + ; (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName ; let -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@ -737,57 +758,51 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt (L loc (ParStmt segs)) thing_inside - = do { checkParStmt ctxt - ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside - ; return (([L loc (ParStmt segs')], thing), fvs) } - -rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside - = do { checkTransformStmt ctxt - - ; (using', fvs1) <- rnLExpr using - - ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> - do { (by', fvs_by) <- case by of - Nothing -> return (Nothing, emptyFVs) - Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) } - ; (thing, fvs_thing) <- thing_inside bndrs - ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free varaible of - -- the "thing inside", **or of the by-expression**, as used - ; return ((by', used_bndrs, thing), fvs) } - - ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), - fvs1 `plusFV` fvs2) } - -rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside - = do { checkTransformStmt ctxt - - -- Rename the 'using' expression in the context before the transform is begun - ; (using', fvs1) <- case using of - Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) } - Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName - ; return (Right e', fvs) } +rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- case form of + GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName + ; return (noLoc e, fvs) } + _ -> rnLExpr using -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free varaible + -- of the "thing inside", **or of the by-expression**, as used ; return ((by', used_bndrs, thing), fvs) } - ; let all_fvs = fvs1 `plusFV` fvs2 + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noSyntaxExpr, emptyFVs) + _ -> lookupStmtName ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [GroupStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) - ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) } - + ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@ -823,6 +838,27 @@ rnParallelStmts ctxt segs thing_inside cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) \end{code} Note [Renaming parallel Stmts] @@ -874,13 +910,15 @@ rnRecStmtsAndThen s cont -- ...bring them and their fixities into scope ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside { segs <- rn_rec_stmts bound_names new_lhs_and_fv ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names fvs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt @@ -902,9 +940,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName, FreeVars)] -rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), - -- this is actually correct - emptyFVs)] +rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) + = return [(L loc (ExprStmt expr a b c), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) + = return [(L loc (LastStmt expr a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) = do @@ -927,13 +967,10 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) @@ -958,11 +995,17 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _ +rn_rec_stmt _ (L loc (LastStmt expr _)) _ + = do { (expr', fv_expr) <- rnLExpr expr + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt expr' ret_op))] } + +rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (ExprStmt expr' then_op placeHolderType))] + L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))] rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat = rnLExpr expr `thenM` \ (expr', fv_expr) -> @@ -992,11 +1035,8 @@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) - -rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt) +rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" @@ -1142,44 +1182,151 @@ program. %************************************************************************ \begin{code} +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) ----------------------- --- Checking when a particular Stmt is ok -checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM () -checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds) -checkLetStmt _ctxt _binds = return () - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False ---------- -checkRecStmt :: HsStmtContext Name -> RnM () -checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo' -checkRecStmt DoExpr = return () -- and in 'do' -checkRecStmt ctxt = addErr msg - where - msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt +emptyErr :: HsStmtContext Name -> SDoc +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------- -checkParStmt :: HsStmtContext Name -> RnM () -checkParStmt _ - = do { parallel_list_comp <- xoptM Opt_ParallelListComp - ; checkErr parallel_list_comp msg } +---------------------- +checkLastStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM (LStmt RdrName) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + PArrComp -> check_comp + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other where - msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp") + check_do -- Expect ExprStmt, and change it to LastStmt + = case stmt of + ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } ---------- -checkTransformStmt :: HsStmtContext Name -> RnM () -checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the - -- desugarer will break when we come to operate on a parallel array - = do { transform_list_comp <- xoptM Opt_TransformListComp - ; checkErr transform_list_comp msg } - where - msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp") -checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt ctxt = addErr msg +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDOpts + ; case okStmt dflags ctxt stmt of + Nothing -> return () + Just extra -> addErr (msg $$ extra) } where - msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext ctxt ] + +pprStmtCat :: Stmt a -> SDoc +pprStmtCat (TransStmt {}) = ptext (sLit "transform") +pprStmtCat (LastStmt {}) = ptext (sLit "return expression") +pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") +pprStmtCat (BindStmt {}) = ptext (sLit "binding") +pprStmtCat (LetStmt {}) = ptext (sLit "let") +pprStmtCat (RecStmt {}) = ptext (sLit "rec") +pprStmtCat (ParStmt {}) = ptext (sLit "parallel") + +------------ +isOK, notOK :: Maybe SDoc +isOK = Nothing +notOK = Just empty + +okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: DynFlags -> HsStmtContext Name + -> Stmt RdrName -> Maybe SDoc +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to an generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt RdrName -> Maybe SDoc +okPatGuardStmt stmt + = case stmt of + ExprStmt {} -> isOK + BindStmt {} -> isOK + LetStmt {} -> isOK + _ -> notOK + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt (HsIPBinds {}) -> notOK + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | Opt_DoRec `xopt` dflags -> isOK + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XDoRec")) + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + _ -> notOK + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} + | Opt_TransformListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + +---------------- +okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} -> notOK + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 725baeb..18c2dfd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -1252,4 +1252,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" -\end{code} \ No newline at end of file +\end{code} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index c527d82..6ddcff2 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -370,13 +370,21 @@ getCoreToDo dflags simpl_phase phase names iter = CoreDoPasses - [ maybe_strictness_before phase + $ [ maybe_strictness_before phase , CoreDoSimplify iter (base_mode { sm_phase = Phase phase , sm_names = names }) - , maybe_rule_check (Phase phase) - ] + , maybe_rule_check (Phase phase) ] + + -- Vectorisation can introduce a fair few common sub expressions involving + -- DPH primitives. For example, see the Reverse test from dph-examples. + -- We need to eliminate these common sub expressions before their definitions + -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings, + -- so we also run simpl_gently to inline them. + ++ (if dopt Opt_Vectorise dflags && phase == 3 + then [CoreCSE, simpl_gently] + else []) vectorisation = runWhen (dopt Opt_Vectorise dflags) $ diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 8249c89..db84c90 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1237,10 +1237,10 @@ completeCall env var cont | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1393,10 +1393,10 @@ tryRules env rules fn args call_cont , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff | not (dopt Opt_D_dump_rule_rewrites dflags) - = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprTrace "Rule fired" + = pprDefiniteTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index ae4a1e8..cfbdf35 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -7,7 +7,7 @@ Typecheck arrow notation \begin{code} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches @@ -17,7 +17,9 @@ import TcBinds import TcPat import TcUnify import TcRnMonad +import TcEnv import Coercion +import Id( mkLocalId ) import Inst import Name import TysWiredIn @@ -83,20 +85,12 @@ tcCmdTop :: CmdEnv tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty = setSrcSpan loc $ - do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty + do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack - -> TcTauType -> TcM (LHsExpr TcId) --- A wrapper that deals with the refinement (if any) -tcGuardedCmd env expr stk res_ty - = do { body <- tcCmd env expr (stk, res_ty) - ; return body - } - tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function tcCmd env (L loc expr) res_ty @@ -123,7 +117,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } - mc_body body res_ty' = tcGuardedCmd env body stk res_ty' + mc_body body res_ty' = tcCmd env body (stk, res_ty') tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty) = do { pred_ty <- newFlexiTyVarTy openTypeKind @@ -206,22 +200,18 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig ; return (GRHSs grhss' binds') } tc_grhs res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $ - tcGuardedCmd env body stk' + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk', res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty) +tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $ - tcGuardedCmd env body [] - ; return (HsDo do_or_lc stmts' body' res_ty) } + ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty + ; return (HsDo do_or_lc stmts' res_ty) } where - tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs ([], ty) - ; return (rhs', ty) } ----------------------------------------------------------------- @@ -307,6 +297,69 @@ tc_cmd _ cmd _ %************************************************************************ %* * + Stmts +%* * +%************************************************************************ + +\begin{code} +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcStmtChecker +tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs ([], res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } + +tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + +tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames + , recS_rec_ids = recNames }) res_ty thing_inside + = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind + ; let rec_ids = zipWith mkLocalId recNames rec_tys + ; tcExtendIdEnv rec_ids $ do + { (stmts', (later_ids, rec_rets)) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + do { rec_rets <- zipWithM tcCheckId recNames rec_tys + ; later_ids <- tcLookupLocalIds laterNames + ; return (later_ids, rec_rets) } + + ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) + + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs ([], ty) + ; return (rhs', ty) } +\end{code} + + +%************************************************************************ +%* * Helpers %* * %************************************************************************ diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8a6a3b7..33e9081 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,6 @@ import TcHsType import TcPat import TcMType import TcType -import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -44,7 +43,6 @@ import BasicTypes import Outputable import FastString -import Data.List( partition ) import Control.Monad #include "HsVersions.h" @@ -559,24 +557,16 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] tcImpPrags prags = do { this_mod <- getModule - ; let is_imp prag - = case sigName prag of - Nothing -> False - Just name -> not (nameIsLocalOrFrom this_mod name) - (spec_prags, others) = partition isSpecLSig $ - filter is_imp prags - ; mapM_ misplacedSigErr others - -- Messy that this misplaced-sig error comes here - -- but the others come from the renamer - ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } - -tcImpSpec :: Sig Name -> TcM TcSpecPrag -tcImpSpec prag@(SpecSig (L _ name) _ _) + ; mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] } + +tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag +tcImpSpec (name, prag) = do { id <- tcLookupId name ; checkTc (isAnyInlinePragma (idInlinePragma id)) (impSpecErr name) ; tcSpec id prag } -tcImpSpec p = pprPanic "tcImpSpec" (ppr p) impSpecErr :: Name -> SDoc impSpecErr name diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 2988f08..1798be3 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1282,7 +1282,7 @@ inferInstanceContexts oflag infer_specs gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt clas inst_tys) $ + addErrCtxt (derivInstCtxt the_pred) $ do { -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts @@ -1297,7 +1297,7 @@ inferInstanceContexts oflag infer_specs , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; theta <- simplifyDeriv orig tyvars deriv_rhs + ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -1307,6 +1307,8 @@ inferInstanceContexts oflag infer_specs -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution + where + the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance @@ -1511,9 +1513,9 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: Class -> [Type] -> Message -derivInstCtxt clas inst_tys - = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) +derivInstCtxt :: PredType -> Message +derivInstCtxt pred + = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) badDerivedPred :: PredType -> Message badDerivedPred pred diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index f714943..645c43a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -15,6 +15,7 @@ import TcMType import TcSMonad import TcType import TypeRep +import Type( isTyVarTy ) import Inst import InstEnv @@ -320,15 +321,10 @@ reportEqErr ctxt ty1 ty2 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () -- tv1 and ty2 are already tidied reportTyVarEqErr ctxt tv1 ty2 - | not is_meta1 - , Just tv2 <- tcGetTyVar_maybe ty2 - , isMetaTyVar tv2 - = -- sk ~ alpha: swap - reportTyVarEqErr ctxt tv2 ty1 - - | (not is_meta1) - = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrorReport (addExtraInfo ctxt ty1 ty2) + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient + || isSigTyVar tv1 && not (isTyVarTy ty2) + = addErrorReport (addExtraInfo ctxt ty1 ty2) (misMatchOrCND ctxt ty1 ty2) -- So tv is a meta tyvar, and presumably it is @@ -376,21 +372,26 @@ reportTyVarEqErr ctxt tv1 ty2 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } - | otherwise -- This can happen, by a recursive decomposition of frozen - -- occurs check constraints - -- Example: alpha ~ T Int alpha has frozen. - -- Then alpha gets unified to T beta gamma - -- So now we have T beta gamma ~ T Int (T beta gamma) - -- Decompose to (beta ~ Int, gamma ~ T beta gamma) - -- The (gamma ~ T beta gamma) is the occurs check, but - -- the (beta ~ Int) isn't an error at all. So return () - = return () - + | otherwise + = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + return () + -- I don't think this should happen, and if it does I want to know + -- Trac #5130 happened because an actual type error was not + -- reported at all! So not reporting is pretty dangerous. + -- + -- OLD, OUT OF DATE COMMENT + -- This can happen, by a recursive decomposition of frozen + -- occurs check constraints + -- Example: alpha ~ T Int alpha has frozen. + -- Then alpha gets unified to T beta gamma + -- So now we have T beta gamma ~ T Int (T beta gamma) + -- Decompose to (beta ~ Int, gamma ~ T beta gamma) + -- The (gamma ~ T beta gamma) is the occurs check, but + -- the (beta ~ Int) isn't an error at all. So return () where - is_meta1 = isMetaTyVar tv1 - k1 = tyVarKind tv1 - k2 = typeKind ty2 - ty1 = mkTyVarTy tv1 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + ty1 = mkTyVarTy tv1 mkTyFunInfoMsg :: TcType -> TcType -> SDoc -- See Note [Non-injective type functions] @@ -458,12 +459,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants typeExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv - , isSkolemTyVar tv - = pprSkolTvBinding implics tv - where -typeExtraInfoMsg _ _ = empty -- Normal case - + , isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + + where + ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful + ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), + sep [ppr info, ptext (sLit "at") <+> ppr loc]] + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env @@ -659,7 +670,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc) -- ASSUMPTION: the Insts are fully zonked mkMonomorphismMsg ctxt inst_tvs = do { dflags <- getDOpts - ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs)) ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where @@ -685,28 +695,6 @@ monomorphism_fix dflags else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! - -pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc --- Print info about the binding of a skolem tyvar, --- or nothing if we don't have anything useful to say -pprSkolTvBinding implics tv - | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) - | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv) - where - ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv) - ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") - ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") - <+> quotes (ppr n) - ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") - - - ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") - ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, - ptext (sLit "at") <+> ppr (getSrcLoc tv)]] - getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 6bb0820..79b097e 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -45,6 +45,7 @@ import Type import Coercion import Var import VarSet +import VarEnv import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) @@ -55,6 +56,7 @@ import SrcLoc import Util import ListSetOps import Maybes +import ErrUtils import Outputable import FastString import Control.Monad @@ -415,8 +417,8 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] -- and it maintains uniformity with other rebindable syntax ; return (HsIf (Just fun') pred' b1' b2') } -tcExpr (HsDo do_or_lc stmts body _) res_ty - = tcDoStmts do_or_lc stmts body res_ty +tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty @@ -820,7 +822,7 @@ tcApp fun args res_ty -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- addErrCtxt (funResCtxt fun) $ + ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ unifyType actual_res_ty res_ty -- Typecheck the arguments @@ -1386,9 +1388,23 @@ funAppCtxt fun arg arg_no quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) -funResCtxt :: LHsExpr Name -> SDoc -funResCtxt fun - = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) +funResCtxt :: LHsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, Message) +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +funResCtxt fun fun_res_ty res_ty env0 + = do { fun_res' <- zonkTcType fun_res_ty + ; res' <- zonkTcType res_ty + ; let n_fun = length (fst (tcSplitFunTys fun_res')) + n_res = length (fst (tcSplitFunTys res')) + what | n_fun > n_res = ptext (sLit "few") + | otherwise = ptext (sLit "many") + extra | n_fun == n_res = empty + | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too") <+> what + <+> ptext (sLit "arguments") + msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + ; return (env0, msg $$ extra) } badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 73fd449..8f53d6e 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this module checks to see if a foreign declaration has got a legal type. \begin{code} -module TcForeign - ( - tcForeignImports +module TcForeign + ( + tcForeignImports , tcForeignExports - ) where + ) where #include "HsVersions.h" @@ -43,18 +43,18 @@ import FastString -- Defines a binding isForeignImport :: LForeignDecl name -> Bool isForeignImport (L _ (ForeignImport _ _ _)) = True -isForeignImport _ = False +isForeignImport _ = False -- Exports a binding isForeignExport :: LForeignDecl name -> Bool isForeignExport (L _ (ForeignExport _ _ _)) = True -isForeignExport _ = False +isForeignExport _ = False \end{code} %************************************************************************ -%* * +%* * \subsection{Imports} -%* * +%* * %************************************************************************ \begin{code} @@ -64,22 +64,22 @@ tcForeignImports decls tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl) - = addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (_, t_ty) = tcSplitForAllTys sig_ty - (arg_tys, res_ty) = tcSplitFunTys t_ty - id = mkLocalId nm sig_ty - -- Use a LocalId to obey the invariant that locally-defined - -- things are LocalIds. However, it does not need zonking, - -- (so TcHsSyn.zonkForeignExports ignores it). - - ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl - -- Can't use sig_ty here because sig_ty :: Type and - -- we need HsType Id hence the undefined - ; return (id, ForeignImport (L loc id) undefined imp_decl') } + = addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + ; let + -- Drop the foralls before inspecting the + -- structure of the foreign type. + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty + id = mkLocalId nm sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so TcHsSyn.zonkForeignExports ignores it). + + ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; return (id, ForeignImport (L loc id) undefined imp_decl') } tcFImport d = pprPanic "tcFImport" (ppr d) \end{code} @@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) do { checkCg checkCOrAsmOrLlvmOrInterp ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) - ; return idecl } -- NB check res_ty not sig_ty! - -- In case sig_ty is (forall a. ForeignPtr a) + ; return idecl } -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do - -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a - -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well - -- as ft -> IO Addr is accepted, too. The use of the latter two forms - -- is DEPRECATED, though. + -- Foreign wrapper (former f.e.d.) + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a + -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well + -- as ft -> IO Addr is accepted, too. The use of the latter two forms + -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv checkSafety safety @@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty \end{code} %************************************************************************ -%* * +%* * \subsection{Exports} -%* * +%* * %************************************************************************ \begin{code} -tcForeignExports :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where @@ -190,25 +190,25 @@ tcForeignExports decls return (b `consBag` binds, f:fs) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) -tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = - addErrCtxt (foreignDeclCtxt fo) $ do +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) + = addErrCtxt (foreignDeclCtxt fo) $ do - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcPolyExpr (nlHsVar nm) sig_ty - tcCheckFEType sig_ty spec + tcCheckFEType sig_ty spec - -- we're exporting a function, but at a type possibly more - -- constrained than its declared/inferred type. Hence the need - -- to create a local binding which will call the exported function - -- at a particular type (and, maybe, overloading). + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need + -- to create a local binding which will call the exported function + -- at a particular type (and, maybe, overloading). - -- We need to give a name to the new top-level binding that - -- is *stable* (i.e. the compiler won't change it later), - -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} @@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do %************************************************************************ -%* * +%* * \subsection{Miscellaneous} -%* * +%* * %************************************************************************ \begin{code} @@ -246,7 +246,7 @@ checkForeignArgs pred tys go ty = check (pred ty) (illegalForeignTyErr argument ty) ------------ Checking result types for foreign calls ---------------------- --- Check that the type has the form +-- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () @@ -256,14 +256,14 @@ nonIOok = True mustBeIO = False checkForeignRes non_io_result_ok pred_res_ty ty - -- (IO t) is ok, and so is any newtype wrapping thereof + -- (IO t) is ok, and so is any newtype wrapping thereof | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty = return () - + | otherwise - = check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr result ty) + = check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr result ty) \end{code} \begin{code} @@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing checkCOrAsmOrLlvm HscAsm = Nothing checkCOrAsmOrLlvm HscLlvm = Nothing checkCOrAsmOrLlvm _ - = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") + = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrInterp HscC = Nothing @@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = Just (text "requires interpreted, C, Llvm or native code generation") checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing @@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = Just (text "requires interpreted, C, Llvm or native code generation") checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do - dflags <- getDOpts - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - Nothing -> return () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + dflags <- getDOpts + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + Nothing -> return () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} - + Calling conventions \begin{code} checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () +checkCConv CCallConv = return () #if i386_TARGET_ARCH -checkCConv StdCallConv = return () +checkCConv StdCallConv = return () #else -- This is a warning, not an error. see #3336 -checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall") +checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") #endif checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") -checkCConv CmmCallConv = panic "checkCConv CmmCallConv" +checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} Deprecated "threadsafe" calls @@ -329,12 +329,12 @@ Warnings \begin{code} check :: Bool -> Message -> TcM () -check True _ = return () +check True _ = return () check _ the_err = addErrTc the_err illegalForeignTyErr :: SDoc -> Type -> SDoc illegalForeignTyErr arg_or_res ty - = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, + = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, ptext (sLit "type in foreign declaration:")]) 2 (hsep [ppr ty]) @@ -344,12 +344,11 @@ argument = text "argument" result = text "result" badCName :: CLabelString -> Message -badCName target - = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] +badCName target + = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) 2 (ppr fo) \end{code} - diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c04cf4..dba87d2 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -779,7 +779,7 @@ gen_Ix_binds loc tycon single_con_range = mk_easy_FunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - nlHsDo ListComp stmts con_expr + noLoc (mkHsComp ListComp stmts con_expr) where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -893,15 +893,15 @@ gen_Read_binds get_fixity loc tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the -- enclosing "parens" call, so here we must match the naked -- data_con_str con - match_con con | isSym con_str = symbol_pat con_str - | otherwise = ident_pat con_str + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str where con_str = data_con_str con -- For nullary constructors we must match Ident s for normal constrs @@ -925,12 +925,12 @@ gen_Read_binds get_fixity loc tycon prefix_parser = mk_parser prefix_prec prefix_stmts body read_prefix_con - | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] - | otherwise = [bindLex (ident_pat con_str)] + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str read_infix_con - | isSym con_str = [bindLex (symbol_pat con_str)] - | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] prefix_stmts -- T a b c = read_prefix_con ++ read_args @@ -965,15 +965,23 @@ gen_Read_binds get_fixity loc tycon ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) - bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP + symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP data_con_str con = occNameString (getOccName con) @@ -991,11 +999,9 @@ gen_Read_binds get_fixity loc tycon -- or (#) = 4 -- Note the parens! read_lbl lbl | isSym lbl_str - = [read_punc "(", - bindLex (symbol_pat lbl_str), - read_punc ")"] + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] | otherwise - = [bindLex (ident_pat lbl_str)] + = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 122b743..d179a0e 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -578,11 +578,10 @@ zonkExpr env (HsLet binds expr) zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts body ty) - = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> - zonkLExpr new_env body `thenM` \ new_body -> +zonkExpr env (HsDo do_or_lc stmts ty) + = zonkStmts env stmts `thenM` \ (_, new_stmts) -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsDo do_or_lc new_stmts new_body new_ty) + returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -728,22 +727,26 @@ zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs) +zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - return (env1, ParStmt new_stmts_w_bndrs) + zonkExpr env1 mzip_op `thenM` \ new_mzip -> + zonkExpr env1 bind_op `thenM` \ new_bind -> + zonkExpr env1 return_op `thenM` \ new_return -> + return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return) where zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id @@ -756,28 +759,34 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets }) } + , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } -zonkStmt env (ExprStmt expr then_op ty) +zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> zonkExpr env then_op `thenM` \ new_then -> + zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_ty) + returnM (env, ExprStmt new_expr new_then new_guard new_ty) -zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr) - = do { (env', stmts') <- zonkStmts env stmts - ; let binders' = zonkIdOccs env' binders - ; usingExpr' <- zonkLExpr env' usingExpr - ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr - ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') } - -zonkStmt env (GroupStmt stmts binderMap by using) +zonkStmt env (LastStmt expr ret_op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_expr new_ret) + +zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using + ; return_op' <- zonkExpr env' return_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using') } + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder @@ -795,11 +804,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) -zonkMaybeLExpr _ Nothing = return Nothing -zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) - - ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) @@ -1112,4 +1116,4 @@ zonkTypeZapping ty zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } -\end{code} \ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 4a049aa..fb6929a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1049,9 +1049,16 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i | nm1 == nm2 = -- See Note [When improvement happens] do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation] - ; let flav = Wanted (combineCtLoc ifl wfl) - ; cans <- mkCanonical flav co_var - ; mkIRContinue "IP/IP fundep" workItem KeepInert cans } + ; let flav = Wanted (combineCtLoc ifl wfl) + ; cans <- mkCanonical flav co_var + ; case wfl of + Given {} -> pprPanic "Unexpected given IP" (ppr workItem) + Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) + Wanted {} -> + do { setIPBind (cc_id workItem) $ + EvCast id1 (mkSymCoercion (mkCoVarCoercion co_var)) + ; mkIRStopK "IP/IP interaction (solved)" cans } + } -- Never rewrite a given with a wanted equality, and a type function -- equality can never rewrite an equality. We rewrite LHS *and* RHS diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 7453334..1d163aa 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -34,8 +34,8 @@ module TcMType ( -------------------------------- -- Instantiation - tcInstTyVar, tcInstTyVars, tcInstSigTyVars, - tcInstType, instMetaTyVar, + tcInstTyVars, tcInstSigTyVars, + tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, @@ -258,8 +258,17 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv) - -- ToDo: the "function binding site is bogus +tcInstSigTyVars = mapM tcInstSigTyVar + +tcInstSigTyVar :: TyVar -> TcM TcTyVar +tcInstSigTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = setNameUnique (tyVarName tyvar) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } \end{code} @@ -277,9 +286,9 @@ newMetaTyVar meta_info kind ; ref <- newMutVar Flexi ; let name = mkTcTyVarName uniq s s = case meta_info of - TauTv -> fsLit "t" - TcsTv -> fsLit "u" - SigTv _ -> fsLit "a" + TauTv -> fsLit "t" + TcsTv -> fsLit "u" + SigTv -> fsLit "a" ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } mkTcTyVarName :: Unique -> FastString -> Name @@ -287,16 +296,6 @@ mkTcTyVarName :: Unique -> FastString -> Name -- leaving the un-cluttered names free for user names mkTcTyVarName uniq str = mkSysTvName uniq str -instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar --- Make a new meta tyvar whose Name and Kind --- come from an existing TyVar -instMetaTyVar meta_info tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = mkSystemName uniq (getOccName tyvar) - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } - readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) @@ -394,10 +393,6 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVar :: TyVar -> TcM TcTyVar --- Instantiate with a META type variable -tcInstTyVar tyvar = instMetaTyVar TauTv tyvar - tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables tcInstTyVars tyvars @@ -407,6 +402,16 @@ tcInstTyVars tyvars -- Since the tyvars are freshly made, -- they cannot possibly be captured by -- any existing for-alls. Hence zipTopTvSubst + +tcInstTyVar :: TyVar -> TcM TcTyVar +-- Make a new unification variable tyvar whose Name and Kind +-- come from an existing TyVar +tcInstTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = mkSystemName uniq (getOccName tyvar) + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv TauTv ref)) } \end{code} diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 860a6db..48fdf77 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -6,16 +6,18 @@ TcMatches: Typecheck some @Matches@ \begin{code} +{-# OPTIONS_GHC -w #-} -- debugging module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), - tcStmts, tcDoStmts, tcBody, - tcDoStmt, tcMDoStmt, tcGuardStmt + TcMatchCtxt(..), TcStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt ) where -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId, +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) import HsSyn +import BasicTypes import TcRnMonad import TcEnv import TcPat @@ -28,13 +30,15 @@ import TysWiredIn import Id import TyCon import TysPrim -import Coercion ( mkSymCoI ) +import Coercion ( isIdentityCoI, mkSymCoI ) import Outputable -import BasicTypes ( Arity ) import Util import SrcLoc import FastString +-- Create chunkified tuple tybes for monad comprehensions +import MkCore + import Control.Monad #include "HsVersions.h" @@ -221,7 +225,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId) tcGRHS ctxt res_ty (GRHS guards rhs) - = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $ + = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs ; return (GRHS guards' rhs') } where @@ -238,36 +242,33 @@ tcGRHS ctxt res_ty (GRHS guards rhs) \begin{code} tcDoStmts :: HsStmtContext Name -> [LStmt Name] - -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo -tcDoStmts ListComp stmts body res_ty +tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCoI coi - (HsDo ListComp stmts' body' (mkListTy elt_ty)) } + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty + ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) } -tcDoStmts PArrComp stmts body res_ty +tcDoStmts PArrComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCoI coi - (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } + ; let parr_ty = mkPArrTy elt_ty + ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty + ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) } + +tcDoStmts DoExpr stmts res_ty + = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; return (HsDo DoExpr stmts' res_ty) } -tcDoStmts DoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $ - tcBody body - ; return (HsDo DoExpr stmts' body' res_ty) } +tcDoStmts MDoExpr stmts res_ty + = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; return (HsDo MDoExpr stmts' res_ty) } -tcDoStmts MDoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $ - tcBody body - ; return (HsDo MDoExpr stmts' body' res_ty) } +tcDoStmts MonadComp stmts res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; return (HsDo MonadComp stmts' res_ty) } -tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcBody body res_ty @@ -296,40 +297,52 @@ tcStmts :: HsStmtContext Name -> TcStmtChecker -- NB: higher-rank type -> [LStmt Name] -> TcRhoType - -> (TcRhoType -> TcM thing) - -> TcM ([LStmt TcId], thing) + -> TcM [LStmt TcId] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: HsStmtContext Name + -> TcStmtChecker -- NB: higher-rank type + -> [LStmt Name] + -> TcRhoType + -> (TcRhoType -> TcM thing) + -> TcM ([LStmt TcId], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts -tcStmts _ _ [] res_ty thing_inside +tcStmtsAndThen _ _ [] res_ty thing_inside = do { thing <- thing_inside res_ty ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmts ctxt stmt_chk stmts res_ty thing_inside + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside ; return (L loc (LetStmt binds') : stmts', thing) } -- For the vanilla case, handle the location-setting part -tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmts ctxt stmt_chk stmts res_ty' $ + setSrcSpan loc $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ thing_inside ; return (L loc stmt' : stmts', thing) } --------------------------------- --- Pattern guards +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + tcGuardStmt :: TcStmtChecker -tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside +tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard boolTy ; thing <- thing_inside res_ty - ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) } + ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already @@ -341,25 +354,292 @@ tcGuardStmt _ stmt _ _ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) --------------------------------- --- List comprehensions and PArrays +--------------------------------------------------- +-- List comprehensions and PArrays +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill +-- b) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcStmtChecker +tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside + = do { body' <- tcMonoExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + -- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside res_ty + thing_inside elt_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard -tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside +tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside = do { rhs' <- tcMonoExpr rhs boolTy - ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) } + ; thing <- thing_inside elt_ty + ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + +-- ParStmt: See notes with tcMcStmt +tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside + = do { (pairs', thing) <- loop bndr_stmts_s + ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) } + where + -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) + loop [] = do { thing <- thing_inside elt_ty + ; return ([], thing) } -- matching in the branches + + loop ((stmts, names) : pairs) + = do { (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + do { ids <- tcLookupLocalIds names + ; (pairs', thing) <- loop pairs + ; return (ids, pairs', thing) } + ; return ( (stmts', ids) : pairs', thing ) } + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) } + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcStmtChecker + +tcMcStmt _ (LastStmt body return_op) res_ty thing_inside + = do { a_ty <- newFlexiTyVarTy liftedTypeKind + ; return_op' <- tcSyntaxOp MCompOrigin return_op + (a_ty `mkFunTy` res_ty) + ; body' <- tcMonoExprNC body a_ty + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt body' return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; pat_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op + (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- if isIrrefutableHsPat pat + then return noSyntaxExpr + else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty) + + ; rhs' <- tcMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside new_res_ty + + ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + test_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcMonoExpr rhs test_ty + ; guard_op' <- tcSyntaxOp MCompOrigin guard_op + (mkFunTy test_ty rhs_ty) + ; then_op' <- tcSyntaxOp MCompOrigin then_op + (mkFunTys [rhs_ty, new_res_ty] res_ty) + ; thing <- thing_inside new_res_ty + ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e ] +-- -> e :: t +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m1_ty <- newFlexiTyVarTy star_star_kind + ; m2_ty <- newFlexiTyVarTy star_star_kind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy star_star_kind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; return_op' <- tcSyntaxOp MCompOrigin return_op $ + (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty' + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty) + `mkFunTy` res_ty + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noSyntaxExpr + _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ + mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ + (alphaTy `mkFunTy` betaTy) + `mkFunTy` (n_app alphaTy) + `mkFunTy` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + --------------- Bulding the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_fmap = fmap_op', trS_form = form }, thing) } -- A parallel set of comprehensions -- [ (g x, h x) | ... ; let g v = ... @@ -381,106 +661,95 @@ tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside -- ensure that g,h and x,y don't duplicate, and simply grow the environment. -- So the binders of the first parallel group will be in scope in the second -- group. But that's fine; there's no shadowing to worry about. - -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs', thing) } - where - -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop ((stmts, names) : pairs) - = do { (stmts', (ids, pairs', thing)) - <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> - do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs - ; return (ids, pairs', thing) } - ; return ( (stmts', ids) : pairs', thing ) } - -tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do - (stmts', (binders', usingExpr', maybeByExpr', thing)) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do - let alphaListTy = mkTyConApp m_tc [alphaTy] - - (usingExpr', maybeByExpr') <- - case maybeByExpr of - Nothing -> do - -- We must validate that usingExpr :: forall a. [a] -> [a] - let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy) - usingExpr' <- tcPolyExpr usingExpr using_ty - return (usingExpr', Nothing) - Just byExpr -> do - -- We must infer a type such that e :: t and then check that - -- usingExpr :: forall a. (a -> t) -> [a] -> [a] - (byExpr', tTy) <- tcInferRhoNC byExpr - let using_ty = mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` tTy) - `mkFunTy` alphaListTy `mkFunTy` alphaListTy - usingExpr' <- tcPolyExpr usingExpr using_ty - return (usingExpr', Just byExpr') - - binders' <- tcLookupLocalIds binders - thing <- thing_inside elt_ty' - - return (binders', usingExpr', maybeByExpr', thing) - - return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing) - -tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside - = do { let (bndr_names, list_bndr_names) = unzip bindersMap - - ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do - (by', using_ty) <- - case by of - Nothing -> -- check that using :: forall a. [a] -> [[a]] - return (Nothing, mkForAllTy alphaTyVar $ - alphaListTy `mkFunTy` alphaListListTy) - - Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]] - -- where by :: t - do { (by_e', t_ty) <- tcInferRhoNC by_e - ; return (Just by_e', mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` t_ty) - `mkFunTy` alphaListTy - `mkFunTy` alphaListListTy) } - -- Find the Ids (and hence types) of all old binders - bndr_ids <- tcLookupLocalIds bndr_names - - return (bndr_ids, by', using_ty, elt_ty') - - -- Ensure that every old binder of type b is linked up with - -- its new binder which should have type [b] - ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` list_bndr_ids - -- See Note [GroupStmt binder map] in HsExpr - - ; using' <- case using of - Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') } - Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) } - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty') - ; return (GroupStmt stmts' bindersMap' by' using', thing) } - where - alphaListTy = mkTyConApp m_tc [alphaTy] - alphaListListTy = mkTyConApp m_tc [alphaListTy] - - mk_list_bndr :: Name -> TcId -> TcId - mk_list_bndr list_bndr_name bndr_id - = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id]) - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - --------------------------------- --- Do-notation --- The main excitement here is dealing with rebindable syntax +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m_ty <- newFlexiTyVarTy star_star_kind + + ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkFunTy` + (m_ty `mkAppTy` betaTy) + `mkFunTy` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty + + ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ + mkForAllTy alphaTyVar $ + alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) + + ; (pairs', thing) <- loop m_ty bndr_stmts_s + + -- Typecheck bind: + ; let tys = map (mkBigCoreVarTupTy . snd) pairs' + tuple_ty = mk_tuple_ty tys + + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + (m_ty `mkAppTy` tuple_ty) + `mkFunTy` (tuple_ty `mkFunTy` res_ty) + `mkFunTy` res_ty + + ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + -- loop :: Type -- m_ty + -- -> [([LStmt Name], [Name])] + -- -> TcM ([([LStmt TcId], [TcId])], thing) + loop _ [] = do { thing <- thing_inside res_ty + ; return ([], thing) } -- matching in the branches + + loop m_ty ((stmts, names) : pairs) + = do { -- type dummy since we don't know all binder types yet + ty_dummy <- newFlexiTyVarTy liftedTypeKind + ; (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> + do { ids <- tcLookupLocalIds names + ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids + + ; check_same m_tup_ty res_ty' + ; check_same m_tup_ty ty_dummy + + ; (pairs', thing) <- loop m_ty pairs + ; return (ids, pairs', thing) } + ; return ( (stmts', ids) : pairs', thing ) } + + -- Check that the types match up. + -- This is a grevious hack. They always *will* match + -- If (>>=) and (>>) are polymorpic in the return type, + -- but we don't have any good way to incorporate the coercion + -- so for now we just check that it's the identity + check_same actual expected + = do { coi <- unifyType actual expected + ; unless (isIdentityCoI coi) $ + failWithMisMatch [UnifyOrigin { uo_expected = expected + , uo_actual = actual }] } + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- tcDoStmt :: TcStmtChecker +tcDoStmt _ (LastStmt body _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside = do { -- Deal with rebindable syntax: -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty @@ -510,7 +779,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside +tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty -- See also Note [Treat rebindable syntax first] @@ -521,7 +790,7 @@ tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside ; rhs' <- tcMonoExprNC rhs rhs_ty ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' rhs_ty, thing) } + ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op @@ -535,7 +804,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; tcExtendIdEnv tup_ids $ do { stmts_ty <- newFlexiTyVarTy liftedTypeKind ; (stmts', (ret_op', tup_rets)) - <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> + <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids @@ -551,7 +820,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) ; thing <- thing_inside new_res_ty --- ; lie_binds <- bindLocalMethods lie tup_ids ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -560,7 +828,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_rec_rets = tup_rets }, thing) + , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing) }} tcDoStmt _ stmt _ _ @@ -577,51 +845,6 @@ rebindable syntax first, and push that information into (tcMonoExprNC rhs). Otherwise the error shows up when cheking the rebindable syntax, and the expected/inferred stuff is back to front (see Trac #3613). -\begin{code} --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference - -> TcStmtChecker -tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_rhs rhs - ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) } - -tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames - , recS_rec_ids = recNames }) res_ty thing_inside - = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind - ; let rec_ids = zipWith mkLocalId recNames rec_tys - ; tcExtendIdEnv rec_ids $ do - { (stmts', (later_ids, rec_rets)) - <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - do { rec_rets <- zipWithM tcCheckId recNames rec_tys - ; later_ids <- tcLookupLocalIds laterNames - ; return (later_ids, rec_rets) } - - ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) - - ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing) - }} - -tcMDoStmt _ _ stmt _ _ - = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt) -\end{code} - %************************************************************************ %* * diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index d28e901..39594f0 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,6 @@ import PrelNames import BasicTypes hiding (SuccessFlag(..)) import DynFlags import SrcLoc -import ErrUtils import Util import Outputable import FastString @@ -348,9 +347,9 @@ tc_lpat :: LPat Name -> TcM a -> TcM (LPat TcId, a) tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - maybeAddErrCtxt (patCtxt pat) $ - do { (pat', res) <- tc_pat penv pat pat_ty thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + thing_inside ; return (L span pat', res) } tc_lpats :: PatEnv @@ -774,7 +773,6 @@ matchExpectedConTy data_tc pat_ty -- coi : T tys ~ pat_ty \end{code} -Noate [ Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -1006,12 +1004,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env -} \begin{code} -patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context -patCtxt (VarPat _) = Nothing -patCtxt (ParPat _) = Nothing -patCtxt (AsPat _ _) = Nothing -patCtxt pat = Just (hang (ptext (sLit "In the pattern:")) - 2 (ppr pat)) +maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) ----------------------------------------------- checkExistentials :: [TyVar] -> PatEnv -> TcM () diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 23c2e67..7b1d5a6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1205,7 +1205,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -------------------- mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt +mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq the_bind = L loc $ mkFunBind (L loc fresh_it) matches @@ -1214,7 +1214,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: -- [it <- e; print it] but not if it::() @@ -1242,7 +1242,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt mkPlan stmt@(L loc (BindStmt {})) | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType ; print_bind_result <- doptM Opt_PrintBindResult ; let print_plan = do @@ -1269,11 +1269,25 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; - + tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope - -- mk_return builds the expression + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; + let { -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] -- -- Despite the inconvenience of building the type applications etc, @@ -1284,27 +1298,14 @@ tcGhciStmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index f105e62..bd48872 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -781,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 3367f06..e511532 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -639,7 +639,7 @@ plusImportAvails (ImportAvails { imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_orphs = orphs1 `unionLists` orphs2, @@ -1038,9 +1038,6 @@ data SkolemInfo -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. - | RuntimeUnkSkol -- a type variable used to represent an unknown - -- runtime type (used in the GHCi debugger) - | BracketSkol -- Template Haskell bracket | UnkSkol -- Unhelpful info (until I improve it) @@ -1075,8 +1072,7 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") -pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol") +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") \end{code} @@ -1116,6 +1112,7 @@ data CtOrigin | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression + | MCompOrigin -- Arising from a monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation @@ -1151,6 +1148,7 @@ pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declarat pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") +pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") pprO ProcOrigin = ptext (sLit "a proc expression") pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq pprO AnnOrigin = ptext (sLit "an annotation") diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 87cd5eb..63b3bb8 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -101,10 +101,13 @@ import FastString import HsBinds -- for TcEvBinds stuff import Id - import TcRnTypes - import Data.IORef + +#ifdef DEBUG +import StaticFlags( opt_PprStyle_Debug ) +import Control.Monad( when ) +#endif \end{code} @@ -421,17 +424,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet) \begin{code} data SimplContext - = SimplInfer -- Inferring type of a let-bound thing - | SimplRuleLhs -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck -- Checking a type signature or RULE rhs - deriving Eq + = SimplInfer SDoc -- Inferring type of a let-bound thing + | SimplRuleLhs RuleName -- Inferring type of a RULE lhs + | SimplInteractive -- Inferring type at GHCi prompt + | SimplCheck SDoc -- Checking a type signature or RULE rhs instance Outputable SimplContext where - ppr SimplInfer = ptext (sLit "SimplInfer") - ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs") + ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d + ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d + ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) ppr SimplInteractive = ptext (sLit "SimplInteractive") - ppr SimplCheck = ptext (sLit "SimplCheck") isInteractive :: SimplContext -> Bool isInteractive SimplInteractive = True @@ -441,14 +443,14 @@ simplEqsOnly :: SimplContext -> Bool -- Simplify equalities only, not dictionaries -- This is used for the LHS of rules; ee -- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly SimplRuleLhs = True -simplEqsOnly _ = False +simplEqsOnly (SimplRuleLhs {}) = True +simplEqsOnly _ = False performDefaulting :: SimplContext -> Bool -performDefaulting SimplInfer = False -performDefaulting SimplRuleLhs = False -performDefaulting SimplInteractive = True -performDefaulting SimplCheck = True +performDefaulting (SimplInfer {}) = False +performDefaulting (SimplRuleLhs {}) = False +performDefaulting SimplInteractive = True +performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -526,7 +528,9 @@ runTcS context untouch tcs #ifdef DEBUG ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") + <+> int count <+> ppr context) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -563,8 +567,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic SimplRuleLhs = SimplCheck -ctxtUnderImplic ctxt = ctxt +ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") + <+> doubleQuotes (ftext n)) +ctxtUnderImplic ctxt = ctxt tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index eecfb27..cf41372 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -49,7 +49,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead simplifyTop wanteds - = simplifyCheck SimplCheck wanteds + = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds ------------------ simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) @@ -61,7 +61,8 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta = do { wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted) + ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) + (mkFlatWC wanted) ; return () } \end{code} @@ -75,13 +76,14 @@ simplifyDefault theta \begin{code} simplifyDeriv :: CtOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed + -> PredType + -> [TyVar] + -> ThetaType -- Wanted + -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possibles -- Fail if not possible -simplifyDeriv orig tvs theta +simplifyDeriv orig pred tvs theta = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. @@ -90,12 +92,13 @@ simplifyDeriv orig tvs theta ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _binds) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer doc) NoUntouchables $ solveWanteds emptyInert (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) @@ -247,7 +250,7 @@ simplifyInfer top_lvl apply_mr name_taus wanteds -- Step 2 -- Now simplify the possibly-bound constraints ; (simpl_results, tc_binds0) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $ simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint @@ -547,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- runTcS SimplRuleLhs untch $ + <- runTcS (SimplRuleLhs name) untch $ solveWanteds emptyInert zonked_lhs ; traceTc "simplifyRule" $ @@ -589,7 +592,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- Hence the rather painful ad-hoc treatement here ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds - ; rhs_binds1 <- simplifyCheck SimplCheck $ + ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name) + ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $ WC { wc_flat = emptyBag , wc_insol = emptyBag , wc_impl = unitBag $ diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index eab0732..d9166d1 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -306,14 +306,12 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | SigTv Name -- A variant of TauTv, except that it should not be + | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages -- see Note [Signature skolems] -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - -- The Name is the name of the function from whose - -- type signature we got this skolem | TcsTv -- A MetaTv allocated by the constraint solver -- Its particular property is that it is always "touchable" @@ -392,12 +390,12 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") -pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") +pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") +pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") +pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) @@ -552,8 +550,8 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> False - _ -> True + MetaTv SigTv _ -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -583,8 +581,8 @@ isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> True - _ -> False + MetaTv SigTv _ -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 4fc50b3..e229b8b 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -20,7 +20,7 @@ module TcUnify ( matchExpectedListTy, matchExpectedPArrTy, matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys, matchExpectedFunKind, - wrapFunResCoercion + wrapFunResCoercion, failWithMisMatch ) where #include "HsVersions.h" @@ -899,8 +899,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2 ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 - nicer_to_update_tv1 _ (SigTv _) = True - nicer_to_update_tv1 (SigTv _) _ = False + nicer_to_update_tv1 _ SigTv = True + nicer_to_update_tv1 SigTv _ = False nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 8551409..7fdf4ae 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -485,9 +485,7 @@ pprKind = pprType pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc -ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv +ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys @@ -570,14 +568,19 @@ ppr_tc tc else ptext (sLit "")) | otherwise = empty +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) +pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code} diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index 097a112..700878a 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -41,6 +41,7 @@ data Bag a | UnitBag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty | ListBag [a] -- INVARIANT: the list is non-empty + deriving Typeable emptyBag :: Bag a emptyBag = EmptyBag @@ -262,8 +263,6 @@ bagToList b = foldrBag (:) [] b instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) -INSTANCE_TYPEABLE1(Bag,bagTc,"Bag") - instance Data a => Data (Bag a) where gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 388b968..1fa4199 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -61,14 +61,14 @@ addNode k node graph -- add back conflict edges from other nodes to this one map_conflict = foldUniqSet - (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) (graphMap graph) (nodeConflicts node) -- add back coalesce edges from other nodes to this one map_coalesce = foldUniqSet - (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) map_conflict (nodeCoalesce node) @@ -434,7 +434,7 @@ freezeNode k else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1 + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 $ nodeCoalesce node in fm2 @@ -604,7 +604,7 @@ setColor setColor u color = graphMapModify - $ adjustUFM + $ adjustUFM_C (\n -> n { nodeColor = Just color }) u @@ -621,13 +621,14 @@ adjustWithDefaultUFM f def k map map k def -{-# INLINE adjustUFM #-} -adjustUFM +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C :: Uniquable k => (a -> a) -> k -> UniqFM a -> UniqFM a -adjustUFM f k map +adjustUFM_C f k map = case lookupUFM map k of Nothing -> map Just a -> addToUFM map k (f a) diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index a2779a2..fc4d919 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -64,7 +64,7 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, - pprTrace, warnPprTrace, + pprTrace, pprDefiniteTrace, warnPprTrace, trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where @@ -883,6 +883,9 @@ pprTrace str doc x | opt_NoDebugOutput = x | otherwise = pprAndThen trace str doc x +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +pprDefiniteTrace str doc x = pprAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' diff --git a/compiler/nativeGen/Platform.hs b/compiler/utils/Platform.hs similarity index 95% rename from compiler/nativeGen/Platform.hs rename to compiler/utils/Platform.hs index 20cb5f5..7b2502d 100644 --- a/compiler/nativeGen/Platform.hs +++ b/compiler/utils/Platform.hs @@ -31,8 +31,7 @@ data Platform -- about what instruction set extensions an architecture might support. -- data Arch - = ArchAlpha - | ArchX86 + = ArchX86 | ArchX86_64 | ArchPPC | ArchPPC_64 @@ -70,9 +69,7 @@ defaultTargetPlatform -- | Move the evil TARGET_ARCH #ifdefs into Haskell land. defaultTargetArch :: Arch -#if alpha_TARGET_ARCH -defaultTargetArch = ArchAlpha -#elif i386_TARGET_ARCH +#if i386_TARGET_ARCH defaultTargetArch = ArchX86 #elif x86_64_TARGET_ARCH defaultTargetArch = ArchX86_64 diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 293e48e..7302b02 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -36,6 +36,8 @@ module UniqFM ( addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, + adjustUFM, + adjustUFM_Directly, delFromUFM, delFromUFM_Directly, delListFromUFM, @@ -45,7 +47,7 @@ module UniqFM ( intersectUFM, intersectUFM_C, foldUFM, foldUFM_Directly, - mapUFM, + mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, sizeUFM, @@ -53,12 +55,15 @@ module UniqFM ( lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, splitUFM, - ufmToList + ufmToList, + joinUFM ) where import Unique ( Uniquable(..), Unique, getKey ) import Outputable +import Compiler.Hoopl hiding (Unique) + import qualified Data.IntMap as M \end{code} @@ -103,6 +108,9 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt + delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt @@ -122,6 +130,7 @@ intersectUFM_C :: (elt1 -> elt2 -> elt3) foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt @@ -174,6 +183,9 @@ addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) delListFromUFM = foldl delFromUFM delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) @@ -188,6 +200,7 @@ intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) foldUFM k z (UFM m) = M.fold k z m foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m mapUFM f (UFM m) = UFM (M.map f m) +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) @@ -205,6 +218,16 @@ keysUFM (UFM m) = map getUnique $ M.keys m eltsUFM (UFM m) = M.elems m ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +-- Hoopl +joinUFM :: JoinFun v -> JoinFun (UniqFM v) +joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new + where add k new_v (ch, joinmap) = + case lookupUFM_Directly joinmap k of + Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v') + (NoChange, _) -> (ch, joinmap) + \end{code} %************************************************************************ diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 6b17a28..dc4f32e 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -66,6 +66,9 @@ module Util ( -- * Floating point readRational, + -- * read helpers + maybeReadFuzzy, + -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, @@ -81,7 +84,10 @@ module Util ( Direction(..), reslash, -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC ) where #include "HsVersions.h" @@ -106,7 +112,7 @@ import System.Directory ( doesDirectoryExist, createDirectory, import System.FilePath import System.Time ( ClockTime ) -import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits @@ -963,6 +969,17 @@ readRational top_s ----------------------------------------------------------------------------- +-- read helpers + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] + | all isSpace s -> + Just x + _ -> + Nothing + +----------------------------------------------------------------------------- -- Create a hierarchy of directories createDirectoryHierarchy :: FilePath -> IO () @@ -1066,3 +1083,22 @@ abstractDataType :: String -> DataType abstractDataType n = mkDataType n [abstractConstr n] \end{code} +%************************************************************************ +%* * +\subsection[Utils-C]{Utils for printing C code} +%* * +%************************************************************************ + +\begin{code} +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] +\end{code} diff --git a/configure.ac b/configure.ac index a8d535f..2de4d8a 100644 --- a/configure.ac +++ b/configure.ac @@ -132,10 +132,15 @@ if test "$WithGhc" != ""; then GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi AC_SUBST(ghc_ge_613)dnl + + BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)']) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command],['$(AR)']) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags],['$(AR_OPTS)']) + BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file],['$(ArSupportsAtFile)']) fi dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on -if test "$BootingFromHc" = "NO" -a -d "$srcdir/compiler"; then +if test "$BootingFromHc" = "NO"; then if test "$WithGhc" = ""; then AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.]) fi @@ -222,7 +227,21 @@ x86_64-apple-darwin) ;; esac -# Sync this with cTargetArch in compiler/ghc.mk +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + +case $host in + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; +esac + checkArch() { case $1 in alpha|arm|hppa|hppa1_1|i386|ia64|m68k|mips|mipseb|mipsel|powerpc|powerpc64|rs6000|s390|sparc|sparc64|vax|x86_64) @@ -288,12 +307,15 @@ checkOS "$TargetOS" # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$BuildPlatform" != "$bootstrap_target" +if test "$BootingFromHc" = "NO" then - echo "This GHC (${WithGhc}) does not generate code for the build platform" - echo " GHC target platform : $bootstrap_target" - echo " Desired build platform : $BuildPlatform" - exit 1 + if test "$BuildPlatform" != "$bootstrap_target" + then + echo "This GHC (${WithGhc}) does not generate code for the build platform" + echo " GHC target platform : $bootstrap_target" + echo " Desired build platform : $BuildPlatform" + exit 1 + fi fi echo "GHC build : $BuildPlatform" @@ -322,6 +344,8 @@ AC_SUBST(TargetVendor_CPP) AC_SUBST(exeext) AC_SUBST(soext) +AC_SUBST(SOLARIS_BROKEN_SHLD) + AC_ARG_WITH(hc, [AC_HELP_STRING([--with-hc=ARG], [Use ARG as the path to the compiler for compiling ordinary @@ -520,7 +544,7 @@ dnl ** look for GCC and find out which version dnl Figure out which C compiler to use. Gcc is preferred. dnl If gcc, make sure it's at least 2.1 dnl -FP_HAVE_GCC +FP_GCC_VERSION FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) @@ -561,7 +585,6 @@ AC_DEFINE([HAVE_BIN_SH], [1], [Define to 1 if you have /bin/sh.]) dnl ** how to invoke `ar' and `ranlib' FP_PROG_AR_SUPPORTS_ATFILE FP_PROG_AR_NEEDS_RANLIB -FP_PROG_AR_SUPPORTS_INPUT dnl ** Check to see whether ln -s works AC_PROG_LN_S @@ -607,8 +630,6 @@ FP_CHECK_DOCBOOK_DTD FP_DOCBOOK_XSL FP_PROG_DBLATEX -FP_PROG_HSTAGS - dnl ** check for ghc-pkg command FP_PROG_GHC_PKG @@ -799,6 +820,7 @@ FP_LEADING_UNDERSCORE dnl ** check for ld, whether it has an -x option, and if it is GNU ld FP_PROG_LD_X FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID dnl ** check for Apple-style dead-stripping support dnl (.subsections-via-symbols assembler directive) @@ -913,7 +935,7 @@ if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then AC_MSG_ERROR([compiler/ghc.cabal.in contains tab characters; please remove them]) fi -AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec extra-gcc-opts docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac]) +AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac]) AC_CONFIG_COMMANDS([mk/stamp-h],[echo timestamp > mk/stamp-h]) AC_OUTPUT diff --git a/darcs-all b/darcs-all deleted file mode 100755 index 106eb8f..0000000 --- a/darcs-all +++ /dev/null @@ -1,437 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -# Usage: -# -# ./darcs-all [-q] [-s] [-i] [-r repo] -# [--nofib] [--testsuite] [--checked-out] cmd [darcs flags] -# -# Applies the darcs command "cmd" to each repository in the tree. -# -# e.g. -# ./darcs-all -r http://darcs.haskell.org/ghc get -# To get any repos which do not exist in the local tree -# -# ./darcs-all -r ~/ghc-validate push -# To push all your repos to the ~/ghc-validate tree -# -# ./darcs-all pull -a -# To pull everything from the default repos -# -# ./darc-all push --dry-run -# To see what local patches you have relative to the main repos -# -# -------------- Flags ------------------- -# -q says to be quite, and -s to be silent. -# -# -i says to ignore darcs errors and move on to the next repository -# -# -r repo says to use repo as the location of package repositories -# -# --checked-out says that the remote repo is in checked-out layout, as -# opposed to the layout used for the main repo. By default a repo on -# the local filesystem is assumed to be checked-out, and repos accessed -# via HTTP or SSH are assumed to be in the main repo layout; use -# --checked-out to override the latter. -# -# --nofib, --testsuite also get the nofib and testsuite repos respectively -# -# The darcs get flag you are most likely to want is --complete. By -# default we pass darcs the --partial flag. -# -# ------------ Which repos to use ------------- -# darcs-all uses the following algorithm to decide which remote repos to use -# -# It always computes the remote repos from a single base, $repo_base -# How is $repo_base set? -# If you say "-r repo", then that's $repo_base -# othewise $repo_base is set thus: -# look in _darcs/prefs/defaultrepo, -# and remove the trailing 'ghc' -# -# Then darcs-all iterates over the package found in the file -# ./packages, which has entries like: -# libraries/array packages/array darcs -# or, in general -# -# -# If $repo_base looks like a local filesystem path, or if you give -# the --checked-out flag, darcs-all works on repos of form -# $repo_base/ -# otherwise darcs-all works on repos of form -# $repo_base/ -# This logic lets you say -# both darcs-all -r http://darcs.haskell.org/ghc-6.12 pull -# and darcs-all -r ../HEAD pull -# The latter is called a "checked-out tree". - -# NB: darcs-all *ignores* the defaultrepo of all repos other than the -# root one. So the remote repos must be laid out in one of the two -# formats given by and in the file 'packages'. - - -$| = 1; # autoflush stdout after each print, to avoid output after die - -my $defaultrepo; - -my $verbose = 2; -my $ignore_failure = 0; -my $want_remote_repo = 0; -my $checked_out_flag = 0; - -my %tags; - -my @packages; - -# Figure out where to get the other repositories from. -sub getrepo { - my $basedir = "."; - my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`; - chomp $repo; - - my $repo_base; - my $checked_out_tree; - - if ($repo =~ /^...*:/) { - # HTTP or SSH - # Above regex says "at least two chars before the :", to avoid - # catching Win32 drives ("C:\"). - $repo_base = $repo; - - # --checked-out is needed if you want to use a checked-out repo - # over SSH or HTTP - if ($checked_out_flag) { - $checked_out_tree = 1; - } else { - $checked_out_tree = 0; - } - - # Don't drop the last part of the path if specified with -r, as - # it expects repos of the form: - # - # http://darcs.haskell.org - # - # rather than - # - # http://darcs.haskell.org/ghc - # - if (!$defaultrepo) { - $repo_base =~ s#/[^/]+/?$##; - } - } - elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute or relative path - # (assumes a checked-out tree): - $repo_base = $repo; - $checked_out_tree = 1; - } - else { - die "Couldn't work out repo"; - } - - return $repo_base, $checked_out_tree; -} - -sub message { - if ($verbose >= 2) { - print "@_\n"; - } -} - -sub warning { - if ($verbose >= 1) { - print "warning: @_\n"; - } -} - -sub darcs { - message "== running darcs @_"; - system ("darcs", @_) == 0 - or $ignore_failure - or die "darcs failed: $?"; -} - -sub parsePackages { - my @repos; - my $lineNum; - - my ($repo_base, $checked_out_tree) = getrepo(); - - open IN, "< packages" or die "Can't open packages file"; - @repos = ; - close IN; - - @packages = (); - $lineNum = 0; - foreach (@repos) { - chomp; - $lineNum++; - if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) { - my %line; - $line{"localpath"} = $1; - $line{"tag"} = $2; - $line{"remotepath"} = $3; - $line{"vcs"} = $4; - $line{"upstream"} = $5; - push @packages, \%line; - } - elsif (! /^(#.*)?$/) { - die "Bad content on line $lineNum of packages file: $_"; - } - } -} - -sub darcsall { - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $command = $_[0]; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if (-d "$localpath/_darcs") { - if ($want_remote_repo) { - if ($command =~ /^opt/) { - # Allows ./darcs-all optimize --relink - darcs (@_, "--repodir", $localpath, "--sibling=$path"); - } else { - darcs (@_, "--repodir", $localpath, $path); - } - } else { - darcs (@_, "--repodir", $localpath); - } - } - elsif ($tag eq "-") { - message "== Required repo $localpath is missing! Skipping"; - } - else { - message "== $localpath repo not present; skipping"; - } - } -} - -sub darcsget { - my $r_flags; - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - if (! grep /(?:--complete|--partial|--lazy)/, @_) { - warning("adding --partial, to override use --complete"); - $r_flags = [@_, "--partial"]; - } - else { - $r_flags = \@_; - } - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if ($tags{$tag} eq 1) { - if (-d $localpath) { - warning("$localpath already present; omitting"); - } - else { - darcs (@$r_flags, $path, $localpath); - } - } - } -} - -sub darcsupstreampull { - my $localpath; - my $upstream; - my $line; - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $upstream = $$line{"upstream"}; - - if ($upstream ne "-") { - if (-d $localpath) { - darcs ("pull", @_, "--repodir", $localpath, $upstream); - } - } - } -} - -sub main { - if (! -d "compiler") { - die "error: darcs-all must be run from the top level of the ghc tree." - } - - $tags{"-"} = 1; - $tags{"dph"} = 1; - $tags{"nofib"} = 0; - $tags{"testsuite"} = 0; - $tags{"extra"} = 0; - - while ($#_ ne -1) { - my $arg = shift; - # We handle -q here as well as lower down as we need to skip over it - # if it comes before the darcs command - if ($arg eq "-q") { - $verbose = 1; - } - elsif ($arg eq "-s") { - $verbose = 0; - } - elsif ($arg eq "-r") { - $defaultrepo = shift; - } - elsif ($arg eq "-i") { - $ignore_failure = 1; - } - # --nofib tells get to also grab the nofib repo. - # It has no effect on the other commands. - elsif ($arg eq "--nofib") { - $tags{"nofib"} = 1; - } - elsif ($arg eq "--no-nofib") { - $tags{"nofib"} = 0; - } - # --testsuite tells get to also grab the testsuite repo. - # It has no effect on the other commands. - elsif ($arg eq "--testsuite") { - $tags{"testsuite"} = 1; - } - elsif ($arg eq "--no-testsuite") { - $tags{"testsuite"} = 0; - } - # --dph tells get to also grab the dph repo. - # It has no effect on the other commands. - elsif ($arg eq "--dph") { - $tags{"dph"} = 1; - } - elsif ($arg eq "--no-dph") { - $tags{"dph"} = 0; - } - # --extralibs tells get to also grab the extra repos. - # It has no effect on the other commands. - elsif ($arg eq "--extra") { - $tags{"extra"} = 1; - } - elsif ($arg eq "--no-extra") { - $tags{"extra"} = 0; - } - # Use --checked-out if the remote repos are a checked-out tree, - # rather than the master trees. - elsif ($arg eq "--checked-out") { - $checked_out_flag = 1; - } - else { - unshift @_, $arg; - if (grep /^-q$/, @_) { - $verbose = 1; - } - last; - } - } - - if ($#_ eq -1) { - die "What do you want to do?"; - } - my $command = $_[0]; - parsePackages; - if ($command eq "get") { - darcsget @_; - } - elsif ($command eq "upstreampull") { - shift; - darcsupstreampull @_; - } - else { - if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) { - # Hack around whatsnew failing if there are no changes - $ignore_failure = 1; - } - if ($command =~ /^(pul|pus|sen|put|opt)/) { - $want_remote_repo = 1; - } - darcsall @_; - } -} - -END { - my $ec = $?; - - message "== Checking for old bytestring repo"; - if (-d "libraries/bytestring/_darcs") { - if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) { - print < /dev/null 2> /dev/null") == 0) { - print < + + + + + Formatting dumps + + formatting dumps + + + + + + + + + In error messages, expressions are printed to a + certain “depth”, with subexpressions beyond the + depth replaced by ellipses. This flag sets the + depth. Its default value is 5. + + + + + + + + + + Set the width of debugging output. Use this if your code is wrapping too much. + For example: . + + + + + + + + + + Print single alternative case expressions as though they were strict + let expressions. This is helpful when your code does a lot of unboxing. + + + + + + + + + + Suppress any unsolicited debugging output. When GHC + has been built with the DEBUG option it + occasionally emits debug output of interest to developers. + The extra output can confuse the testing framework and + cause bogus test failures, so this flag is provided to + turn it off. + + + + + + + + Suppressing unwanted information + + suppression + + Core dumps contain a large amount of information. Depending on what you are doing, not all of it will be useful. + Use these flags to suppress the parts that you are not interested in. + + + + + + + + + Suppress everything that can be suppressed, except for unique ids as this often + makes the printout ambiguous. If you just want to see the overall structure of + the code, then start here. + + @@ -483,7 +565,7 @@ - Suppress the printing of uniques in debugging output. This may make + Suppress the printing of uniques. This may make the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but it makes the output of two compiler runs have many fewer gratuitous differences, so you can realistically apply diff. Once diff @@ -493,12 +575,13 @@ - - + + - Suppress the printing of coercions in Core dumps to make them -shorter. + Suppress extended information about identifiers where they are bound. This includes + strictness information and inliner templates. Using this flag can cut the size + of the core dump in half, due to the lack of inliner templates @@ -508,36 +591,39 @@ shorter. - Suppress the printing of module qualification prefixes in Core dumps to make them easier to read. + Suppress the printing of module qualification prefixes. + This is the Data.List in Data.List.length. - - + + - In error messages, expressions are printed to a - certain “depth”, with subexpressions beyond the - depth replaced by ellipses. This flag sets the - depth. Its default value is 5. + Suppress the printing of type signatures. - - - + + + - - Suppress any unsolicited debugging output. When GHC - has been built with the DEBUG option it - occasionally emits debug output of interest to developers. - The extra output can confuse the testing framework and - cause bogus test failures, so this flag is provided to - turn it off. - + + Suppress the printing of type applications. + + + + + + + + + + Suppress the printing of type coercions. + diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 47c0f01..97a2378 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -245,18 +245,11 @@ extern HsInt foo(HsInt a0); #include "foo_stub.h" #endif -#ifdef __GLASGOW_HASKELL__ -extern void __stginit_Foo ( void ); -#endif - int main(int argc, char *argv[]) { int i; hs_init(&argc, &argv); -#ifdef __GLASGOW_HASKELL__ - hs_add_root(__stginit_Foo); -#endif for (i = 0; i < 5; i++) { printf("%d\n", foo(2500)); @@ -283,26 +276,6 @@ int main(int argc, char *argv[]) (i.e. those arguments between +RTS...-RTS). - Next, we call - hs_add_rooths_add_root - , a GHC-specific interface which is required to - initialise the Haskell modules in the program. The argument - to hs_add_root should be the name of the - initialization function for the "root" module in your program - - in other words, the module which directly or indirectly - imports all the other Haskell modules in the program. In a - standalone Haskell program the root module is normally - Main, but when you are using Haskell code - from a library it may not be. If your program has multiple - root modules, then you can call - hs_add_root multiple times, one for each - root. The name of the initialization function for module - M is - __stginit_M, and - it may be declared as an external function symbol as in the - code above. Note that the symbol name should be transformed - according to the Z-encoding: - @@ -380,9 +353,6 @@ int main(int argc, char *argv[]) // Initialize Haskell runtime hs_init(&argc, &argv); - // Tell Haskell about all root modules - hs_add_root(__stginit_Foo); - // do any other initialization here and // return false if there was a problem return HS_BOOL_TRUE; @@ -394,7 +364,7 @@ int main(int argc, char *argv[]) The initialisation routine, mylib_init, calls - hs_init() and hs_add_root() as + hs_init() as normal to initialise the Haskell runtime, and the corresponding deinitialisation function mylib_end() calls hs_exit() to shut down the runtime. @@ -599,8 +569,7 @@ int main(int argc, char *argv[]) invoke foreign exported functions from multiple OS threads concurrently. The runtime system must be initialised as usual by - calling hs_init() - and hs_add_root, and these calls must + calling hs_init(), and this call must complete before invoking any foreign exported functions. diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index ad219cf..4a502b4 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -325,13 +325,6 @@ - - or - - retain intermediate .raw_s files - dynamic - - - - retain all intermediate temporary files dynamic @@ -567,7 +560,7 @@ P Compile to be part of package P - dynamic + static - @@ -905,6 +898,12 @@ dynamic + + + Enable monad comprehensions. + dynamic + + Enable unlifted FFI types. @@ -1187,6 +1186,13 @@ + + warn about polymorphic local bindings without signatures + dynamic + + + + warn when names are shadowed dynamic @@ -1999,12 +2005,6 @@ phase n - cmd - Use cmd as the mangler - dynamic - - - - cmd Use cmd as the splitter dynamic @@ -2474,32 +2474,68 @@ phase n - + + Don't output pragma info in dumps + static + - + + + + Set the depth for printing expressions in error msgs + static + - + + + + Set the width of debugging output. For example + static + - + + + + Print single alternative case expressions as strict lets. + static + - + + + + In core dumps, suppress everything that is suppressable. + static + - + + - Suppress the printing of uniques in debug output (easier to use diff. + Suppress the printing of uniques in debug output (easier to use diff) static - - - Suppress the printing of coercions in Core dumps to make them shorter. + + Suppress extended information about identifiers where they are bound static - - Suppress the printing of module qualification prefixes in Core dumps to make them easier to read. + Suppress the printing of module qualification prefixes static - - - Don't output pragma info in dumps + + Suppress type signatures static - - - Set the depth for printing expressions in error msgs + + Suppress type applications + static + - + + + + Suppress the printing of coercions in Core dumps to make them shorter static - @@ -2595,12 +2631,6 @@ phase n - - - Turn off assembly mangling (use instead) - dynamic - - - - Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread. dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index a5fba51..89198c4 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1201,6 +1201,234 @@ output = [ x + + + + Monad comprehensions + monad comprehensions + + + Monad comprehesions generalise the list comprehension notation, + including parallel comprehensions + () and + transform comprenensions () + to work for any monad. + + + Monad comprehensions support: + + + + + Bindings: + + + +[ x + y | x <- Just 1, y <- Just 2 ] + + + + Bindings are translated with the (>>=) and + return functions to the usual do-notation: + + + +do x <- Just 1 + y <- Just 2 + return (x+y) + + + + + + Guards: + + + +[ x | x <- [1..10], x <= 5 ] + + + + Guards are translated with the guard function, + which requires a MonadPlus instance: + + + +do x <- [1..10] + guard (x <= 5) + return x + + + + + + Transform statements (as with -XTransformListComp): + + + +[ x+y | x <- [1..10], y <- [1..x], then take 2 ] + + + + This translates to: + + + +do (x,y) <- take 2 (do x <- [1..10] + y <- [1..x] + return (x,y)) + return (x+y) + + + + + + Group statements (as with -XTransformListComp): + + + +[ x | x <- [1,1,2,2,3], then group by x ] +[ x | x <- [1,1,2,2,3], then group by x using GHC.Exts.groupWith ] +[ x | x <- [1,1,2,2,3], then group using myGroup ] + + + + The basic then group by e statement is + translated using the mgroupWith function, which + requires a MonadGroup instance, defined in + Control.Monad.Group: + + + +do x <- mgroupWith (do x <- [1,1,2,2,3] + return x) + return x + + + + Note that the type of x is changed by the + grouping statement. + + + + The grouping function can also be defined with the + using keyword. + + + + + + Parallel statements (as with -XParallelListComp): + + + +[ (x+y) | x <- [1..10] + | y <- [11..20] + ] + + + + Parallel statements are translated using the + mzip function, which requires a + MonadZip instance defined in + Control.Monad.Zip: + + + +do (x,y) <- mzip (do x <- [1..10] + return x) + (do y <- [11..20] + return y) + return (x+y) + + + + + + + All these features are enabled by default if the + MonadComprehensions extension is enabled. The types + and more detailed examples on how to use comprehensions are explained + in the previous chapters and . In general you just have + to replace the type [a] with the type + Monad m => m a for monad comprehensions. + + + + Note: Even though most of these examples are using the list monad, + monad comprehensions work for any monad. + The base package offers all necessary instances for + lists, which make MonadComprehensions backward + compatible to built-in, transform and parallel list comprehensions. + + More formally, the desugaring is as follows. We write D[ e | Q] +to mean the desugaring of the monad comprehension [ e | Q]: + +Expressions: e +Declarations: d +Lists of qualifiers: Q,R,S + +-- Basic forms +D[ e | ] = return e +D[ e | p <- e, Q ] = e >>= \p -> D[ e | Q ] +D[ e | e, Q ] = guard e >> \p -> D[ e | Q ] +D[ e | let d, Q ] = let d in D[ e | Q ] + +-- Parallel comprehensions (iterate for multiple parallel branches) +D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D[ e | S ] + +-- Transform comprehensions +D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +where Qv is the tuple of variables bound by Q (and used subsequently) + selQvi is a selector mapping Qv to the ith component of Qv + +Operator Standard binding Expected type +-------------------------------------------------------------------- +return GHC.Base t1 -> m t2 +(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3 +(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3 +guard Control.Monad t1 -> m t2 +fmap GHC.Base forall a b. (a->b) -> n a -> n b +mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a) +mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b) + +The comprehension should typecheck when its desugaring would typecheck. + + +Monad comprehensions support rebindable syntax (). +Without rebindable +syntax, the operators from the "standard binding" module are used; with +rebindable syntax, the operators are looked up in the current lexical scope. +For example, parallel comprehensions will be typechecked and desugared +using whatever "mzip" is in scope. + + +The rebindable operators must have the "Expected type" given in the +table above. These types are surprisingly general. For example, you can +use a bind operator with the type + +(>>=) :: T x y a -> (a -> T y z b) -> T x z b + +In the case of transform comprehensions, notice that the groups are +parameterised over some arbitrary type n (provided it +has an fmap, as well as +the comprehension being over an arbitrary monad. + + + @@ -5884,7 +6112,7 @@ type variables, in the annotated expression. For example: f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool ) -Here, the type signature forall a. ST s Bool brings the +Here, the type signature forall s. ST s Bool brings the type variable s into scope, in the annotated expression (op >>= \(x :: STRef s Int) -> g x). diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 5915046..86df594 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -279,7 +279,6 @@ exposed-modules: Network.BSD, /usr/bin/ld: Undefined symbols: _ZCMain_main_closure -___stginit_ZCMain diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index 6ed8de1..dfa10a5 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -71,17 +71,6 @@ - cmd - - - - Use cmd as the - mangler. - - - - - cmd diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index ae0e80c..099a91f 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -496,22 +496,6 @@ $ ghc -c parse/Foo.hs parse/Bar.hs gurgle/Bumble.hs -odir `uname -m` - , - - - - - - Keep intermediate .raw-s files. - These are the direct output from the C compiler, before - GHC does “assembly mangling” to produce the - .s file. Again, these are not produced - when using the native code generator. - - - - - temporary fileskeeping diff --git a/docs/users_guide/shared_libs.xml b/docs/users_guide/shared_libs.xml index def773c..89b656a 100644 --- a/docs/users_guide/shared_libs.xml +++ b/docs/users_guide/shared_libs.xml @@ -16,7 +16,7 @@ shared between several programs. In contrast, with static linking the code is copied into each program. Using shared libraries can thus save disk space. They also allow a single copy of code to be shared in memory - between several programs that use it. Shared libraires are often used as + between several programs that use it. Shared libraries are often used as a way of structuring large projects, especially where different parts are written in different programming languages. Shared libraries are also commonly used as a plugin mechanism by various applications. This is diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 05f1de4..115c290 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1373,6 +1373,20 @@ module M where + : + + + type signatures, missing + + If you use the + flag GHC will warn + you about any polymorphic local bindings. As part of + the warning GHC also reports the inferred type. The + option is off by default. + + + + : @@ -2203,27 +2217,6 @@ f "2" = 2 - - : - - (x86 only)-monly-N-regs - option (iX86 only) GHC tries to - “steal” four registers from GCC, for performance - reasons; it almost always works. However, when GCC is - compiling some modules with four stolen registers, it will - crash, probably saying: - - -Foo.hc:533: fixed or forbidden register was spilled. -This may be due to a compiler bug or to impossible asm -statements or clauses. - - - Just give some registers back with - . Try `3' first, then `2'. - If `2' doesn't work, please report the bug to us. - - diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml index bf243a2..f00e1e2 100644 --- a/docs/users_guide/win32-dlls.xml +++ b/docs/users_guide/win32-dlls.xml @@ -429,8 +429,6 @@ foreign export stdcall adder :: Int -> Int -> IO Int // StartEnd.c #include <Rts.h> -extern void __stginit_Adder(void); - void HsStart() { int argc = 1; @@ -439,9 +437,6 @@ void HsStart() // Initialize Haskell runtime char** args = argv; hs_init(&argc, &args); - - // Tell Haskell about all root modules - hs_add_root(__stginit_Adder); } void HsEnd() diff --git a/driver/mangler/Makefile b/driver/mangler/Makefile deleted file mode 100644 index 58a1761..0000000 --- a/driver/mangler/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture -# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -dir = driver/mangler -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk diff --git a/driver/mangler/ghc-asm.lprl b/driver/mangler/ghc-asm.lprl deleted file mode 100644 index 4bac756..0000000 --- a/driver/mangler/ghc-asm.lprl +++ /dev/null @@ -1,2061 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -Any other required tidying up. -\end{itemize} - -General note [chak]: Many regexps are very fragile because they rely on white -space being in the right place. This caused trouble with gcc 2.95 (at least -on Linux), where the use of white space in .s files generated by gcc suddenly -changed. To guarantee compatibility across different versions of gcc, make -sure (at least on i386-.*-linux) that regexps tolerate varying amounts of white -space between an assembler statement and its arguments as well as after a the -comma separating multiple arguments. - -\emph{For the time being, I have corrected the regexps for i386-.*-linux. I -didn't touch all the regexps for other i386 platforms, as I don't have -a box to test these changes.} - -HPPA specific notes: -\begin{itemize} -\item -The HP linker is very picky about symbols being in the appropriate -space (code vs. data). When we mangle the threaded code to put the -info tables just prior to the code, they wind up in code space -rather than data space. This means that references to *_info from -un-mangled parts of the RTS (e.g. unthreaded GC code) get -unresolved symbols. Solution: mini-mangler for .c files on HP. I -think this should really be triggered in the driver by a new -rts -option, so that user code doesn't get mangled inappropriately. -\item -With reversed tables, jumps are to the _info label rather than to -the _entry label. The _info label is just an address in code -space, rather than an entry point with the descriptive blob we -talked about yesterday. As a result, you can't use the call-style -JMP_ macro. However, some JMP_ macros take _info labels as targets -and some take code entry points within the RTS. The latter won't -work with the goto-style JMP_ macro. Sigh. Solution: Use the goto -style JMP_ macro, and mangle some more assembly, changing all -"RP'literal" and "LP'literal" references to "R'literal" and -"L'literal," so that you get the real address of the code, rather -than the descriptive blob. Also change all ".word P%literal" -entries in info tables and vector tables to just ".word literal," -for the same reason. Advantage: No more ridiculous call sequences. -\end{itemize} - -%************************************************************************ -%* * -\subsection{Top-level code} -%* * -%************************************************************************ - -\begin{code} -$TargetPlatform = $TARGETPLATFORM; - -($Pgm = $0) =~ s|.*/||m; -$ifile = $ARGV[0]; -$ofile = $ARGV[1]; - -if ( $TargetPlatform =~ /^i386-/m ) { - if ($ARGV[2] eq '') { - $StolenX86Regs = 4; - } else { - $StolenX86Regs = $ARGV[2]; - } -} - -&mangle_asm($ifile,$ofile); - -exit(0); -\end{code} - -%************************************************************************ -%* * -\subsection{Constants for various architectures} -%* * -%************************************************************************ - -\begin{code} -sub init_TARGET_STUFF { - - #--------------------------------------------------------# - if ( $TargetPlatform =~ /^alpha-.*-.*/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\$L?C(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\$.*\.\.ng:|\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)'; - $T_COPY_DIRVS = '^\s*(\$.*\.\.ng:|\#|\.(file|globl|ent|loc))'; - - $T_DOT_WORD = '\.(long|quad|byte|word)'; - $T_DOT_GLOBAL = '^\t\.globl'; - $T_HDR_literal = "\.rdata\n\t\.align 3\n"; - $T_HDR_misc = "\.text\n\t\.align 3\n"; - $T_HDR_data = "\.data\n\t\.align 3\n"; - $T_HDR_rodata = "\.rdata\n\t\.align 3\n"; - $T_HDR_closure = "\.data\n\t\.align 3\n"; - $T_HDR_info = "\.text\n\t\.align 3\n"; - $T_HDR_entry = "\.text\n\t\.align 3\n"; - $T_HDR_vector = "\.text\n\t\.align 3\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^hppa/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^L\$C(\d+)$'; # regexp for what such a lbl looks like - $T_POST_LBL = ''; - - $T_MOVE_DIRVS = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)'; - $T_COPY_DIRVS = '^\s+\.(IMPORT|EXPORT)'; - - $T_DOT_WORD = '\.(blockz|word|half|byte)'; - $T_DOT_GLOBAL = '^\s+\.EXPORT'; - $T_HDR_literal = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n"; - $T_HDR_misc = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_data = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_rodata = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_closure = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|nextstep3|cygwin32|mingw32)$/m ) { - # NeXT added but not tested. CaS - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = 'L'; - $T_X86_PRE_LLBL = 'L'; - $T_X86_BADJMP = '^\tjmp [^L\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|stab|lcomm)'; - $T_DOT_WORD = '\.(long|word|value|byte|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.text\n\t\.align 4\n"; - $T_HDR_misc = "\.text\n\t\.align 4,0x90\n"; - $T_HDR_data = "\.data\n\t\.align 4\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding - $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?) - $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|gnu|freebsd|dragonfly|netbsd|openbsd|kfreebsdgnu)$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = # regexp that says what comes before APP/NO_APP - ($TargetPlatform =~ /-(linux|gnu|freebsd|dragonfly|netbsd|openbsd)$/m) ? '#' : '/' ; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = '\.L'; - $T_X86_PRE_LLBL = '.L'; - $T_X86_BADJMP = '^\tjmp\s+[^\.\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - if ( $TargetPlatform =~ /solaris2/m ) { - # newer Solaris linkers are picky about .size information, so - # omit it (see #1421) - $T_COPY_DIRVS = '^\s*\.(globl|local)'; - } else { - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - } - - $T_DOT_WORD = '\.(long|value|word|byte|zero)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 4\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?) - $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^ia64-.*-linux$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*\.(global|proc|pred\.safe_across_calls|text|data|section|subsection|align|size|type|ident)\s+.*\n)'; - $T_COPY_DIRVS = '\.(global|proc)'; - - $T_DOT_WORD = '\.(long|value|byte|zero)'; - $T_DOT_GLOBAL = '\.global'; - $T_HDR_literal = "\.section\t\.rodata\n"; - $T_HDR_misc = "\.text\n\t\.align 16\n"; # May contain code; align like 'entry' - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n"; - $T_HDR_closure = "\.data\n\t\.align 8\n"; - $T_HDR_info = "\.text\n\t\.align 8\n"; - $T_HDR_entry = "\.text\n\t\.align 16\n"; - $T_HDR_vector = "\.text\n\t\.align 8\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd|freebsd|dragonfly|netbsd|kfreebsdgnu)$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*\.(globl|text|data|section|align|size|type|ident|local)([ \t].*)?\n)'; - $T_COPY_DIRVS = '\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(quad|long|value|byte|zero)'; - $T_DOT_GLOBAL = '\.global'; - - $T_HDR_literal16 = "\.section\t\.rodata.cst16\n\t.align 16\n"; - $T_HDR_literal = "\.section\t\.rodata\n"; - - $T_HDR_misc = "\.text\n\t\.align 8\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n"; - - # the assembler on x86_64/Linux refuses to generate code for - # .quad x - y - # where x is in the text section and y in the rodata section. - # It works if y is in the text section, though. This is probably - # going to cause difficulties for PIC, I imagine. - # - # See Note [x86-64-relative] in includes/InfoTables.h - $T_HDR_relrodata= "\.text\n\t\.align 8\n"; - - $T_HDR_closure = "\.data\n\t\.align 8\n"; - $T_HDR_info = "\.text\n\t\.align 8\n"; - $T_HDR_entry = "\.text\n\t\.align 8\n"; - $T_HDR_vector = "\.text\n\t\.align 8\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/m ) { - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^# MAY NOT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)'; - $T_COPY_DIRVS = '\.(globl|proc|stab)'; - - $T_DOT_WORD = '\.long'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.text\n\t\.even\n"; - $T_HDR_misc = "\.text\n\t\.even\n"; - $T_HDR_data = "\.data\n\t\.even\n"; - $T_HDR_rodata = "\.text\n\t\.even\n"; - $T_HDR_closure = "\.data\n\t\.even\n"; - $T_HDR_info = "\.text\n\t\.even\n"; - $T_HDR_entry = "\.text\n\t\.even\n"; - $T_HDR_vector = "\.text\n\t\.even\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^mips-.*/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '^\s*#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\$LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)'; - $T_COPY_DIRVS = '\.(globl|ent)'; - - $T_DOT_WORD = '\.word'; - $T_DOT_GLOBAL = '^\t\.globl'; - $T_HDR_literal = "\t\.rdata\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.rdata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc-apple-darwin.*/m ) { - # Apple PowerPC Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.const\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m ) { - # Apple i386 Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = 'L'; - $T_X86_PRE_LLBL = 'L'; - $T_X86_BADJMP = '^\tjmp [^L\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n"; - $T_HDR_literal = "\t\.const\n\t\.align 4\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^x86_64-apple-darwin.*/m ) { - # Apple amd64 Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align \d+|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(quad|long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n"; - $T_HDR_literal = "\t\.const\n\t\.align 4\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m ) { - # PowerPC Linux - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc64-.*-linux/m ) { - # PowerPC 64 Linux - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '\.'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.section\t\".toc\",\"aw\"\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-(solaris2|openbsd)/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.stab.*|\s*\.section.*|\s+\.type.*|\s+\.size.*)\n)'; - $T_COPY_DIRVS = '\.(global|local|proc|stab)'; - - $T_DOT_WORD = '\.(long|word|byte|half|skip|uahalf|uaword)'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/m ) { - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^# DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)'; - $T_COPY_DIRVS = '\.(global|proc|stab)'; - - $T_DOT_WORD = '\.word'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-linux/m ) { - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; # regexp that says what comes before APP/NO_APP - # Probably doesn't apply anyway - $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.seg|\.stab.*|\s+?\.section.*|\s+\.type.*|\s+\.size.*)\n)'; - $T_COPY_DIRVS = '\.(global|local|globl|proc|stab)'; - - $T_DOT_WORD = '\.(long|word|nword|xword|byte|half|short|skip|uahalf|uaword)'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } else { - print STDERR "$Pgm: don't know how to mangle assembly language for: $TargetPlatform\n"; - exit 1; - } - - if($T_HDR_relrodata eq "") { - # default values: - # relrodata defaults to rodata. - $T_HDR_relrodata = $T_HDR_rodata; - } - -if ( 0 ) { -print STDERR "T_STABBY: $T_STABBY\n"; -print STDERR "T_US: $T_US\n"; -print STDERR "T_PRE_APP: $T_PRE_APP\n"; -print STDERR "T_CONST_LBL: $T_CONST_LBL\n"; -print STDERR "T_POST_LBL: $T_POST_LBL\n"; -if ( $TargetPlatform =~ /^i386-/m ) { - print STDERR "T_X86_PRE_LLBL_PAT: $T_X86_PRE_LLBL_PAT\n"; - print STDERR "T_X86_PRE_LLBL: $T_X86_PRE_LLBL\n"; - print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n"; -} -print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n"; -print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n"; -print STDERR "T_DOT_WORD: $T_DOT_WORD\n"; -print STDERR "T_HDR_literal: $T_HDR_literal\n"; -print STDERR "T_HDR_misc: $T_HDR_misc\n"; -print STDERR "T_HDR_data: $T_HDR_data\n"; -print STDERR "T_HDR_rodata: $T_HDR_rodata\n"; -print STDERR "T_HDR_closure: $T_HDR_closure\n"; -print STDERR "T_HDR_info: $T_HDR_info\n"; -print STDERR "T_HDR_entry: $T_HDR_entry\n"; -print STDERR "T_HDR_vector: $T_HDR_vector\n"; -} - -} -\end{code} - -%************************************************************************ -%* * -\subsection{Mangle away} -%* * -%************************************************************************ - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - local($i, $c); - - # ia64-specific information for code chunks - my $ia64_locnum; - my $ia64_outnum; - - &init_TARGET_STUFF(); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %entrychk = (); # ditto, its entry code - %closurechk = (); # ditto, the (static) closure - %srtchk = (); # ditto, its SRT (for top-level things) - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - $EXTERN_DECLS = ''; # .globl .text (MIPS only) - - $i = 0; $chkcat[0] = 'misc'; $chk[0] = ''; - - while () { - tr/\r//d if $TargetPlatform =~ /-mingw32$/m; # In case Perl doesn't convert line endings - next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/om; - next if $T_STABBY && /^\.stab.*ghc.*c_ID/m; - next if /^\t\.def.*endef$/m; - next if /${T_PRE_APP}(NO_)?APP/om; - next if /^;/m && $TargetPlatform =~ /^hppa/m; - - next if /(^$|^\t\.file\t|^ # )/m && $TargetPlatform =~ /(^mips-|^ia64-|-mingw32$)/m; - - if ( $TargetPlatform =~ /^mips-/m - && /^\t\.(globl\S+\.text|comm\t)/m ) { - $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/m; - # Treat .comm variables as data. These show up in two (known) places: - # - # - the module_registered variable used in the __stginit fragment. - # even though these are declared static and initialised, gcc 3.3 - # likes to make them .comm, presumably to save space in the - # object file. - # - # - global variables used to pass arguments from C to STG in - # a foreign export. (is this still true? --SDM) - # - } elsif ( /^\t\.comm.*$/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - # Labels ending "_str": these are literal strings. - } elsif ( /^${T_US}([A-Za-z0-9_]+)_str${T_POST_LBL}$/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'relrodata'; - $chksymb[$i] = ''; - } elsif ( $TargetPlatform =~ /-darwin/m - && (/^\s*\.subsections_via_symbols/m - ||/^\s*\.no_dead_strip.*/m)) { - # Don't allow Apple's linker to do any dead-stripping of symbols - # in this file, because it will mess up info-tables in mangled - # code. - # The .no_dead_strip directives are actually put there by - # the gcc3 "used" attribute on entry points. - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && ( - /^\s*\.picsymbol_stub/m - || /^\s*\.section __TEXT,__picsymbol_stub\d,.*/m - || /^\s*\.section __TEXT,__picsymbolstub\d,.*/m - || /^\s*\.symbol_stub/m - || /^\s*\.section __TEXT,__symbol_stub\d,.*/m - || /^\s*\.section __TEXT,__symbolstub\d,.*/m - || /^\s*\.lazy_symbol_pointer/m - || /^\s*\.non_lazy_symbol_pointer/m - || /^\s*\.section __IMPORT.*/m)) - { - $chk[++$i] = $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - $dyld_section = $_; - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.data/m) - { # non_lazy_symbol_ptrs that point to local symbols - $chk[++$i] = $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - $dyld_section = $_; - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.align/m) - { # non_lazy_symbol_ptrs that point to local symbols - $dyld_section .= $_; - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^L_.*:$/m) - { # non_lazy_symbol_ptrs that point to local symbols - $chk[++$i] = $dyld_section . $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - - } elsif ( /^\s+/m ) { # most common case first -- a simple line! - # duplicated from the bottom - - $chk[$i] .= $_; - - } elsif ( /\.\.ng:$/m && $TargetPlatform =~ /^alpha-/m ) { - # Alphas: Local labels not to be confused with new chunks - $chk[$i] .= $_; - # NB: all the rest start with a non-space - - } elsif ( $TargetPlatform =~ /^mips-/m - && /^\d+:/m ) { # a funny-looking very-local label - $chk[$i] .= $_; - - } elsif ( /$T_CONST_LBL/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'literal'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}__stg_split_marker(\d*)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/om ) { - $symb = $1; - $chk[++$i] = $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_(entry|ret)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'entry'; - $chksymb[$i] = $1; - - $entrychk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_srt${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'srt'; - $chksymb[$i] = $1; - - $srtchk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_ct${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}(stg_ap_stack_entries|stg_stack_save_entries|stg_arg_bitmaps)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/om ) { - ; # toss it - - } elsif ( /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/om - || /^${T_US}.*_CAT${T_POST_LBL}$/om # PROF: _entryname_CAT - || /^${T_US}.*_done${T_POST_LBL}$/om # PROF: _module_done - || /^${T_US}_module_registered${T_POST_LBL}$/om # PROF: _module_registered - ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/m && $TargetPlatform =~ /^hppa/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'bss'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_cc(s)?${T_POST_LBL}$/om ) { - # all CC_ symbols go in the data section... - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_hpc${T_POST_LBL}$/om ) { - # hpc shares tick boxes across modules - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_vtbl${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/m - && /^[A-Za-z0-9][A-Za-z0-9_]*:/m ) { - # Some Solaris system headers contain function definitions (as - # opposed to mere prototypes), which end up in the .hc file when - # a Haskell module foreign imports the corresponding system - # functions (most notably stat()). We put them into the text - # segment. Note that this currently does not extend to function - # names starting with an underscore. - # - chak 7/2001 - $chk[++$i] = $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = $1; - - } elsif ( $TargetPlatform =~ /^i386-apple-darwin/m && /^(___i686\.get_pc_thunk\.[abcd]x):/om) { - # To handle PIC on Darwin/x86, we need to appropriately pass through - # the get_pc_thunk functions. The need to be put into a special section - # marked as coalesced (otherwise the .weak_definition doesn't work - # on Darwin). - $chk[++$i] = $_; - $chkcat[$i] = 'get_pc_thunk'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}[A-Za-z0-9_]/om - && ( $TargetPlatform !~ /^hppa/m # need to avoid local labels in this case - || ! /^L\$\d+$/m ) - && ( $TargetPlatform !~ /^powerpc64/m # we need to avoid local labels in this case - || ! /^\.L\d+:$/m ) ) { - local($thing); - chop($thing = $_); - $thing =~ s/:$//m; - $chk[++$i] = $_; - $chksymb[$i] = ''; - if ( - /^${T_US}stg_.*${T_POST_LBL}$/om # RTS internals - || /^${T_US}__stg_.*${T_POST_LBL}$/om # more RTS internals - || /^${T_US}__fexp_.*${T_POST_LBL}$/om # foreign export - || /^${T_US}.*_slow${T_POST_LBL}$/om # slow entry - || /^${T_US}__stginit.*${T_POST_LBL}$/om # __stginit - || /^${T_US}.*_btm${T_POST_LBL}$/om # large bitmaps - || /^${T_US}.*_fast${T_POST_LBL}$/om # primops - || /^_uname:/om # x86/Solaris2 - ) - { - $chkcat[$i] = 'misc'; - } elsif ( - /^${T_US}.*_srtd${T_POST_LBL}$/om # large bitmaps - || /^${T_US}.*_closure_tbl${T_POST_LBL}$/om # closure tables - ) - { - $chkcat[$i] = 'relrodata'; - } else - { - print STDERR "Warning: retaining unknown function \`$thing' in output from C compiler\n"; - $chkcat[$i] = 'unknown'; - } - - } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m && /^\.LCTOC1 = /om ) { - # PowerPC Linux's large-model PIC (-fPIC) generates a gobal offset - # table "by hand". Be sure to copy it over. - # Note that this label and all entries in the table should actually - # go into the .got2 section, but it isn't easy to distinguish them - # from other constant literals (.LC\d+), so we just put everything - # in .rodata. - $chk[++$i] = $_; - $chkcat[$i] = 'literal'; - $chksymb[$i] = 'LCTOC1'; - } else { # simple line (duplicated at the top) - - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - $chk[$numchks] = ''; # We might push .note.GNU-stack into this - $chkcat[$numchks] = 'verbatim'; # If we do, write it straight back out - - # open CHUNKS, ">/tmp/chunks1" or die "Cannot open /tmp/chunks1: $!\n"; - # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } - # close CHUNKS; - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/m) ? 1 : 0; - local($FIRST_TOSSABLE ) = ($TargetPlatform =~ /^(hppa|mips-)/m) ? 1 : 0; - -# print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n"; - - # Alphas: NB: we start meddling at chunk 1, not chunk 0 - # The first ".rdata" is quite magical; as of GCC 2.7.x, it - # spits a ".quad 0" in after the very first ".rdata"; we - # detect this special case (tossing the ".quad 0")! - local($magic_rdata_seen) = 0; - - # HPPAs, MIPSen: also start medding at chunk 1 - - for ($i = $FIRST_TOSSABLE; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c; - - # toss all prologue stuff; HPPA is pretty weird - # (see elsewhere) - $c = &hppa_mash_prologue($c) if $TargetPlatform =~ /^hppa-/m; - - undef $ia64_locnum; - undef $ia64_outnum; - - # be slightly paranoid to make sure there's - # nothing surprising in there - if ( $c =~ /--- BEGIN ---/m ) { - if (($p, $r) = split(/--- BEGIN ---/m, $c)) { - - # remove junk whitespace around the split point - $p =~ s/\t+$//m; - $r =~ s/^\s*\n//m; - - if ($TargetPlatform =~ /^i386-/m) { - if ($p =~ /^\tsubl\s+\$(\d+),\s*\%esp\n/m) { - if ($1 >= 8192) { - die "Error: reserved stack space exceeded!\n Possible workarounds: compile with -fasm, or try another version of gcc.\n" - } - } - - # gcc 3.4.3 puts this kind of stuff in the prologue, eg. - # when compiling PrimOps.cmm with -optc-O2: - # xorl %ecx, %ecx - # xorl %edx, %edx - # movl %ecx, 16(%esp) - # movl %edx, 20(%esp) - # but then the code of the function doesn't assume - # anything about the contnets of these stack locations. - # I think it's to do with the use of inline functions for - # PK_Word64() and friends, where gcc is initialising the - # contents of the struct to zero, and failing to optimise - # away the initialisation. Let's live dangerously and - # discard these initalisations. - - $p =~ s/^\tpushl\s+\%e(di|si|bx)\n//gm; - $p =~ s/^\txorl\s+\%e(ax|cx|dx),\s*\%e(ax|cx|dx)\n//gm; - $p =~ s/^\tmovl\s+\%e(ax|cx|dx|si|di),\s*\d*\(\%esp\)\n//gm; - $p =~ s/^\tmovl\s+\$\d+,\s*\d*\(\%esp\)\n//gm; - $p =~ s/^\tsubl\s+\$\d+,\s*\%esp\n//m; - $p =~ s/^\tmovl\s+\$\d+,\s*\%eax\n\tcall\s+__alloca\n//m if ($TargetPlatform =~ /^.*-(cygwin32|mingw32)/m); - - if ($TargetPlatform =~ /^i386-apple-darwin/m) { - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = ""; - $pcrel_reg = $p; - $pcrel_reg =~ s/(.|\n)*.*___i686\.get_pc_thunk\.([abcd]x)\n(.|\n)*/$2/m or $pcrel_reg = ""; - $p =~ s/^\s+call\s+___i686\.get_pc_thunk\..x//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - - if ($pcrel_reg eq "bx") { - # Bad gcc. Goes and uses %ebx, our BaseReg, for PIC. Bad gcc. - die "Darwin/x86: -fPIC -via-C doesn't work yet, use -fasm. Aborting." - } - } - - } elsif ($TargetPlatform =~ /^x86_64-/m) { - $p =~ s/^\tpushq\s+\%r(bx|bp|12|13|14)\n//gm; - $p =~ s/^\tmovq\s+\%r(bx|bp|12|13|14),\s*\d*\(\%rsp\)\n//gm; - $p =~ s/^\tsubq\s+\$\d+,\s*\%rsp\n//m; - - } elsif ($TargetPlatform =~ /^ia64-/m) { - $p =~ s/^\t\.prologue .*\n//m; - - # Record the number of local and out registers for register relocation later - $p =~ s/^\t\.save ar\.pfs, r\d+\n\talloc r\d+ = ar\.pfs, 0, (\d+), (\d+), 0\n//m; - $ia64_locnum = $1; - $ia64_outnum = $2; - - $p =~ s/^\t\.fframe \d+\n\tadds r12 = -\d+, r12\n//m; - $p =~ s/^\t\.save rp, r\d+\n\tmov r\d+ = b0\n//m; - - # Ignore save/restore of these registers; they're taken - # care of in StgRun() - $p =~ s/^\t\.save ar\.lc, r\d+\n//m; - $p =~ s/^\t\.save pr, r\d+\n//m; - $p =~ s/^\tmov r\d+ = ar\.lc\n//m; - $p =~ s/^\tmov r\d+ = pr\n//m; - - # Remove .proc and .body directives - $p =~ s/^\t\.proc [a-zA-Z0-9_.]+#\n//m; - $p =~ s/^\t\.body\n//m; - - # If there's a label, move it to the body - if ($p =~ /^[a-zA-Z0-9.]+:\n/m) { - $p = $` . $'; - $r = $& . $r; - } - - # Remove floating-point spill instructions. - # Only fp registers 2-5 and 16-23 are saved by the runtime. - if ($p =~ s/^\tstf\.spill \[r1[4-9]\] = f([2-5]|1[6-9]|2[0-3])(, [0-9]+)?\n//gm) { - # Being paranoid, only try to remove these if we saw a - # spill operation. - $p =~ s/^\tmov r1[4-9] = r12\n//m; - $p =~ s/^\tadds r1[4-9] = -[0-9]+, r12\n//gm; - $p =~ s/^\t\.save\.f 0x[0-9a-fA-F]\n//gm; - $p =~ s/^\t\.save\.gf 0x0, 0x[0-9a-fA-F]+\n//gm; - } - - $p =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions - $p =~ s/^\t\.(mii|mmi|mfi)\n//gm; # bundling is no longer sensible - $p =~ s/^\t;;\n//gm; # discard stops - $p =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments - - # GCC 3.3 saves r1 in the prologue, move this to the body - # (Does this register get restored anywhere?) - if ($p =~ /^\tmov r\d+ = r1\n/m) { - $p = $` . $'; - $r = $& . $r; - } - } elsif ($TargetPlatform =~ /^m68k-/m) { - $p =~ s/^\tlink a6,#-?\d.*\n//m; - $p =~ s/^\tpea a6@\n\tmovel sp,a6\n//m; - # The above showed up in the asm code, - # so I added it here. - # I hope it's correct. - # CaS - $p =~ s/^\tmovel d2,sp\@-\n//m; - $p =~ s/^\tmovel d5,sp\@-\n//m; # SMmark.* only? - $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//m; # SMmark.* only? - } elsif ($TargetPlatform =~ /^mips-/m) { - # the .frame/.mask/.fmask that we use is the same - # as that produced by GCC for miniInterpret; this - # gives GDB some chance of figuring out what happened - $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n"; - $p =~ s/^\t\.(frame).*\n/__FRAME__/gm; - $p =~ s/^\t\.(mask|fmask).*\n//gm; - $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/m; # 16 + 100 4-byte args - $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//m; - $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//m; - $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//m; - $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//m; - $p =~ s/__FRAME__/$FRAME/m; - } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) { - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = ""; - - $p =~ s/^\tmflr r0\n//m; - $p =~ s/^\tbl saveFP # f\d+\n//m; - $p =~ s/^\tbl saveFP ; save f\d+-f\d+\n//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - $p =~ s/^\tstmw r\d+,-\d+\(r1\)\n//m; - $p =~ s/^\tstfd f\d+,-\d+\(r1\)\n//gm; - $p =~ s/^\tstw r0,\d+\(r1\)\n//gm; - $p =~ s/^\tstwu r1,-\d+\(r1\)\n//m; - $p =~ s/^\tstw r\d+,-\d+\(r1\)\n//gm; - $p =~ s/^\tbcl 20,31,\"?L\d+\$pb\"?\n//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - $p =~ s/^\tmflr r31\n//m; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli r\d+,0\n//gm; - $p =~ s/^\tstw r\d+,\d+\(r1\)\n//gm; - } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m) { - $p =~ s/^\tmflr 0\n//m; - $p =~ s/^\tstmw \d+,\d+\(1\)\n//m; - $p =~ s/^\tstfd \d+,\d+\(1\)\n//gm; - $p =~ s/^\tstw r0,8\(1\)\n//m; - $p =~ s/^\tstwu 1,-\d+\(1\)\n//m; - $p =~ s/^\tstw \d+,\d+\(1\)\n//gm; - - # GCC's "large-model" PIC (-fPIC) - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^.LCF(\d+):\n(.|\n)*/$2/m or $pcrel_label = ""; - - $p =~ s/^\tbcl 20,31,.LCF\d+\n//m; - $p =~ s/^.LCF\d+:\n//m; - $p =~ s/^\tmflr 30\n//m; - $p =~ s/^\tlwz 0,\.LCL\d+-\.LCF\d+\(30\)\n//m; - $p =~ s/^\tadd 30,0,30\n//m; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli \d+,0\n//gm; - $p =~ s/^\tstw \d+,\d+\(1\)\n//gm; - } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) { - $p =~ s/^\tmr 31,1\n//m; - $p =~ s/^\tmflr 0\n//m; - $p =~ s/^\tstmw \d+,\d+\(1\)\n//m; - $p =~ s/^\tstfd \d+,-?\d+\(1\)\n//gm; - $p =~ s/^\tstd r0,8\(1\)\n//m; - $p =~ s/^\tstdu 1,-\d+\(1\)\n//m; - $p =~ s/^\tstd \d+,-?\d+\(1\)\n//gm; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli \d+,0\n//gm; - $p =~ s/^\tstd \d+,\d+\(1\)\n//gm; - } else { - print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n"; - } - - # HWL HACK: dont die, just print a warning - #print stderr "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/; - die "Prologue junk?: $p\n" if $p =~ /^\s+[^\s\.]/m; - - # For PIC, we want to keep part of the prologue - if ($TargetPlatform =~ /^powerpc-apple-darwin.*/m && $pcrel_label ne "") { - # Darwin: load the current instruction pointer into register r31 - $p .= "bcl 20,31,$pcrel_label\n"; - $p .= "$pcrel_label:\n"; - $p .= "\tmflr r31\n"; - } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m && $pcrel_label ne "") { - # Linux: load the GOT pointer into register 30 - $p .= "\tbcl 20,31,.LCF$pcrel_label\n"; - $p .= ".LCF$pcrel_label:\n"; - $p .= "\tmflr 30\n"; - $p .= "\tlwz 0,.LCL$pcrel_label-.LCF$pcrel_label(30)\n"; - $p .= "\tadd 30,0,30\n"; - } elsif ($TargetPlatform =~ /^i386-apple-darwin.*/m && $pcrel_label ne "") { - $p .= "\tcall ___i686.get_pc_thunk.$pcrel_reg\n"; - $p .= "$pcrel_label:\n"; - } - - # glue together what's left - $c = $p . $r; - } - } - - if ( $TargetPlatform =~ /^mips-/m ) { - # MIPS: first, this basic sequence may occur "--- END ---" or not - $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/m; - } - - # toss all epilogue stuff; again, paranoidly - if ( $c =~ /--- END ---/m ) { - # Gcc may decide to replicate the function epilogue. We want - # to process all epilogues, so we split the function and then - # loop here. - @fragments = split(/--- END ---/m, $c); - $r = shift(@fragments); - - # Rebuild `c'; processed fragments will be appended to `c' - $c = $r; - - foreach $e (@fragments) { - # etail holds code that is after the epilogue in the assembly-code - # layout and should not be filtered as part of the epilogue. - $etail = ""; - if ($TargetPlatform =~ /^i386-/m) { - $e =~ s/^\tret\n//m; - $e =~ s/^\tpopl\s+\%edi\n//m; - $e =~ s/^\tpopl\s+\%esi\n//m; - $e =~ s/^\tpopl\s+\%edx\n//m; - $e =~ s/^\tpopl\s+\%ecx\n//m; - $e =~ s/^\taddl\s+\$\d+,\s*\%esp\n//m; - $e =~ s/^\tsubl\s+\$-\d+,\s*\%esp\n//m; - } elsif ($TargetPlatform =~ /^ia64-/m) { - # The epilogue is first split into: - # $e, the epilogue code (up to the return instruction) - # $etail, non-epilogue code (after the return instruction) - # The return instruction is stripped in the process. - if (!(($e, $etail) = split(/^\tbr\.ret\.sptk\.many b0\n/m, $e))) { - die "Epilogue doesn't seem to have one return instruction: $e\n"; - } - # Remove 'endp' directive from the tail - $etail =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m; - - # If a return value is saved here, discard it - $e =~ s/^\tmov r8 = r14\n//m; - - # Remove floating-point fill instructions. - # Only fp registers 2-5 and 16-23 are saved by the runtime. - if ($e =~ s/^\tldf\.fill f([2-5]|1[6-9]|2[0-3]) = \[r1[4-9]\](, [0-9]+)?\n//gm) { - # Being paranoid, only try to remove this if we saw a fill - # operation. - $e =~ s/^\tadds r1[4-9] = [0-9]+, r12//gm; - } - - $e =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions - $e =~ s/^\tmov ar\.pfs = r\d+\n//m; - $e =~ s/^\tmov ar\.lc = r\d+\n//m; - $e =~ s/^\tmov pr = r\d+, -1\n//m; - $e =~ s/^\tmov b0 = r\d+\n//m; - $e =~ s/^\t\.restore sp\n\tadds r12 = \d+, r12\n//m; - #$e =~ s/^\tbr\.ret\.sptk\.many b0\n//; # already removed - $e =~ s/^\t\.(mii|mmi|mfi|mib)\n//gm; # bundling is no longer sensible - $e =~ s/^\t;;\n//gm; # discard stops - stop at end of body is sufficient - $e =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments - } elsif ($TargetPlatform =~ /^m68k-/m) { - $e =~ s/^\tunlk a6\n//m; - $e =~ s/^\trts\n//m; - } elsif ($TargetPlatform =~ /^mips-/m) { - $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//m; - $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//m; - $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//m; - $e =~ s/^\tj\t\$31\n//m; - } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) { - $e =~ s/^\taddi r1,r1,\d+\n//m; - $e =~ s/^\tlwz r\d+,\d+\(r1\)\n//m; - $e =~ s/^\tlmw r\d+,-\d+\(r1\)\n//m; - $e =~ s/^\tmtlr r0\n//m; - $e =~ s/^\tblr\n//m; - $e =~ s/^\tb restFP ;.*\n//m; - } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) { - $e =~ s/^\tmr 3,0\n//m; - $e =~ s/^\taddi 1,1,\d+\n//m; - $e =~ s/^\tld 0,16\(1\)\n//m; - $e =~ s/^\tmtlr 0\n//m; - - # callee-save registers - $e =~ s/^\tld \d+,-?\d+\(1\)\n//gm; - $e =~ s/^\tlfd \d+,-?\d+\(1\)\n//gm; - - # get rid of the debug junk along with the blr - $e =~ s/^\tblr\n\t.long .*\n\t.byte .*\n//m; - - # incase we missed it with the last one get the blr alone - $e =~ s/^\tblr\n//m; - } else { - print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n"; - } - - print STDERR "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/m; - - # glue together what's left - $c .= $e . $etail; - } - $c =~ s/\n\t\n/\n/m; # junk blank line - } - else { - if ($TargetPlatform =~ /^ia64-/m) { - # On IA64, remove an .endp directive even if no epilogue was found. - # Code optimizations may have removed the "--- END ---" token. - $c =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m; - } - } - - # On SPARCs, we don't do --- BEGIN/END ---, we just - # toss the register-windowing save/restore/ret* instructions - # directly unless they've been generated by function definitions in header - # files on Solaris: - if ( $TargetPlatform =~ /^sparc-/m ) { - if ( ! ( $TargetPlatform =~ /solaris2$/m && $chkcat[$i] eq 'unknown' )) { - $c =~ s/^\t(save.*|restore.*|ret|retl)\n//gm; - } - # throw away PROLOGUE comments - $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//m; - } - - # On Alphas, the prologue mangling is done a little later (below) - - # toss all calls to __DISCARD__ - $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//gom; - $c =~ s/^\tjsr\s+\$26\s*,\s*${T_US}__DISCARD__\n//gom if $TargetPlatform =~ /^alpha-/m; - $c =~ s/^\tbl\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /^powerpc-apple-darwin.*/m; - $c =~ s/^\tbl\s+__DISCARD__(\@plt)?\n//gom if $TargetPlatform =~ /^powerpc-.*-linux/m; - $c =~ s/^\tbl\s+\.__DISCARD__\n\s+nop\n//gom if $TargetPlatform =~ /^powerpc64-.*-linux/m; - $c =~ s/^\tcall\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /i386-apple-darwin.*/m; - - # IA64: fix register allocation; mangle tailcalls into jumps - if ($TargetPlatform =~ /^ia64-/m) { - ia64_rename_registers($ia64_locnum, $ia64_outnum) if (defined($ia64_locnum)); - ia64_mangle_tailcalls(); - } - - # MIPS: that may leave some gratuitous asm macros around - # (no harm done; but we get rid of them to be tidier) - $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/m - if $TargetPlatform =~ /^mips-/m; - - # toss stack adjustment after DoSparks - $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/gm - if $TargetPlatform =~ /^m68k-/m; # this looks old... - - if ( $TargetPlatform =~ /^alpha-/m && - ! $magic_rdata_seen && - $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/m ) { - $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/m; - $magic_rdata_seen = 1; - } - - # pick some end-things and move them to the next chunk - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/om ) { - - $to_move = $1; - - # on x86 we try not to copy any directives into a literal - # chunk, rather we keep looking for the next real chunk. This - # is because we get things like - # - # .globl blah_closure - # .LC32 - # .string "..." - # blah_closure: - # ... - # - if ( $TargetPlatform =~ /^(i386|sparc|powerpc)/m && $to_move =~ /${T_COPY_DIRVS}/m ) { - $j = $i + 1; - while ( $j < $numchks && $chk[$j] =~ /$T_CONST_LBL/m) { - $j++; - } - if ( $j < $numchks ) { - $chk[$j] = $to_move . $chk[$j]; - } - } - - elsif ( ( $i < ($numchks - 1) - && ( $to_move =~ /${T_COPY_DIRVS}/m - || ( $TargetPlatform =~ /^hppa/m - && $to_move =~ /align/m - && $chkcat[$i+1] eq 'literal') - ) - ) - || ($to_move =~ /^[ \t]*\.section[ \t]+\.note\.GNU-stack,/m) - ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/om; - } - - if ( $TargetPlatform =~ /^alpha-/m && $c =~ /^\t\.ent\s+(\S+)/m ) { - $ent = $1; - # toss all prologue stuff, except for loading gp, and the ..ng address - unless ($c =~ /\.ent.*\n\$.*\.\.ng:/m) { - if (($p, $r) = split(/^\t\.prologue/m, $c)) { - # use vars '$junk'; # Unused? - if (($keep, $junk) = split(/\.\.ng:/m, $p)) { - $keep =~ s/^\t\.frame.*\n/\t.frame \$30,0,\$26,0\n/m; - $keep =~ s/^\t\.(mask|fmask).*\n//gm; - $c = $keep . "..ng:\n"; - } else { - print STDERR "malformed code block ($ent)?\n" - } - } - $c .= "\t.prologue" . $r; - } - } - - $c =~ s/FUNNY#END#THING//m; - -# print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c; - - $chk[$i] = $c; # update w/ convenience copy - } - - # open CHUNKS, ">/tmp/chunks2" or die "Cannot open /tmp/chunks2: $!\n"; - # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } - # close CHUNKS; - - if ( $TargetPlatform =~ /^alpha-/m ) { - # print out the header stuff first - $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/m; - print OUTASM $chk[0]; - - } elsif ( $TargetPlatform =~ /^hppa/m ) { - print OUTASM $chk[0]; - - } elsif ( $TargetPlatform =~ /^mips-/m ) { - $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0]; - - # get rid of horrible "Revision: .*$" strings - local(@lines0) = split(/\n/m, $chk[0]); - local($z) = 0; - while ( $z <= $#lines0 ) { - if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/m ) { - undef($lines0[$z]); - $z++; - while ( $z <= $#lines0 ) { - undef($lines0[$z]); - last if $lines0[$z] =~ /[,\t]0x0$/m; - $z++; - } - } - $z++; - } - $chk[0] = join("\n", @lines0); - $chk[0] =~ s/\n\n+/\n/m; - print OUTASM $chk[0]; - } - - # print out all the literal strings next - for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'literal' ) { - - # HACK: try to detect 16-byte constants and align them - # on a 16-byte boundary. x86_64 sometimes needs 128-bit - # aligned constants, and so does Darwin/x86. - if ( $TargetPlatform =~ /^x86_64/m - || $TargetPlatform =~ /^i386-apple-darwin/m ) { - $z = $chk[$i]; - if ($z =~ /(\.long.*\n.*\.long.*\n.*\.long.*\n.*\.long|\.quad.*\n.*\.quad)/m) { - print OUTASM $T_HDR_literal16; - } else { - print OUTASM $T_HDR_literal; - } - } else { - print OUTASM $T_HDR_literal; - } - - print OUTASM $chk[$i]; - print OUTASM "; end literal\n" if $TargetPlatform =~ /^hppa/m; # for the splitter - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - # on the HPPA, print out all the bss next - if ( $TargetPlatform =~ /^hppa/m ) { - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'bss' ) { - print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - } - - # $numchks + 1 as we have the extra one for .note.GNU-stack - for ($i = $FIRST_MANGLABLE; $i < $numchks + 1; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' || $chkcat[$i] eq 'unknown' ) { - if ($chk[$i] ne '') { - print OUTASM $T_HDR_misc; - &print_doctored($chk[$i], 0); - } - - } elsif ( $chkcat[$i] eq 'verbatim' ) { - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'toss' ) { - print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n"; - - } elsif ( $chkcat[$i] eq 'data' ) { - if ($chk[$i] ne '') { - print OUTASM $T_HDR_data; - print OUTASM $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - # NB: we emit _three_ underscores no matter what, - # so ghc-split doesn't have to care. - print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'srt' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'entry') { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM $T_HDR_closure; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # SRT - if ( defined($srtchk{$symb}) ) { - print OUTASM $T_HDR_relrodata; - print OUTASM $chk[$srtchk{$symb}]; - $chkcat[$srtchk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM $T_HDR_info; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - - # entry code will be put here! - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # ENTRY POINT - if ( defined($entrychk{$symb}) ) { - - $c = $chk[$entrychk{$symb}]; - - # If this is an entry point with an info table, - # eliminate the entry symbol and all directives involving it. - if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/m - && $TABLES_NEXT_TO_CODE eq "YES") { - @o = (); - foreach $l (split(/\n/m,$c)) { - next if $l =~ /^.*$symb_(entry|ret)${T_POST_LBL}/m; - - # If we have .type/.size direrctives involving foo_entry, - # then make them refer to foo_info instead. The information - # in these directives is used by the cachegrind annotator, - # so it is worthwhile keeping. - if ($l =~ /^\s*\.(type|size).*$symb_(entry|ret)/m) { - $l =~ s/$symb(_entry|_ret)/${symb}_info/gm; - push(@o,$l); - next; - } - next if $l =~ /^\s*\..*$symb.*\n?/m; - push(@o,$l); - } - $c = join("\n",@o) . "\n"; - } - - print OUTASM $T_HDR_entry; - - &print_doctored($c, 1); # NB: the 1!!! - - $chkcat[$entrychk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' ) { - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM $T_HDR_vector; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - - } elsif ( $TargetPlatform =~ /^alpha-/m ) { - # Alphas: the commented nop is for the splitter, to ensure - # that no module ends with a label as the very last - # thing. (The linker will adjust the label to point - # to the first code word of the next module linked in, - # even if alignment constraints cause the label to move!) - - print OUTASM "\t# nop\n"; - } - - } elsif ( $chkcat[$i] eq 'rodata' ) { - print OUTASM $T_HDR_rodata; - print OUTASM $chk[$i]; - $chkcat[$i] = 'DONE ALREADY'; - } elsif ( $chkcat[$i] eq 'relrodata' ) { - print OUTASM $T_HDR_relrodata; - print OUTASM $chk[$i]; - $chkcat[$i] = 'DONE ALREADY'; - } elsif ( $chkcat[$i] eq 'toc' ) { - # silly optimisation to print tocs, since they come in groups... - print OUTASM $T_HDR_toc; - local($j) = $i; - while ($chkcat[$j] eq 'toc') - { if ( $chk[$j] !~ /\.tc UpdatePAP\[TC\]/m # not needed: always turned into a jump. - ) - { - print OUTASM $chk[$j]; - } - $chkcat[$j] = 'DONE ALREADY'; - $j++; - } - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' ) { - # apple-darwin: dynamic linker stubs - if($chk[$i] !~ /\.indirect_symbol ___DISCARD__/m) - { # print them out unchanged, but remove the stubs for __DISCARD__ - print OUTASM $chk[$i]; - } - } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m && $chkcat[$i] eq 'get_pc_thunk' ) { - # i386-apple-darwin: __i686.get_pc_thunk.[abcd]x - print OUTASM ".section __TEXT,__textcoal_nt,coalesced,no_toc\n"; - print OUTASM $chk[$i]; - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - print OUTASM $EXTERN_DECLS if $TargetPlatform =~ /^mips-/m; - - # finished - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -On IA64, tail calls are converted to branches at this point. The mangler -searches for function calls immediately followed by a '--- TAILCALL ---' -token. Since the compiler can put various combinations of labels, bundling -directives, nop instructions, stops, and a move of the return value -between the branch and the tail call, proper matching of the tail call -gets a little hairy. This subroutine does the mangling. - -Here is an example of a tail call before mangling: - -\begin{verbatim} - br.call.sptk.many b0 = b6 -.L211 - ;; - .mmi - mov r1 = r32 - ;; - nop.m 0 - nop.i 0 - ;; - --- TAILCALL -- - ;; -.L123 -\end{verbatim} - -\begin{code} -sub ia64_mangle_tailcalls { - # Function input and output are in $c - - # Construct the tailcall-mangling expression the first time this function - # is called. - if (!defined($IA64_MATCH_TAILCALL)) { - # One-line pattern matching constructs. None of these - # should bind references; all parenthesized terms - # should be (?:) terms. - my $stop = q/(?:\t;;\n)/; - my $bundle = q/(?:\t\.(?:mii|mib|mmi|mmb|mfi|mfb|mbb|bbb)\n)/; - my $nop = q/(?:\tnop(?:\.[mifb])?\s+\d+\n)/; - my $movgp = q/(?:\tmov r1 = r\d+\n)/; - my $postbr = q/(?:\tbr \.L\d+\n)/; - - my $noeffect = "(?:$stop$bundle?|$nop)*"; - my $postbundle = "(?:$bundle?$nop?$nop?$postbr)?"; - - # Important parts of the pattern match. The branch target - # and subsequent jump label are bound to $1 and $2 - # respectively. Sometimes there is no label. - my $callbr = q/^\tbr\.call\.sptk\.many b0 = (.*)\n/; - my $label = q/(?:^\.L([0-9]*):\n)/; - my $tailcall = q/\t--- TAILCALL ---\n/; - - $IA64_MATCH_TAILCALL = - $callbr . $label . '?' . $noeffect . $movgp . '?' . $noeffect . - $tailcall . $stop . '?' . '(?:' . $postbundle . ')?'; - } - - # Find and mangle tailcalls - while ($c =~ s/$IA64_MATCH_TAILCALL/\tbr\.few $1\n/om) { - # Eek, the gcc optimiser is getting smarter... if we see a jump to the - # --- TAILCALL --- marker then we reapply the substitution at the source sites - $c =~ s/^\tbr \.L$2\n/\t--- TAILCALL ---\n/gm if ($2); - } - - # Verify that all instances of TAILCALL were processed - if ($c =~ /^\t--- TAILCALL ---\n/m) { - die "Unmangled TAILCALL tokens remain after mangling" - } -} -\end{code} - -The number of registers allocated on the IA64 register stack is set -upon entry to the runtime with an `alloc' instruction at the entry -point of \verb+StgRun()+. Gcc uses its own `alloc' to allocate -however many registers it likes in each function. When we discard -gcc's alloc, we have to reconcile its register assignment with what -the STG uses. - -There are three stack areas: fixed registers, input/local registers, -and output registers. We move the output registers to the output -register space and leave the other registers where they are. - -\begin{code} -sub ia64_rename_registers() { - # The text to be mangled is in $c - # Find number of registers in each stack area - my ($loc, $out) = @_; - my $cout; - my $first_out_reg; - my $regnum; - my $fragment; - - # These are the register numbers used in the STG runtime - my $STG_FIRST_OUT_REG = 32 + 34; - my $STG_LAST_OUT_REG = $STG_FIRST_OUT_REG + 7; - - $first_out_reg = 32 + $loc; - - if ($first_out_reg > $STG_FIRST_OUT_REG) { - die "Too many local registers allocated by gcc"; - } - - # Split the string into fragments containing one register name each. - # Rename the register in each fragment and concatenate. - $cout = ""; - foreach $fragment (split(/(?=r\d+[^a-zA-Z0-9_.])/sm, $c)) { - if ($fragment =~ /^r(\d+)((?:[^a-zA-Z0-9_.].*)?)$/sm) { - $regnum = $1; - - if ($regnum < $first_out_reg) { - # This is a local or fixed register - - # Local registers 32 and 33 (r64 and r65) are - # used to hold saved state; they shouldn't be touched - if ($regnum == 64 || $regnum == 65) { - die "Reserved register $regnum is in use"; - } - } - else { - # This is an output register - $regnum = $regnum - $first_out_reg + $STG_FIRST_OUT_REG; - if ($regnum > $STG_LAST_OUT_REG) { - die "Register number ($regnum) is out of expected range"; - } - } - - # Update this fragment - $fragment = "r" . $regnum . $2; - } - $cout .= $fragment; - } - - $c = $cout; -} - -\end{code} - -\begin{code} -sub hppa_mash_prologue { # OK, epilogue, too - local($_) = @_; - - # toss all prologue stuff - s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/m; - - # Lie about our .CALLINFO - s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/m; - - # Get rid of P' - - s/LP'/L'/gm; - s/RP'/R'/gm; - - # toss all epilogue stuff - s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/m; - - # Sorry; we moved the _info stuff to the code segment. - s/_info,DATA/_info,CODE/gm; - - return($_); -} -\end{code} - -\begin{code} -sub print_doctored { - local($_, $need_fallthru_patch) = @_; - - if ( $TargetPlatform =~ /^x86_64-/m ) { - # Catch things like - # - # movq -4(%ebp), %rax - # jmp *%rax - # - # and optimise: - # - s/^\tmovq\s+(-?\d*\(\%r(bx|bp|13)\)),\s*(\%r(ax|cx|dx|10|11))\n\tjmp\s+\*\3/\tjmp\t\*$1/gm; - s/^\tmovl\s+\$${T_US}(.*),\s*(\%e(ax|cx|si|di))\n\tjmp\s+\*\%r\3/\tjmp\t$T_US$1/gm; - } - - if ( $TargetPlatform !~ /^i386-/m - || ! /^\t[a-z]/m # no instructions in here, apparently - || /^${T_US}__stginit_[A-Za-z0-9_]+${T_POST_LBL}/m) { - print OUTASM $_; - return; - } - - # OK, must do some x86 **HACKING** - - local($entry_patch) = ''; - local($exit_patch) = ''; - - # gotta watch out for weird instructions that - # invisibly smash various regs: - # rep* %ecx used for counting - # scas* %edi used for destination index - # cmps* %e[sd]i used for indices - # loop* %ecx used for counting - # - # SIGH. - - # We cater for: - # * use of STG reg [ nn(%ebx) ] where no machine reg avail - # - # * GCC used an "STG reg" for its own purposes - # - # * some secret uses of machine reg, requiring STG reg - # to be saved/restored - - # The most dangerous "GCC uses" of an "STG reg" are when - # the reg holds the target of a jmp -- it's tricky to - # insert the patch-up code before we get to the target! - # So here we change the jmps: - - # -------------------------------------------------------- - # it can happen that we have jumps of the form... - # jmp * - # or - # jmp - # - # a reasonably-common case is: - # - # movl $_blah, - # jmp * - # - s/^\tmovl\s+\$${T_US}(.*),\s*(\%e[acd]x)\n\tjmp\s+\*\2/\tjmp $T_US$1/gm; - - # Catch things like - # - # movl -4(%ebx), %eax - # jmp *%eax - # - # and optimise: - # - s/^\tmovl\s+(-?\d*\(\%e(bx|si)\)),\s*(\%e[acd]x)\n\tjmp\s+\*\3/\tjmp\t\*$1/gm; - - if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi? - s/^\tmovl\s+(.*),\s*\%esi\n\tjmp\s+\*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*(.*\(.*\%esi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/gm; - die "$Pgm: (mangler) still have jump involving \%esi!\n$_" - if /(jmp|call)\s+.*\%esi/m; - } - if ($StolenX86Regs <= 3 ) { # spurious uses of edi? - s/^\tmovl\s+(.*),\s*\%edi\n\tjmp\s+\*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*(.*\(.*\%edi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/gm; - die "$Pgm: (mangler) still have jump involving \%edi!\n$_" - if /(jmp|call)\s+.*\%edi/m; - } - - # OK, now we can decide what our patch-up code is going to - # be: - - # Offsets into register table - you'd better update these magic - # numbers should you change its contents! - # local($OFFSET_R1)=0; No offset for R1 in new RTS. - local($OFFSET_Hp)=88; - - # Note funky ".=" stuff; we're *adding* to these _patch guys - if ( $StolenX86Regs <= 2 - && ( /[^0-9]\(\%ebx\)/m || /\%esi/m || /^\tcmps/m ) ) { # R1 (esi) - $entry_patch .= "\tmovl \%esi,(\%ebx)\n"; - $exit_patch .= "\tmovl (\%ebx),\%esi\n"; - - # nothing for call_{entry,exit} because %esi is callee-save - } - if ( $StolenX86Regs <= 3 - && ( /${OFFSET_Hp}\(\%ebx\)/m || /\%edi/m || /^\t(scas|cmps)/m ) ) { # Hp (edi) - $entry_patch .= "\tmovl \%edi,${OFFSET_Hp}(\%ebx)\n"; - $exit_patch .= "\tmovl ${OFFSET_Hp}(\%ebx),\%edi\n"; - - # nothing for call_{entry,exit} because %edi is callee-save - } - - # -------------------------------------------------------- - # next, here we go with non-%esp patching! - # - s/^(\t[a-z])/$entry_patch$1/m; # before first instruction - -# Before calling GC we must set up the exit condition before the call -# and entry condition when we come back - - # fix _all_ non-local jumps: - - if ( $TargetPlatform =~ /^.*-apple-darwin.*/m ) { - # On Darwin, we've got local-looking jumps that are - # actually global (i.e. jumps to Lfoo$stub or via - # Lfoo$non_lazy_ptr), so we fix those first. - # In fact, we just fix everything that contains a dollar - # because false positives don't hurt here. - - s/^(\tjmp\s+\*?L.*\$.*\n)/$exit_patch$1/gm; - } - - s/^\tjmp\s+\*${T_X86_PRE_LLBL_PAT}/\tJMP___SL/gom; - s/^\tjmp\s+${T_X86_PRE_LLBL_PAT}/\tJMP___L/gom; - - s/^(\tjmp\s+.*\n)/$exit_patch$1/gm; # here's the fix... - - s/^\tJMP___SL/\tjmp \*${T_X86_PRE_LLBL}/gom; - s/^\tJMP___L/\tjmp ${T_X86_PRE_LLBL}/gom; - - if ($StolenX86Regs == 2 ) { - die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_" - if /^\t(jmp|call)\s+.*\%e(si|di)/m; - } elsif ($StolenX86Regs == 3 ) { - die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_" - if /^\t(jmp|call)\s+.*\%edi/m; - } - - # -------------------------------------------------------- - # that's it -- print it - # - #die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia - - print OUTASM $_; - - if ( $need_fallthru_patch ) { # exit patch for end of slow entry code - print OUTASM $exit_patch; - # ToDo: make it not print if there is a "jmp" at the end - } -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - # use vars '%KNOWN_FUNNY_THING'; # Unused? - %KNOWN_FUNNY_THING = ( - # example - # "${T_US}stg_.*{T_POST_LBL}", 1, - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - # use vars '$discard1'; # Unused? - local($symb, $tbl, $discard1) = @_; - - return ($tbl) if ($TargetPlatform =~ /^ia64-/m - || $TABLES_NEXT_TO_CODE eq "NO"); - - local($before) = ''; - local($label) = ''; - local(@imports) = (); # hppa only - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/m, $tbl); - local($i, $j); - - # Deal with the header... - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?${T_DOT_WORD}\s+/om; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/om - || $lines[$i] =~ /${T_DOT_GLOBAL}/om - || $lines[$i] =~ /^${T_US}\S+_vtbl${T_POST_LBL}$/om; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - $infoname = $label; - $infoname =~ s/(.|\n)*^([A-Za-z0-9_]+_info)${T_POST_LBL}$(.|\n)*/$2/m; - - # Grab the table data... - if ( $TargetPlatform !~ /^hppa/m ) { - for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/om; $i++) { - $line = $lines[$i]; - # Convert addresses of SRTs, slow entrypoints and large bitmaps - # to offsets (relative to the info label), - # in order to support position independent code. - $line =~ s/$infoname/0/m - || $line =~ s/([A-Za-z0-9_]+_srtd)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_srt(\+\d+)?)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_str)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_slow)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_btm)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_alt)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_dflt)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_ret)$/$1 - $infoname/m; - push(@words, $line); - } - } else { # hppa weirdness - for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/m; $i++) { - # FIXME: the RTS now expects offsets instead of addresses - # for all labels in info tables. - if ($lines[$i] =~ /^\s+\.IMPORT/m) { - push(@imports, $lines[$i]); - } else { - # We don't use HP's ``function pointers'' - # We just use labels in code space, like normal people - $lines[$i] =~ s/P%//m; - push(@words, $lines[$i]); - } - } - } - - # Now throw away any initial zero word from the table. This is a hack - # that lets us reduce the size of info tables when the SRT field is not - # needed: see comments StgFunInfoTable in InfoTables.h. - # - # The .zero business is for Linux/ELF. - # The .skip business is for Sparc/Solaris/ELF. - # The .blockz business is for HPPA. -# if ($discard1) { -# if ($words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) { -# shift(@words); -# } -# } - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - # Alphas: If we have anonymous text (not part of a procedure), the - # linker may complain about missing exception information. Bleh. - # To suppress this, we place a .ent/.end pair around the code. - # At the same time, we have to be careful and not enclose any leading - # .file/.loc directives. - if ( $TargetPlatform =~ /^alpha-/m && $label =~ /^([A-Za-z0-9_]+):$/m) { - local ($ident) = $1; - $before =~ s/^((\s*\.(file|loc)\s+[^\n]*\n)*)/$1\t.ent $ident\n/m; - $after .= "\t.end $ident\n"; - } - - # Alphas: The heroic Simon Marlow found a bug in the Digital UNIX - # assembler (!) wherein .quad constants inside .text sections are - # first narrowed to 32 bits then sign-extended back to 64 bits. - # This obviously screws up our 64-bit bitmaps, so we work around - # the bug by replacing .quad with .align 3 + .long + .long [ccshan] - if ( $TargetPlatform =~ /^alpha-/m ) { - foreach (@words) { - if (/^\s*\.quad\s+([-+0-9].*\S)\s*$/m && length $1 >= 10) { - local ($number) = $1; - if ($number =~ /^([-+])?(0x?)?([0-9]+)$/m) { - local ($sign, $base, $digits) = ($1, $2, $3); - $base = (10, 8, 16)[length $base]; - local ($hi, $lo) = (0, 0); - foreach $i (split(//, $digits)) { - $j = $lo * $base + $i; - $lo = $j % 4294967296; - $hi = $hi * $base + ($j - $lo) / 4294967296; - } - ($hi, $lo) = (4294967295 - $hi, 4294967296 - $lo) - if $sign eq "-"; - $_ = "\t.align 3\n\t.long $lo\n\t.long $hi\n"; - # printf STDERR "TURNING %s into 0x %08x %08x\n", $number, $hi, $lo; - } else { - print STDERR "Cannot handle \".quad $number\" in info table\n"; - exit 1; - } - } - } - } - - if ( $TargetPlatform =~ /x86_64-apple-darwin/m ) { - # Tack a label to the front of the info table, too. - # For now, this just serves to work around a crash in Apple's new - # 64-bit linker (it seems to assume that there is no data before the - # first label in a section). - - # The plan for the future is to do this on all Darwin platforms, and - # to add a reference to this label after the entry code, just as the - # NCG does, so we can enable dead-code-stripping in the linker without - # losing our info tables. (Hence the name _dsp, for dead-strip preventer) - - $before .= "\n${infoname}_dsp:\n"; - } - - $tbl = $before - . (($TargetPlatform !~ /^hppa/m) ? '' : join("\n", @imports) . "\n") - . join("\n", @words) . "\n" - . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -The HP is a major nuisance. The threaded code mangler moved info -tables from data space to code space, but unthreaded code in the RTS -still has references to info tables in data space. Since the HP -linker is very precise about where symbols live, we need to patch the -references in the unthreaded RTS as well. - -\begin{code} -sub mini_mangle_asm_hppa { - local($in_asmf, $out_asmf) = @_; - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - while () { - s/_info,DATA/_info,CODE/m; # Move _info references to code space - s/P%_PR/_PR/m; - print OUTASM; - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} - -\end{code} - -\begin{code} -sub tidy_up_and_die { - local($return_val, $msg) = @_; - print STDERR $msg; - exit (($return_val == 0) ? 0 : 1); -} -\end{code} diff --git a/driver/mangler/ghc.mk b/driver/mangler/ghc.mk deleted file mode 100644 index c5e3bdf..0000000 --- a/driver/mangler/ghc.mk +++ /dev/null @@ -1,19 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture -# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -driver/mangler_PERL_SRC = ghc-asm.lprl -driver/mangler_dist_PROG = $(GHC_MANGLER_PGM) -driver/mangler_dist_TOPDIR = YES -driver/mangler_dist_INSTALL_IN = $(DESTDIR)$(topdir) - -$(eval $(call build-perl,driver/mangler,dist)) - diff --git a/extra-gcc-opts.in b/extra-gcc-opts.in deleted file mode 100644 index 8c9832c..0000000 --- a/extra-gcc-opts.in +++ /dev/null @@ -1 +0,0 @@ -@GccExtraViaCOpts@ diff --git a/ghc.mk b/ghc.mk index a41537f..b00d925 100644 --- a/ghc.mk +++ b/ghc.mk @@ -227,6 +227,7 @@ include rules/package-config.mk # ----------------------------------------------------------------------------- # Building dependencies +include rules/dependencies.mk include rules/build-dependencies.mk include rules/include-dependencies.mk @@ -544,7 +545,6 @@ BUILD_DIRS += \ ifneq "$(GhcUnregisterised)" "YES" BUILD_DIRS += \ - $(GHC_MANGLER_DIR) \ $(GHC_SPLIT_DIR) endif @@ -750,7 +750,7 @@ TAGS: TAGS_compiler # ----------------------------------------------------------------------------- # Installation -install: install_packages install_libs install_libexecs install_headers \ +install: install_libs install_packages install_libexecs install_headers \ install_libexec_scripts install_bins install_topdirs ifeq "$(HADDOCK_DOCS)" "YES" install: install_docs @@ -904,7 +904,7 @@ $(eval $(call bindist,.,\ README \ INSTALL \ configure config.sub config.guess install-sh \ - extra-gcc-opts.in \ + settings.in \ packages \ Makefile \ mk/config.mk.in \ @@ -933,7 +933,7 @@ $(eval $(call bindist,.,\ compiler/stage2/doc \ $(wildcard libraries/*/dist-install/doc/) \ $(wildcard libraries/*/*/dist-install/doc/) \ - $(filter-out extra-gcc-opts,$(INSTALL_LIBS)) \ + $(filter-out settings,$(INSTALL_LIBS)) \ $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \ mk/project.mk \ mk/install.mk.in \ @@ -954,7 +954,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk unix-binary-dist-prep: "$(RM)" $(RM_OPTS_REC) bindistprep/ "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR) - set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh extra-gcc-opts.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done + set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK) echo "LATEX_DOCS = $(LATEX_DOCS)" >> $(BIN_DIST_MK) echo "BUILD_DOCBOOK_HTML = $(BUILD_DOCBOOK_HTML)" >> $(BIN_DIST_MK) @@ -1043,7 +1043,7 @@ SRC_DIST_DIRS = mk rules docs distrib bindisttest libffi includes utils docs rts SRC_DIST_FILES += \ configure.ac config.guess config.sub configure \ aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \ - ghc.spec.in ghc.spec extra-gcc-opts.in VERSION \ + ghc.spec.in ghc.spec settings.in VERSION \ boot boot-pkgs packages ghc.mk SRC_DIST_TARBALL = $(SRC_DIST_NAME)-src.tar.bz2 @@ -1158,7 +1158,7 @@ distclean : clean "$(RM)" $(RM_OPTS) config.cache config.status config.log mk/config.h mk/stamp-h "$(RM)" $(RM_OPTS) mk/config.mk mk/are-validating.mk mk/project.mk "$(RM)" $(RM_OPTS) mk/config.mk.old mk/project.mk.old - "$(RM)" $(RM_OPTS) extra-gcc-opts docs/users_guide/ug-book.xml + "$(RM)" $(RM_OPTS) settings docs/users_guide/ug-book.xml "$(RM)" $(RM_OPTS) compiler/ghc.cabal compiler/ghc.cabal.old "$(RM)" $(RM_OPTS) ghc/ghc-bin.cabal "$(RM)" $(RM_OPTS) libraries/base/include/HsBaseConfig.h diff --git a/ghc.spec.in b/ghc.spec.in index c8eab26..2a70043 100644 --- a/ghc.spec.in +++ b/ghc.spec.in @@ -177,7 +177,6 @@ fi %{_prefix}/bin/ghci %{_prefix}/bin/ghci-%{version} %{_prefix}/bin/ghcprof -%{_prefix}/bin/hasktags %{_prefix}/bin/hp2ps %{_prefix}/bin/hpc %{_prefix}/bin/hsc2hs-ghc diff --git a/ghc/Main.hs b/ghc/Main.hs index da2a1f2..12d8dd2 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,7 +78,8 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - GHC.defaultErrorHandler defaultDynFlags $ do + let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings") + GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -358,9 +359,6 @@ showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions -printMode :: String -> Mode -printMode str = mkPreStartupMode (Print str) - mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left @@ -383,8 +381,10 @@ showGhcUsageMode = mkPreLoadMode ShowGhcUsage showGhciUsageMode = mkPreLoadMode ShowGhciUsage showInfoMode = mkPreLoadMode ShowInfo -printWithDynFlagsMode :: (DynFlags -> String) -> Mode -printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f) +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) mkPreLoadMode :: PreLoadMode -> Mode mkPreLoadMode = Right . Left @@ -504,14 +504,30 @@ mode_flags = , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ - [ Flag k' (PassFlag (setMode mode)) - | (k, v) <- compilerInfo, + [ Flag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "Gcc Linker flags", + "Ld Linker flags"], let k' = "-print-" ++ map (replaceSpace . toLower) k replaceSpace ' ' = '-' replaceSpace c = c - mode = case v of - String str -> printMode str - FromDynFlags f -> printWithDynFlagsMode f ] ++ ------- interfaces ---------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) @@ -591,7 +607,7 @@ doMake srcs = do haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -649,9 +665,7 @@ showBanner _postLoadMode dflags = do showInfo :: DynFlags -> IO () showInfo dflags = do let sq x = " [" ++ x ++ "\n ]" - putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo - where flatten (k, String v) = (k, v) - flatten (k, FromDynFlags f) = (k, f dflags) + putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags showSupportedExtensions :: IO () showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 420c918..61b7b34 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -14,7 +14,7 @@ Description: XXX Category: XXX Data-Dir: .. -Data-Files: extra-gcc-opts +Data-Files: settings Build-Type: Simple Cabal-Version: >= 1.2 diff --git a/ghc/ghc.mk b/ghc/ghc.mk index cd2a027..da9fd8a 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -108,24 +108,26 @@ all_ghc_stage1 : $(GHC_STAGE1) all_ghc_stage2 : $(GHC_STAGE2) all_ghc_stage3 : $(GHC_STAGE3) -$(INPLACE_LIB)/extra-gcc-opts : extra-gcc-opts +$(INPLACE_LIB)/settings : settings "$(CP)" $< $@ -# The GHC programs need to depend on all the helper programs they might call +# The GHC programs need to depend on all the helper programs they might call, +# and the settings files they use + +$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/settings +$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/settings + ifeq "$(GhcUnregisterised)" "NO" -$(GHC_STAGE1) : $(MANGLER) $(SPLIT) -$(GHC_STAGE2) : $(MANGLER) $(SPLIT) -$(GHC_STAGE3) : $(MANGLER) $(SPLIT) +$(GHC_STAGE1) : | $(SPLIT) +$(GHC_STAGE2) : | $(SPLIT) +$(GHC_STAGE3) : | $(SPLIT) endif -$(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE2) : $(INPLACE_LIB)/extra-gcc-opts -$(GHC_STAGE3) : $(INPLACE_LIB)/extra-gcc-opts - ifeq "$(Windows)" "YES" -$(GHC_STAGE1) : $(TOUCHY) -$(GHC_STAGE2) : $(TOUCHY) -$(GHC_STAGE3) : $(TOUCHY) +$(GHC_STAGE1) : | $(TOUCHY) +$(GHC_STAGE2) : | $(TOUCHY) +$(GHC_STAGE3) : | $(TOUCHY) endif ifeq "$(BootingFromHc)" "YES" @@ -135,7 +137,7 @@ endif endif -INSTALL_LIBS += extra-gcc-opts +INSTALL_LIBS += settings ifeq "$(Windows)" "NO" install: install_ghc_link diff --git a/ghc/ghc.wrapper b/ghc/ghc.wrapper index 5003f9a..083a66d 100644 --- a/ghc/ghc.wrapper +++ b/ghc/ghc.wrapper @@ -1 +1 @@ -exec "$executablename" -B"$topdir" -pgmc "$pgmgcc" -pgma "$pgmgcc" -pgml "$pgmgcc" -pgmP "$pgmgcc -E -undef -traditional" ${1+"$@"} +exec "$executablename" -B"$topdir" ${1+"$@"} diff --git a/ghc/hschooks.c b/ghc/hschooks.c index 4878021..1867928 100644 --- a/ghc/hschooks.c +++ b/ghc/hschooks.c @@ -20,7 +20,6 @@ defaultsHook (void) RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE; RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_); RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; - RtsFlags.GcFlags.statsFile = stderr; // See #3408: the default idle GC time of 0.3s is too short on // Windows where we receive console events once per second or so. diff --git a/includes/RtsFlags.h b/includes/RtsFlags.h deleted file mode 100644 index a6b4d2c..0000000 --- a/includes/RtsFlags.h +++ /dev/null @@ -1,5 +0,0 @@ -#ifndef MAKING_GHC_BUILD_SYSTEM_DEPENDENCIES -#warning RtsFlags.h is DEPRECATED; please just #include "Rts.h" -#endif - -#include "Rts.h" diff --git a/includes/RtsOpts.h b/includes/RtsOpts.h index e81a41c..b8eab68 100644 --- a/includes/RtsOpts.h +++ b/includes/RtsOpts.h @@ -9,8 +9,12 @@ #ifndef RTSOPTS_H #define RTSOPTS_H -typedef enum {rtsOptsNone, rtsOptsSafeOnly, rtsOptsAll} rtsOptsEnabledEnum; +typedef enum { + RtsOptsNone, // +RTS causes an error + RtsOptsSafeOnly, // safe RTS options allowed; others cause an error + RtsOptsAll // all RTS options allowed + } RtsOptsEnabledEnum; -extern const rtsOptsEnabledEnum rtsOptsEnabled; +extern const RtsOptsEnabledEnum rtsOptsEnabled; #endif /* RTSOPTS_H */ diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 95ccfc0..b4e7b64 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -219,13 +219,6 @@ extern RTS_FLAGS RtsFlags[]; extern RTS_FLAGS RtsFlags; #endif -/* Routines that operate-on/to-do-with RTS flags: */ - -void initRtsFlagsDefaults(void); -void setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]); -void setProgName(char *argv[]); - - /* * The printf formats are here, so we are less likely to make * overly-long filenames (with disastrous results). No more than 128 diff --git a/includes/rts/Hpc.h b/includes/rts/Hpc.h index 26da35d..bceb81c 100644 --- a/includes/rts/Hpc.h +++ b/includes/rts/Hpc.h @@ -18,16 +18,16 @@ typedef struct _HpcModuleInfo { char *modName; // name of module StgWord32 tickCount; // number of ticks - StgWord32 tickOffset; // offset into a single large .tix Array - StgWord32 hashNo; // Hash number for this module's mix info + StgWord32 hashNo; // Hash number for this module's mix info StgWord64 *tixArr; // tix Array; local for this module + rtsBool from_file; // data was read from the .tix file struct _HpcModuleInfo *next; } HpcModuleInfo; -int hs_hpc_module (char *modName, - StgWord32 modCount, - StgWord32 modHashNo, - StgWord64 *tixArr); +void hs_hpc_module (char *modName, + StgWord32 modCount, + StgWord32 modHashNo, + StgWord64 *tixArr); HpcModuleInfo * hs_hpc_rootModule (void); diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index e6cfc47..ed0bf65 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -383,6 +383,7 @@ RTS_FUN_DECL(stg_newArrayzh); RTS_FUN_DECL(stg_newMutVarzh); RTS_FUN_DECL(stg_atomicModifyMutVarzh); +RTS_FUN_DECL(stg_casMutVarzh); RTS_FUN_DECL(stg_isEmptyMVarzh); RTS_FUN_DECL(stg_newMVarzh); diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h index ad8c0ba..52fd6f1 100644 --- a/includes/stg/SMP.h +++ b/includes/stg/SMP.h @@ -306,6 +306,7 @@ load_load_barrier(void) { #define store_load_barrier() /* nothing */ #define load_load_barrier() /* nothing */ +#if !IN_STG_CODE || IN_STGCRUN INLINE_HEADER StgWord xchg(StgPtr p, StgWord w) { @@ -314,7 +315,8 @@ xchg(StgPtr p, StgWord w) return old; } -STATIC_INLINE StgWord +EXTERN_INLINE StgWord cas(StgVolatilePtr p, StgWord o, StgWord n); +EXTERN_INLINE StgWord cas(StgVolatilePtr p, StgWord o, StgWord n) { StgWord result; @@ -336,6 +338,7 @@ atomic_dec(StgVolatilePtr p) { return --(*p); } +#endif #define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p))) diff --git a/libffi/ghc.mk b/libffi/ghc.mk index 080c43f..f7caeda 100644 --- a/libffi/ghc.mk +++ b/libffi/ghc.mk @@ -34,8 +34,6 @@ # # We use libffi's own configuration stuff. -PLATFORM := $(shell echo $(HOSTPLATFORM) | sed 's/i[567]86/i486/g') - # 2007-07-05 # Passing # as_ln_s='cp -p' @@ -116,16 +114,16 @@ $(libffi_STAMP_CONFIGURE): PATH=`pwd`:$$PATH; \ export PATH; \ cd build && \ - CC=$(WhatGccIsCalled) \ + CC=$(CC_STAGE1) \ LD=$(LD) \ - AR=$(AR) \ + AR=$(AR_STAGE1) \ NM=$(NM) \ CFLAGS="$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -w" \ LDFLAGS="$(SRC_LD_OPTS) $(CONF_GCC_LINKER_OPTS_STAGE1) -w" \ "$(SHELL)" configure \ --enable-static=yes \ --enable-shared=$(libffi_EnableShared) \ - --host=$(PLATFORM) --build=$(PLATFORM) + --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) # libffi.so needs to be built with the correct soname. # NOTE: this builds libffi_convience.so with the incorrect @@ -179,7 +177,7 @@ $(eval $(call all-target,libffi,$(INSTALL_HEADERS) $(INSTALL_LIBS))) libffi/dist-install/build/HSffi.o: libffi/dist-install/build/libHSffi.a cd libffi/dist-install/build && \ touch empty.c && \ - "$(CC)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o + "$(CC_STAGE1)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o $(eval $(call all-target,libffi,libffi/dist-install/build/HSffi.o)) @@ -227,4 +225,3 @@ $(eval $(call manual-package-config,libffi)) # binary-dist BINDIST_EXTRAS += libffi/package.conf.in - diff --git a/libraries/Makefile.common b/libraries/Makefile.common deleted file mode 100644 index 8fe1462..0000000 --- a/libraries/Makefile.common +++ /dev/null @@ -1,118 +0,0 @@ -# This Makefile.common is used only in an nhc98 build of the libraries. -# It is included from each package's individual Makefile.nhc98. -# We assume the following definitions have already been made in -# the importing Makefile. -# -# THISPKG = e.g. mypkg -# SEARCH = e.g. -P../IO -P../PreludeIO -package base -# SRCS = all .hs .gc and .c files -# -# EXTRA_H_FLAGS = e.g. -prelude -# EXTRA_C_FLAGS = e.g. -I../Binary -include ../Makefile.inc - -# nasty hack - replace flags for ghc, nhc98, with hbc specific ones -ifeq "hbc" "${BUILDCOMP}" -EXTRA_H_FLAGS := ${EXTRA_HBC_FLAGS} -endif - -DIRS = $(shell ${LOCAL}pkgdirlist ${THISPKG}) - -OBJDIR = ${BUILDDIR}/${OBJ}/libraries/${THISPKG} -OBJDIRS = $(patsubst %, ${OBJDIR}/%, ${DIRS}) -FINALLIB = ${DST}/libHS${THISPKG}.$A -INCDIRS = ${INCDIR}/packages/${THISPKG} \ - $(patsubst %, ${INCDIR}/packages/${THISPKG}/%, ${DIRS}) -.SUFFIXES: .hi .hs .lhs .o .gc .c .hc .p.o .p.c .z.o .z.c .hsc - -SRCS_HS = $(filter %.hs, ${SRCS}) -SRCS_LHS = $(filter %.lhs,${SRCS}) -SRCS_GC = $(filter %.gc, ${SRCS}) -SRCS_HSC = $(filter %.hsc,${SRCS}) -SRCS_C = $(filter %.c, ${SRCS}) -SRCS_HASK= $(SRCS_HS) $(SRCS_LHS) $(SRCS_GC) $(SRCS_HSC) - -OBJS_HS = $(patsubst %.hs, ${OBJDIR}/%.$O, ${SRCS_HS}) -OBJS_LHS = $(patsubst %.lhs,${OBJDIR}/%.$O, ${SRCS_LHS}) -OBJS_GC = $(patsubst %.gc, ${OBJDIR}/%.$O, ${SRCS_GC}) -OBJS_HSC = $(patsubst %.hsc,${OBJDIR}/%.$O, ${SRCS_HSC}) -OBJS_C = $(patsubst %.c, ${OBJDIR}/%.$O, ${SRCS_C}) -OBJS_HASK= ${OBJS_HS} ${OBJS_LHS} ${OBJS_GC} ${OBJS_HSC} -OBJS = $(OBJS_HASK) $(OBJS_C) - -CFILES_HS = $(patsubst %.hs, %.$C, ${SRCS_HS}) -CFILES_LHS = $(patsubst %.lhs,%.$C, ${SRCS_LHS}) -CFILES_GC = $(patsubst %.gc, %.$C, ${SRCS_GC}) -CFILES_XS = $(patsubst %.gc, %_.$C, ${SRCS_GC}) \ - $(patsubst %.gc, %_.hs, ${SRCS_GC}) -CFILES_HSC = $(patsubst %.hsc,%.$C, ${SRCS_HSC}) -CFILES_GEN = ${CFILES_HS} ${CFILES_LHS} ${CFILES_GC} ${CFILES_HSC} - -ifeq "p" "${PROFILING}" -HC += -p -endif - -ifeq "z" "${TPROF}" -HC += -z -endif - -all: ${OBJDIR} ${OBJDIRS} ${INCDIRS} extra ${OBJS} ${FINALLIB} -extra: -cfiles: extracfiles ${CFILES_GEN} -extracfiles: -fromC: ${OBJDIR} ${OBJS_C} ${OBJDIRS} - $(HC) -c -d $(OBJDIR) $(EXTRA_C_FLAGS) ${SEARCH} ${CFILES_GEN} - echo $(OBJS) | xargs ar cr ${FINALLIB} -objdir: ${OBJDIR} ${OBJDIRS} ${INCDIRS} -${OBJDIR} ${OBJDIRS} ${INCDIRS}: - mkdir -p $@ -${FINALLIB}: ${OBJS} - echo $(OBJS) | xargs ar cr $@ -cleanhi: - -rm -f $(patsubst %, %/*.hi, ${DIRS}) -cleanC: cleanExtraC - -rm -f ${CFILES_GEN} ${CFILES_XS} -clean: cleanhi - -rm -f $(patsubst %, ${OBJDIR}/%/*.$O, ${DIRS}) - -rm -f $(patsubst %.gc, %_.hs, $(filter %.gc, $(SRCS))) - -rm -f $(patsubst %.gc, %_.$C, $(filter %.gc, $(SRCS))) -cleanExtraC: - -# general build rules for making objects from Haskell files -$(OBJS_HASK): #$(OBJDIR) $(OBJDIRS) $(SRCS_HASK) - $(LOCAL)hmake -hc=$(HC) -hidir $(INCDIR)/packages/$(THISPKG) \ - $(SEARCH) $(EXTRA_H_FLAGS) -d$(OBJDIR) \ - $(SRCS_HASK) -${OBJS_HS}: ${OBJDIR}/%.$O : %.hs -${OBJS_LHS}: ${OBJDIR}/%.$O : %.lhs -${OBJS_GC}: ${OBJDIR}/%.$O : %.gc -${OBJS_HSC}: ${OBJDIR}/%.$O : %.hsc - -# general build rule for making objects from C files -${OBJS_C}: ${OBJDIR}/%.$O : cbits/%.c - $(CC) -c -I$(INCDIR) $(ENDIAN) $(filter -I%, ${SEARCH}) \ - $(EXTRA_C_FLAGS) -o $@ $< - -# general build rules for making bootstrap C files from Haskell files -$(CFILES_GEN): - $(LOCAL)hmake -hc=$(HC) -C -hidir $(INCDIR)/packages/$(THISPKG) \ - $(SEARCH) $(EXTRA_H_FLAGS) \ - $(SRCS_HASK) -${CFILES_HS}: %.$C : %.hs -${CFILES_LHS}: %.$C : %.lhs -${CFILES_GC}: %.$C : %.gc -${CFILES_HSC}: %.$C : %.hsc - -# hack to get round mutual recursion between libraries -HIFILES = $(patsubst %.hs,../${THISLIB}/%.${HISUFFIX},$(filter %.hs, ${SRCS})) -${HIFILES}: ../${THISLIB}/%.${HISUFFIX} : %.hs - $(HC) -c $(PART_FLAGS) -o /dev/null $< - -# The importing Makefile may now define extra individual dependencies -# e.g. -# ${OBJDIR}/Function.$O: Function.hs ${OBJDIR}/Other.$O -# -# and C-files dependencies likewise -# e.g. -# AlignBin.c: BinHandle.c - diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc deleted file mode 100644 index 0b54f52..0000000 --- a/libraries/Makefile.inc +++ /dev/null @@ -1,8 +0,0 @@ -ifeq "" "${MKDIR}" -MKDIR:=$(shell pwd) -#MKDIR:=$(PWD) -else -MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) -endif -include ${MKDIR}/Makefile.inc - diff --git a/libraries/Makefile.local b/libraries/Makefile.local deleted file mode 100644 index 84b90a6..0000000 --- a/libraries/Makefile.local +++ /dev/null @@ -1,38 +0,0 @@ -# Local GHC-build-tree customization for Cabal makefiles. We want to build -# libraries using flags that the user has put in build.mk/validate.mk and -# appropriate flags for Mac OS X deployment targets. - -# Careful here: including boilerplate.mk breaks things, because paths.mk and -# opts.mk overrides some of the variable settings in the Cabal Makefile, so -# we just include config.mk and custom-settings.mk. -include ../defineTOP.mk -SAVE_GHC := $(GHC) -SAVE_AR := $(AR) -SAVE_LD := $(LD) -include $(TOP)/mk/config.mk -include $(TOP)/mk/custom-settings.mk -GHC := $(SAVE_GHC) -AR := $(SAVE_AR) -LD := $(SAVE_LD) - -# We want all warnings on -GhcLibHcOpts += -Wall - -# Cabal has problems with deprecated flag warnings, as it needs to pass -# deprecated flags in pragmas in order to support older GHCs. Thus for -# now at least we just disable them completely. -GhcLibHcOpts += -fno-warn-deprecated-flags - -ifeq "$(filter-out Win32-% dph%,$(package))" "" -# XXX We are one of the above list, i.e. we are a package that is not -# yet warning-clean. Thus turn warnings off for now so that validate -# goes through. -GhcLibHcOpts += -w -endif - -# Now add flags from the GHC build system to the Cabal build: -GHC_OPTS += $(SRC_HC_OPTS) -GHC_OPTS += $(GhcLibHcOpts) - -include $(TOP)/mk/bindist.mk - diff --git a/libraries/gen_contents_index b/libraries/gen_contents_index index fcf30e3..04209fd 100644 --- a/libraries/gen_contents_index +++ b/libraries/gen_contents_index @@ -7,7 +7,7 @@ HADDOCK_ARGS= case $* in --inplace) HADDOCK=../inplace/bin/haddock - for LIB in `grep '^libraries/[^ ]\+ \+- \+[^ ]\+ \+[^ ]\+ \+[^ ]\+' ../packages | sed -e 's#libraries/##' -e 's/ .*//'` + for LIB in `grep '^libraries/[^ ]* *- ' ../packages | sed -e 's#libraries/##' -e 's/ .*//'` do HADDOCK_FILE="$LIB/dist-install/doc/html/$LIB/$LIB.haddock" if [ -f "$HADDOCK_FILE" ] diff --git a/libraries/tarballs/time-1.2.0.3.tar.gz b/libraries/tarballs/time-1.2.0.3.tar.gz deleted file mode 100644 index 525b019..0000000 Binary files a/libraries/tarballs/time-1.2.0.3.tar.gz and /dev/null differ diff --git a/libraries/tarballs/time-1.2.0.4.tar.gz b/libraries/tarballs/time-1.2.0.4.tar.gz new file mode 100644 index 0000000..6bbbd75 Binary files /dev/null and b/libraries/tarballs/time-1.2.0.4.tar.gz differ diff --git a/mk/build.mk.sample b/mk/build.mk.sample index a7764e2..216ca66 100644 --- a/mk/build.mk.sample +++ b/mk/build.mk.sample @@ -136,15 +136,6 @@ endif # ----------------------------------------------------------------------------- # Other settings that might be useful -# profiled RTS -#GhcRtsCcOpts = -pg -g - -# Optimised/profiled RTS -#GhcRtsCcOpts = -O2 -pg - -#GhcRtsWithFrontPanel = YES -#SRC_HC_OPTS += `gtk-config --libs` - # NoFib settings NoFibWays = STRIP_CMD = : diff --git a/mk/config.mk.in b/mk/config.mk.in index b478997..3749bce 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -97,6 +97,16 @@ GhcStage1HcOpts= GhcStage2HcOpts=-O2 GhcStage3HcOpts=-O2 +# These options modify whether or not a built compiler for a bootstrap +# stage defaults to using the new code generation path. The new +# code generation path is a bit slower, so for development just +# GhcStage2DefaultNewCodegen=YES, but it's also a good idea to try +# building all libraries and the stage2 compiler with the +# new code generator, which involves GhcStage1DefaultNewCodegen=YES. +GhcStage1DefaultNewCodegen=NO +GhcStage2DefaultNewCodegen=NO +GhcStage3DefaultNewCodegen=NO + GhcDebugged=NO GhcDynamic=NO @@ -104,13 +114,18 @@ GhcDynamic=NO GhcProfiled=NO # Do we support shared libs? -PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ - i386-unknown-linux x86_64-unknown-linux \ +SharedLibsPlatformList = i386-unknown-linux x86_64-unknown-linux \ i386-unknown-freebsd x86_64-unknown-freebsd \ i386-unknown-openbsd x86_64-unknown-openbsd \ i386-unknown-mingw32 \ - i386-unknown-solaris2 \ - i386-apple-darwin powerpc-apple-darwin),YES,NO) + i386-apple-darwin powerpc-apple-darwin + +ifeq ($(SOLARIS_BROKEN_SHLD), NO) +SharedLibsPlatformList := $(SharedLibsPlatformList) i386-unknown-solaris2 +endif + +PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ + $(SharedLibsPlatformList)),YES,NO) # Build a compiler that will build *unregisterised* libraries and # binaries by default. Unregisterised code is supposed to compile and @@ -425,7 +440,6 @@ GHC_HP2PS_PGM = hp2ps$(exeext) GHC_GHCTAGS_PGM = ghctags$(exeext) GHC_HSC2HS_PGM = hsc2hs$(exeext) GHC_TOUCHY_PGM = touchy$(exeext) -GHC_MANGLER_PGM = ghc-asm GHC_SPLIT_PGM = ghc-split GHC_SYSMAN_PGM = SysMan GHC_GENPRIMOP_PGM = genprimopcode$(exeext) @@ -445,7 +459,6 @@ GHC_PERL = $(PERL) endif HP2PS = $(GHC_HP2PS_DIR)/$(GHC_HP2PS_PGM) -MANGLER = $(INPLACE_LIB)/$(GHC_MANGLER_PGM) SPLIT = $(INPLACE_LIB)/$(GHC_SPLIT_PGM) SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM) LTX = $(GHC_LTX_DIR)/$(GHC_LTX_PGM) @@ -527,18 +540,19 @@ endif # the flag --with-gcc= instead. The reason is that the configure script # needs to know which gcc you're using in order to perform its tests. -HaveGcc = @HaveGcc@ -UseGcc = YES WhatGccIsCalled = @WhatGccIsCalled@ GccVersion = @GccVersion@ -GccLT34 = @GccLT34@ -ifeq "$(strip $(HaveGcc))" "YES" -ifneq "$(strip $(UseGcc))" "YES" - CC = cc -else - CC = $(WhatGccIsCalled) -endif -endif +GccLT34 = @GccLT34@ +CC = $(WhatGccIsCalled) +CC_STAGE0 = @CC_STAGE0@ +CC_STAGE1 = $(CC) +CC_STAGE2 = $(CC) +CC_STAGE3 = $(CC) +AS = $(WhatGccIsCalled) +AS_STAGE0 = @CC_STAGE0@ +AS_STAGE1 = $(AS) +AS_STAGE2 = $(AS) +AS_STAGE3 = $(AS) # C compiler and linker flags from configure (e.g. -m to select # correct C compiler backend). The stage number is the stage of GHC @@ -588,10 +602,24 @@ DLLTOOL = inplace/mingw/bin/dlltool.exe AR = @ArCmd@ AR_OPTS = @ArArgs@ -ArSupportsInput = @ArSupportsInput@ ArSupportsAtFile = @ArSupportsAtFile@ -# Yuckage: for ghc/utils/parallel -- todo: nuke this dependency!! -BASH = /usr/local/bin/bash + +AR_STAGE0 = @AR_STAGE0@ +AR_STAGE1 = $(AR) +AR_STAGE2 = $(AR) +AR_STAGE3 = $(AR) +AR_OPTS_STAGE0 = @AR_OPTS_STAGE0@ +AR_OPTS_STAGE1 = $(AR_OPTS) +AR_OPTS_STAGE2 = $(AR_OPTS) +AR_OPTS_STAGE3 = $(AR_OPTS) +EXTRA_AR_ARGS_STAGE0 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE1 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE2 = $(EXTRA_AR_ARGS) +EXTRA_AR_ARGS_STAGE3 = $(EXTRA_AR_ARGS) +ArSupportsAtFile_STAGE0 = @ArSupportsAtFile_STAGE0@ +ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile) CONTEXT_DIFF = @ContextDiffCmd@ CP = cp @@ -624,7 +652,6 @@ NROFF = nroff PERL = @PerlCmd@ PYTHON = @PythonCmd@ PIC = pic -PREPROCESSCMD = $(CC) -E RANLIB = @RANLIB@ SED = @SedCmd@ TR = tr @@ -646,6 +673,10 @@ LD_X = @LdXFlag@ # overflowing command-line length limits. LdIsGNULd = @LdIsGNULd@ +# Set to YES if ld has the --build-id flag. Sometimes we need to +# disable it with --build-id=none. +LdHasBuildId = @LdHasBuildId@ + # On MSYS, building with SplitObjs=YES fails with # ar: Bad file number # see #3201. We need to specify a smaller max command-line size @@ -743,8 +774,6 @@ ALEX_VERSION = @AlexVersion@ # SRC_ALEX_OPTS = -g -HSTAGS = @HstagsCmd@ - # Should we build haddock docs? HADDOCK_DOCS = YES # And HsColour the sources? diff --git a/mk/project.mk.in b/mk/project.mk.in index 3ceef15..58b0f1a 100644 --- a/mk/project.mk.in +++ b/mk/project.mk.in @@ -139,3 +139,7 @@ endif # This distinguishes "msys" and "cygwin", which are not # not distinguished by HOST_OS_CPP OSTYPE=@OSTYPE@ + +# In case of Solaris OS, does it provide broken shared libs +# linker or not? +SOLARIS_BROKEN_SHLD=@SOLARIS_BROKEN_SHLD@ diff --git a/mk/tree.mk b/mk/tree.mk index 3aa8527..2010c36 100644 --- a/mk/tree.mk +++ b/mk/tree.mk @@ -36,7 +36,6 @@ GHC_PKG_DIR = $(GHC_UTILS_DIR)/ghc-pkg GHC_GENPRIMOP_DIR = $(GHC_UTILS_DIR)/genprimopcode GHC_GENAPPLY_DIR = $(GHC_UTILS_DIR)/genapply GHC_CABAL_DIR = $(GHC_UTILS_DIR)/ghc-cabal -GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split GHC_SYSMAN_DIR = $(GHC_RTS_DIR)/parallel diff --git a/packages.git b/packages.git deleted file mode 100644 index 0af091c..0000000 --- a/packages.git +++ /dev/null @@ -1,85 +0,0 @@ -# Despite the name "package", this file contains the master list of -# the *repositories* that make up GHC. It is parsed by boot and darcs-all. -# -# Some of this information is duplicated elsewhere in the build system: -# See Trac #3896 -# In particular when adding libraries to this file, you also need to add -# the library to the SUBDIRS variable in libraries/Makefile so that they -# actually get built -# -# The repos are of several kinds: -# - The main GHC source repo -# - Each boot package lives in a repo -# - DPH is a repo that contains several packages -# - Haddock and hsc2hs are applications, built on top of GHC, -# and in turn needed to bootstrap GHC -# - ghc-tarballs is need to build GHC -# - nofib and testsuite are optional helpers -# -# The format of the lines in this file is: -# localpath tag remotepath VCS upstream -# where -# * 'localpath' is where to put the repository in a checked out tree. -# * 'remotepath' is where the repository is in the central repository. -# * 'VCS' is what version control system the repo uses. -# -# * The 'tag' determines when "darcs-all get" will get the -# repo. If the tag is "-" then it will always get it, but if there -# is a tag then a corresponding flag must be given to darcs-all, e.g. -# if you want to get the packages with an "extralibs" or "testsuite" -# tag then you need to use "darcs-all --extra --testsuite get". -# Support for new tags must be manually added to the darcs-all script. -# -# 'tag' is also used to determine which packages the build system -# deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra' -# both give this property -# -# * 'upstream' is the URL of the upstream repo, where there is one, or -# "-" if there is no upstream. -# -# Lines that start with a '#' are comments. -. - ghc.git git - -ghc-tarballs - ghc-tarballs darcs - -utils/hsc2hs - hsc2hs darcs - -# haddock does have an upstream: -# http://code.haskell.org/haddock/ -# but it stays buildable with the last stable release rather than tracking HEAD, -# and is resynced with the GHC HEAD branch by David Waern when appropriate -utils/haddock - haddock2 darcs - -libraries/array - packages/array darcs - -libraries/base - packages/base darcs - -libraries/binary - packages/binary darcs http://code.haskell.org/binary/ -libraries/bytestring - packages/bytestring darcs http://darcs.haskell.org/bytestring/ -libraries/Cabal - packages/Cabal darcs http://darcs.haskell.org/cabal/ -libraries/containers - packages/containers darcs - -libraries/directory - packages/directory darcs - -libraries/extensible-exceptions - packages/extensible-exceptions darcs - -libraries/filepath - packages/filepath darcs - -libraries/ghc-prim - packages/ghc-prim darcs - -libraries/haskeline - packages/haskeline darcs http://code.haskell.org/haskeline/ -libraries/haskell98 - packages/haskell98 darcs - -libraries/haskell2010 - packages/haskell2010 darcs - -libraries/hoopl - packages/hoopl darcs - -libraries/hpc - packages/hpc darcs - -libraries/integer-gmp - packages/integer-gmp darcs - -libraries/integer-simple - packages/integer-simple darcs - -libraries/mtl - packages/mtl darcs - -libraries/old-locale - packages/old-locale darcs - -libraries/old-time - packages/old-time darcs - -libraries/pretty - packages/pretty darcs - -libraries/process - packages/process darcs - -libraries/random - packages/random darcs - -libraries/template-haskell - packages/template-haskell darcs - -libraries/terminfo - packages/terminfo darcs http://code.haskell.org/terminfo/ -libraries/unix - packages/unix darcs - -libraries/utf8-string - packages/utf8-string darcs http://code.haskell.org/utf8-string/ -libraries/Win32 - packages/Win32 darcs - -libraries/xhtml - packages/xhtml darcs - -testsuite testsuite testsuite darcs - -nofib nofib nofib darcs - -libraries/deepseq extra packages/deepseq darcs - -libraries/parallel extra packages/parallel darcs - -libraries/stm extra packages/stm darcs - -libraries/primitive dph packages/primitive darcs http://code.haskell.org/primitive -libraries/vector dph packages/vector darcs http://code.haskell.org/vector -libraries/dph dph packages/dph darcs - diff --git a/rts/Capability.c b/rts/Capability.c index bffb735..9091fdd 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -842,11 +842,9 @@ freeCapabilities (void) ------------------------------------------------------------------------ */ void -markSomeCapabilities (evac_fn evac, void *user, nat i0, nat delta, - rtsBool no_mark_sparks USED_IF_THREADS) +markCapability (evac_fn evac, void *user, Capability *cap, + rtsBool no_mark_sparks USED_IF_THREADS) { - nat i; - Capability *cap; InCall *incall; // Each GC thread is responsible for following roots from the @@ -854,39 +852,31 @@ markSomeCapabilities (evac_fn evac, void *user, nat i0, nat delta, // or fewer Capabilities as GC threads, but just in case there // are more, we mark every Capability whose number is the GC // thread's index plus a multiple of the number of GC threads. - for (i = i0; i < n_capabilities; i += delta) { - cap = &capabilities[i]; - evac(user, (StgClosure **)(void *)&cap->run_queue_hd); - evac(user, (StgClosure **)(void *)&cap->run_queue_tl); + evac(user, (StgClosure **)(void *)&cap->run_queue_hd); + evac(user, (StgClosure **)(void *)&cap->run_queue_tl); #if defined(THREADED_RTS) - evac(user, (StgClosure **)(void *)&cap->inbox); + evac(user, (StgClosure **)(void *)&cap->inbox); #endif - for (incall = cap->suspended_ccalls; incall != NULL; - incall=incall->next) { - evac(user, (StgClosure **)(void *)&incall->suspended_tso); - } + for (incall = cap->suspended_ccalls; incall != NULL; + incall=incall->next) { + evac(user, (StgClosure **)(void *)&incall->suspended_tso); + } #if defined(THREADED_RTS) - if (!no_mark_sparks) { - traverseSparkQueue (evac, user, cap); - } -#endif + if (!no_mark_sparks) { + traverseSparkQueue (evac, user, cap); } +#endif -#if !defined(THREADED_RTS) - evac(user, (StgClosure **)(void *)&blocked_queue_hd); - evac(user, (StgClosure **)(void *)&blocked_queue_tl); - evac(user, (StgClosure **)(void *)&sleeping_queue); -#endif + // Free STM structures for this Capability + stmPreGCHook(cap); } void markCapabilities (evac_fn evac, void *user) { - markSomeCapabilities(evac, user, 0, 1, rtsFalse); + nat n; + for (n = 0; n < n_capabilities; n++) { + markCapability(evac, user, &capabilities[n], rtsFalse); + } } - -/* ----------------------------------------------------------------------------- - Messages - -------------------------------------------------------------------------- */ - diff --git a/rts/Capability.h b/rts/Capability.h index 2daade8..d580a83 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -278,9 +278,11 @@ INLINE_HEADER void contextSwitchCapability(Capability *cap); void freeCapabilities (void); // For the GC: -void markSomeCapabilities (evac_fn evac, void *user, nat i0, nat delta, - rtsBool no_mark_sparks); +void markCapability (evac_fn evac, void *user, Capability *cap, + rtsBool no_mark_sparks USED_IF_THREADS); + void markCapabilities (evac_fn evac, void *user); + void traverseSparkQueues (evac_fn evac, void *user); /* ----------------------------------------------------------------------------- diff --git a/rts/Hash.c b/rts/Hash.c index 09d0a06..9c9b2bc 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -27,13 +27,16 @@ /* Linked list of (key, data) pairs for separate chaining */ -struct hashlist { +typedef struct hashlist { StgWord key; void *data; struct hashlist *next; /* Next cell in bucket chain (same hash value) */ -}; +} HashList; -typedef struct hashlist HashList; +typedef struct chunklist { + HashList *chunk; + struct chunklist *next; +} HashListChunk; struct hashtable { int split; /* Next bucket to split when expanding */ @@ -43,7 +46,9 @@ struct hashtable { int kcount; /* Number of keys */ int bcount; /* Number of buckets */ HashList **dir[HDIRSIZE]; /* Directory of segments */ - HashFunction *hash; /* hash function */ + HashList *freeList; /* free list of HashLists */ + HashListChunk *chunks; + HashFunction *hash; /* hash function */ CompareFunction *compare; /* key comparison function */ }; @@ -207,30 +212,23 @@ lookupHashTable(HashTable *table, StgWord key) * no effort to actually return the space to the malloc arena. * -------------------------------------------------------------------------- */ -static HashList *freeList = NULL; - -static struct chunkList { - void *chunk; - struct chunkList *next; -} *chunks; - static HashList * -allocHashList(void) +allocHashList (HashTable *table) { HashList *hl, *p; - struct chunkList *cl; + HashListChunk *cl; - if ((hl = freeList) != NULL) { - freeList = hl->next; + if ((hl = table->freeList) != NULL) { + table->freeList = hl->next; } else { hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList"); cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList"); - cl->chunk = hl; - cl->next = chunks; - chunks = cl; + cl->chunk = hl; + cl->next = table->chunks; + table->chunks = cl; - freeList = hl + 1; - for (p = freeList; p < hl + HCHUNK - 1; p++) + table->freeList = hl + 1; + for (p = table->freeList; p < hl + HCHUNK - 1; p++) p->next = p + 1; p->next = NULL; } @@ -238,10 +236,10 @@ allocHashList(void) } static void -freeHashList(HashList *hl) +freeHashList (HashTable *table, HashList *hl) { - hl->next = freeList; - freeList = hl; + hl->next = table->freeList; + table->freeList = hl; } void @@ -264,7 +262,7 @@ insertHashTable(HashTable *table, StgWord key, void *data) segment = bucket / HSEGSIZE; index = bucket % HSEGSIZE; - hl = allocHashList(); + hl = allocHashList(table); hl->key = key; hl->data = data; @@ -292,7 +290,7 @@ removeHashTable(HashTable *table, StgWord key, void *data) table->dir[segment][index] = hl->next; else prev->next = hl->next; - freeHashList(hl); + freeHashList(table,hl); table->kcount--; return hl->data; } @@ -317,6 +315,7 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) ) long index; HashList *hl; HashList *next; + HashListChunk *cl, *cl_next; /* The last bucket with something in it is table->max + table->split - 1 */ segment = (table->max + table->split - 1) / HSEGSIZE; @@ -328,14 +327,18 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) ) next = hl->next; if (freeDataFun != NULL) (*freeDataFun)(hl->data); - freeHashList(hl); - } + } index--; } stgFree(table->dir[segment]); segment--; index = HSEGSIZE - 1; } + for (cl = table->chunks; cl != NULL; cl = cl_next) { + cl_next = cl->next; + stgFree(cl->chunk); + stgFree(cl); + } stgFree(table); } @@ -363,6 +366,8 @@ allocHashTable_(HashFunction *hash, CompareFunction *compare) table->mask2 = 2 * HSEGSIZE - 1; table->kcount = 0; table->bcount = HSEGSIZE; + table->freeList = NULL; + table->chunks = NULL; table->hash = hash; table->compare = compare; @@ -385,11 +390,5 @@ allocStrHashTable(void) void exitHashTable(void) { - struct chunkList *cl; - - while ((cl = chunks) != NULL) { - chunks = cl->next; - stgFree(cl->chunk); - stgFree(cl); - } + /* nothing to do */ } diff --git a/rts/Hpc.c b/rts/Hpc.c index 81c802c..c4ff8d3 100644 --- a/rts/Hpc.c +++ b/rts/Hpc.c @@ -6,6 +6,8 @@ #include "Rts.h" #include "Trace.h" +#include "Hash.h" +#include "RtsUtils.h" #include #include @@ -36,11 +38,11 @@ static pid_t hpc_pid = 0; // pid of this process at hpc-boot time. static FILE *tixFile; // file being read/written static int tix_ch; // current char +static HashTable * moduleHash = NULL; // module name -> HpcModuleInfo + HpcModuleInfo *modules = 0; -HpcModuleInfo *nextModule = 0; -int totalTixes = 0; // total number of tix boxes. -static char *tixFilename; +static char *tixFilename = NULL; static void GNU_ATTRIBUTE(__noreturn__) failure(char *msg) { @@ -78,7 +80,7 @@ static void ws(void) { } static char *expectString(void) { - char tmp[256], *res; + char tmp[256], *res; // XXX int tmp_ix = 0; expect('"'); while (tix_ch != '"') { @@ -87,7 +89,7 @@ static char *expectString(void) { } tmp[tmp_ix++] = 0; expect('"'); - res = malloc(tmp_ix); + res = stgMallocBytes(tmp_ix,"Hpc.expectString"); strcpy(res,tmp); return res; } @@ -104,10 +106,8 @@ static StgWord64 expectWord64(void) { static void readTix(void) { unsigned int i; - HpcModuleInfo *tmpModule; + HpcModuleInfo *tmpModule, *lookup; - totalTixes = 0; - ws(); expect('T'); expect('i'); @@ -117,7 +117,9 @@ readTix(void) { ws(); while(tix_ch != ']') { - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.readTix"); + tmpModule->from_file = rtsTrue; expect('T'); expect('i'); expect('x'); @@ -134,8 +136,6 @@ readTix(void) { ws(); tmpModule -> tickCount = (int)expectWord64(); tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64)); - tmpModule -> tickOffset = totalTixes; - totalTixes += tmpModule -> tickCount; ws(); expect('['); ws(); @@ -150,13 +150,32 @@ readTix(void) { expect(']'); ws(); - if (!modules) { - modules = tmpModule; + lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName); + if (tmpModule == NULL) { + debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s", + tmpModule->modName); + insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule); } else { - nextModule->next=tmpModule; + ASSERT(lookup->tixArr != 0); + ASSERT(!strcmp(tmpModule->modName, lookup->modName)); + debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s", + tmpModule->modName); + if (tmpModule->hashNo != lookup->hashNo) { + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); + } + for (i=0; i < tmpModule->tickCount; i++) { + lookup->tixArr[i] = tmpModule->tixArr[i]; + } + stgFree(tmpModule->tixArr); + stgFree(tmpModule->modName); + stgFree(tmpModule); } - nextModule=tmpModule; - + if (tix_ch == ',') { expect(','); ws(); @@ -166,9 +185,18 @@ readTix(void) { fclose(tixFile); } -static void hpc_init(void) { +void +startupHpc(void) +{ char *hpc_tixdir; char *hpc_tixfile; + + if (moduleHash == NULL) { + // no modules were registered with hs_hpc_module, so don't bother + // creating the .tix file. + return; + } + if (hpc_inited != 0) { return; } @@ -177,6 +205,8 @@ static void hpc_init(void) { hpc_tixdir = getenv("HPCTIXDIR"); hpc_tixfile = getenv("HPCTIXFILE"); + debugTrace(DEBUG_hpc,"startupHpc"); + /* XXX Check results of mallocs/strdups, and check we are requesting enough bytes */ if (hpc_tixfile != NULL) { @@ -192,10 +222,13 @@ static void hpc_init(void) { #endif /* Then, try open the file */ - tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12); + tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) + + strlen(prog_name) + 12, + "Hpc.startupHpc"); sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid); } else { - tixFilename = (char *) malloc(strlen(prog_name) + 6); + tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6, + "Hpc.startupHpc"); sprintf(tixFilename, "%s.tix", prog_name); } @@ -204,90 +237,80 @@ static void hpc_init(void) { } } -/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory. - * This memory can be uninitized, because we will initialize it with either the contents - * of the tix file, or all zeros. +/* + * Called on a per-module basis, by a constructor function compiled + * with each module (see Coverage.hpcInitCode), declaring where the + * tix boxes are stored in memory. This memory can be uninitized, + * because we will initialize it with either the contents of the tix + * file, or all zeros. + * + * Note that we might call this before reading the .tix file, or after + * in the case where we loaded some Haskell code from a .so with + * dlopen(). So we must handle the case where we already have an + * HpcModuleInfo for the module which was read from the .tix file. */ -int +void hs_hpc_module(char *modName, StgWord32 modCount, StgWord32 modHashNo, - StgWord64 *tixArr) { - HpcModuleInfo *tmpModule, *lastModule; - unsigned int i; - int offset = 0; - - debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount); + StgWord64 *tixArr) +{ + HpcModuleInfo *tmpModule; + nat i; - hpc_init(); + if (moduleHash == NULL) { + moduleHash = allocStrHashTable(); + } - tmpModule = modules; - lastModule = 0; - - for(;tmpModule != 0;tmpModule = tmpModule->next) { - if (!strcmp(tmpModule->modName,modName)) { + tmpModule = lookupHashTable(moduleHash, (StgWord)modName); + if (tmpModule == NULL) + { + // Did not find entry so add one on. + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.hs_hpc_module"); + tmpModule->modName = modName; + tmpModule->tickCount = modCount; + tmpModule->hashNo = modHashNo; + + tmpModule->tixArr = tixArr; + for(i=0;i < modCount;i++) { + tixArr[i] = 0; + } + tmpModule->next = modules; + tmpModule->from_file = rtsFalse; + modules = tmpModule; + insertHashTable(moduleHash, (StgWord)modName, tmpModule); + } + else + { if (tmpModule->tickCount != modCount) { - failure("inconsistent number of tick boxes"); + failure("inconsistent number of tick boxes"); } - assert(tmpModule->tixArr != 0); + ASSERT(tmpModule->tixArr != 0); if (tmpModule->hashNo != modHashNo) { - fprintf(stderr,"in module '%s'\n",tmpModule->modName); - failure("module mismatch with .tix/.mix file hash number"); - fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); - stg_exit(1); - + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); } + // The existing tixArr was made up when we read the .tix file, + // whereas this is the real tixArr, so copy the data from the + // .tix into the real tixArr. for(i=0;i < modCount;i++) { - tixArr[i] = tmpModule->tixArr[i]; + tixArr[i] = tmpModule->tixArr[i]; } - tmpModule->tixArr = tixArr; - return tmpModule->tickOffset; - } - lastModule = tmpModule; - } - // Did not find entry so add one on. - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); - tmpModule->modName = modName; - tmpModule->tickCount = modCount; - tmpModule->hashNo = modHashNo; - if (lastModule) { - tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount; - } else { - tmpModule->tickOffset = 0; - } - tmpModule->tixArr = tixArr; - for(i=0;i < modCount;i++) { - tixArr[i] = 0; - } - tmpModule->next = 0; - - if (!modules) { - modules = tmpModule; - } else { - lastModule->next=tmpModule; - } - - debugTrace(DEBUG_hpc,"end: hs_hpc_module"); - - return offset; -} - -/* This is called after all the modules have registered their local tixboxes, - * and does a sanity check: are we good to go? - */ - -void -startupHpc(void) { - debugTrace(DEBUG_hpc,"startupHpc"); - - if (hpc_inited == 0) { - return; + if (tmpModule->from_file) { + stgFree(tmpModule->modName); + stgFree(tmpModule->tixArr); + } + tmpModule->from_file = rtsFalse; } } - static void writeTix(FILE *f) { HpcModuleInfo *tmpModule; @@ -311,11 +334,10 @@ writeTix(FILE *f) { tmpModule->modName, (nat)tmpModule->hashNo, (nat)tmpModule->tickCount); - debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n", + debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n", tmpModule->modName, (nat)tmpModule->tickCount, - (nat)tmpModule->hashNo, - (nat)tmpModule->tickOffset); + (nat)tmpModule->hashNo); inner_comma = 0; for(i = 0;i < tmpModule->tickCount;i++) { @@ -338,7 +360,17 @@ writeTix(FILE *f) { fclose(f); } -/* Called at the end of execution, to write out the Hpc *.tix file +static void +freeHpcModuleInfo (HpcModuleInfo *mod) +{ + if (mod->from_file) { + stgFree(mod->modName); + stgFree(mod->tixArr); + } + stgFree(mod); +} + +/* Called at the end of execution, to write out the Hpc *.tix file * for this exection. Safe to call, even if coverage is not used. */ void @@ -357,6 +389,12 @@ exitHpc(void) { FILE *f = fopen(tixFilename,"w"); writeTix(f); } + + freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo); + moduleHash = NULL; + + stgFree(tixFilename); + tixFilename = NULL; } ////////////////////////////////////////////////////////////////////////////// diff --git a/rts/Linker.c b/rts/Linker.c index edad92e..c1310b0 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -70,12 +70,12 @@ #include #endif -#if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ - defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ - defined(openbsd_HOST_OS ) || \ - ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) || \ - defined(kfreebsdgnu_HOST_OS) -/* Don't use mmap on powerpc-apple-darwin as mmap doesn't support +#if !defined(powerpc_HOST_ARCH) && \ + ( defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ + defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ + defined(openbsd_HOST_OS ) || defined(darwin_HOST_OS ) || \ + defined(kfreebsdgnu_HOST_OS) ) +/* Don't use mmap on powerpc_HOST_ARCH as mmap doesn't support * reallocating but we need to allocate jump islands just after each * object images. Otherwise relative branches to jump islands can fail * due to 24-bits displacement overflow. @@ -101,6 +101,8 @@ #elif defined(darwin_HOST_OS) # define OBJFORMAT_MACHO # include +# include +# include # include # include # include @@ -830,6 +832,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_newTVarzh) \ SymI_HasProto(stg_noDuplicatezh) \ SymI_HasProto(stg_atomicModifyMutVarzh) \ + SymI_HasProto(stg_casMutVarzh) \ SymI_HasProto(stg_newPinnedByteArrayzh) \ SymI_HasProto(stg_newAlignedPinnedByteArrayzh) \ SymI_HasProto(newSpark) \ @@ -1183,11 +1186,11 @@ initLinker( void ) # endif /* RTLD_DEFAULT */ compileResult = regcomp(&re_invalid, - "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header", + "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)", REG_EXTENDED); ASSERT( compileResult == 0 ); compileResult = regcomp(&re_realso, - "GROUP *\\( *(([^ )])+)", + "(GROUP|INPUT) *\\( *(([^ )])+)", REG_EXTENDED); ASSERT( compileResult == 0 ); # endif @@ -1358,8 +1361,8 @@ addDLL( char *dll_name ) if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) { // success -- try to dlopen the first named file IF_DEBUG(linker, debugBelch("match%s\n","")); - line[match[1].rm_eo] = '\0'; - errmsg = internal_dlopen(line+match[1].rm_so); + line[match[2].rm_eo] = '\0'; + errmsg = internal_dlopen(line+match[2].rm_so); break; } // if control reaches here, no GROUP ( ... ) directive was found @@ -1565,6 +1568,7 @@ mmapForLinker (size_t bytes, nat flags, int fd) int pagesize, size; static nat fixed = 0; + IF_DEBUG(linker, debugBelch("mmapForLinker: start\n")); pagesize = getpagesize(); size = ROUND_UP(bytes, pagesize); @@ -1576,6 +1580,8 @@ mmap_again: } #endif + IF_DEBUG(linker, debugBelch("mmapForLinker: \tprotection %#0x\n", PROT_EXEC | PROT_READ | PROT_WRITE)); + IF_DEBUG(linker, debugBelch("mmapForLinker: \tflags %#0x\n", MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags)); result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0); @@ -1623,6 +1629,8 @@ mmap_again: } #endif + IF_DEBUG(linker, debugBelch("mmapForLinker: mapped %lu bytes starting at %p\n", (lnat)size, result)); + IF_DEBUG(linker, debugBelch("mmapForLinker: done\n")); return result; } #endif // USE_MMAP @@ -1638,6 +1646,7 @@ mkOc( char *path, char *image, int imageSize, ) { ObjectCode* oc; + IF_DEBUG(linker, debugBelch("mkOc: start\n")); oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)"); # if defined(OBJFORMAT_ELF) @@ -1679,6 +1688,7 @@ mkOc( char *path, char *image, int imageSize, oc->next = objects; objects = oc; + IF_DEBUG(linker, debugBelch("mkOc: done\n")); return oc; } @@ -1694,13 +1704,33 @@ loadArchive( char *path ) char *fileName; size_t fileNameSize; int isObject, isGnuIndex; - char tmp[12]; + char tmp[20]; char *gnuFileIndex; int gnuFileIndexSize; -#if !defined(USE_MMAP) && defined(darwin_HOST_OS) +#if defined(darwin_HOST_OS) + int i; + uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; +#if defined(i386_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_X86; + const uint32_t mycpusubtype = CPU_SUBTYPE_X86_ALL; +#elif defined(x86_64_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_X86_64; + const uint32_t mycpusubtype = CPU_SUBTYPE_X86_64_ALL; +#elif defined(powerpc_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_POWERPC; + const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL; +#elif defined(powerpc64_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_POWERPC64; + const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL; +#else +#error Unknown Darwin architecture +#endif +#if !defined(USE_MMAP) int misalignment; #endif +#endif + IF_DEBUG(linker, debugBelch("loadArchive: start\n")); IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path)); gnuFileIndex = NULL; @@ -1713,20 +1743,97 @@ loadArchive( char *path ) if (!f) barf("loadObj: can't read `%s'", path); + /* Check if this is an archive by looking for the magic "!\n" + * string. Usually, if this fails, we barf and quit. On Darwin however, + * we may have a fat archive, which contains archives for more than + * one architecture. Fat archives start with the magic number 0xcafebabe, + * always stored big endian. If we find a fat_header, we scan through + * the fat_arch structs, searching through for one for our host + * architecture. If a matching struct is found, we read the offset + * of our archive data (nfat_offset) and seek forward nfat_offset bytes + * from the start of the file. + * + * A subtlety is that all of the members of the fat_header and fat_arch + * structs are stored big endian, so we need to call byte order + * conversion functions. + * + * If we find the appropriate architecture in a fat archive, we gobble + * its magic "!\n" string and continue processing just as if + * we had a single architecture archive. + */ + n = fread ( tmp, 1, 8, f ); - if (strncmp(tmp, "!\n", 8) != 0) + if (n != 8) + barf("loadArchive: Failed reading header from `%s'", path); + if (strncmp(tmp, "!\n", 8) != 0) { + +#if defined(darwin_HOST_OS) + /* Not a standard archive, look for a fat archive magic number: */ + if (ntohl(*(uint32_t *)tmp) == FAT_MAGIC) { + nfat_arch = ntohl(*(uint32_t *)(tmp + 4)); + IF_DEBUG(linker, debugBelch("loadArchive: found a fat archive containing %d architectures\n", nfat_arch)); + nfat_offset = 0; + + for (i = 0; i < (int)nfat_arch; i++) { + /* search for the right arch */ + n = fread( tmp, 1, 20, f ); + if (n != 8) + barf("loadArchive: Failed reading arch from `%s'", path); + cputype = ntohl(*(uint32_t *)tmp); + cpusubtype = ntohl(*(uint32_t *)(tmp + 4)); + + if (cputype == mycputype && cpusubtype == mycpusubtype) { + IF_DEBUG(linker, debugBelch("loadArchive: found my archive in a fat archive\n")); + nfat_offset = ntohl(*(uint32_t *)(tmp + 8)); + break; + } + } + + if (nfat_offset == 0) { + barf ("loadArchive: searched %d architectures, but no host arch found", (int)nfat_arch); + } + else { + n = fseek( f, nfat_offset, SEEK_SET ); + if (n != 0) + barf("loadArchive: Failed to seek to arch in `%s'", path); + n = fread ( tmp, 1, 8, f ); + if (n != 8) + barf("loadArchive: Failed reading header from `%s'", path); + if (strncmp(tmp, "!\n", 8) != 0) { + barf("loadArchive: couldn't find archive in `%s' at offset %d", path, nfat_offset); + } + } + } + else { + barf("loadArchive: Neither an archive, nor a fat archive: `%s'", path); + } + +#else barf("loadArchive: Not an archive: `%s'", path); +#endif + } + + IF_DEBUG(linker, debugBelch("loadArchive: loading archive contents\n")); while(1) { n = fread ( fileName, 1, 16, f ); if (n != 16) { if (feof(f)) { + IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%s'\n", path)); break; } else { barf("loadArchive: Failed reading file name from `%s'", path); } } + +#if defined(darwin_HOST_OS) + if (strncmp(fileName, "!\n", 8) == 0) { + IF_DEBUG(linker, debugBelch("loadArchive: found the start of another archive, breaking\n")); + break; + } +#endif + n = fread ( tmp, 1, 12, f ); if (n != 12) barf("loadArchive: Failed reading mod time from `%s'", path); @@ -1746,7 +1853,11 @@ loadArchive( char *path ) for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; memberSize = atoi(tmp); + + IF_DEBUG(linker, debugBelch("loadArchive: size of this archive member is %d\n", memberSize)); n = fread ( tmp, 1, 2, f ); + if (n != 2) + barf("loadArchive: Failed reading magic from `%s'", path); if (strncmp(tmp, "\x60\x0A", 2) != 0) barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); @@ -1772,6 +1883,11 @@ loadArchive( char *path ) path); } fileName[thisFileNameSize] = 0; + + /* On OS X at least, thisFileNameSize is the size of the + fileName field, not the length of the fileName + itself. */ + thisFileNameSize = strlen(fileName); } else { barf("loadArchive: BSD-variant filename size not found while reading filename from `%s'", path); @@ -1857,6 +1973,9 @@ loadArchive( char *path ) && fileName[thisFileNameSize - 2] == '.' && fileName[thisFileNameSize - 1] == 'o'; + IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize)); + IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject)); + if (isObject) { char *archiveMemberName; @@ -1922,23 +2041,29 @@ loadArchive( char *path ) gnuFileIndexSize = memberSize; } else { + IF_DEBUG(linker, debugBelch("loadArchive: '%s' does not appear to be an object file\n", fileName)); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) barf("loadArchive: error whilst seeking by %d in `%s'", memberSize, path); } + /* .ar files are 2-byte aligned */ if (memberSize % 2) { + IF_DEBUG(linker, debugBelch("loadArchive: trying to read one pad byte\n")); n = fread ( tmp, 1, 1, f ); if (n != 1) { if (feof(f)) { + IF_DEBUG(linker, debugBelch("loadArchive: found EOF while reading one pad byte\n")); break; } else { barf("loadArchive: Failed reading padding from `%s'", path); } } + IF_DEBUG(linker, debugBelch("loadArchive: successfully read one pad byte\n")); } + IF_DEBUG(linker, debugBelch("loadArchive: reached end of archive loading while loop\n")); } fclose(f); @@ -1952,6 +2077,7 @@ loadArchive( char *path ) #endif } + IF_DEBUG(linker, debugBelch("loadArchive: done\n")); return 1; } @@ -2079,18 +2205,18 @@ static HsInt loadOc( ObjectCode* oc ) { int r; - IF_DEBUG(linker, debugBelch("loadOc\n")); + IF_DEBUG(linker, debugBelch("loadOc: start\n")); # if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)) r = ocAllocateSymbolExtras_MachO ( oc ); if (!r) { - IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n")); return r; } # elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)) r = ocAllocateSymbolExtras_ELF ( oc ); if (!r) { - IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n")); return r; } #endif @@ -2106,7 +2232,7 @@ loadOc( ObjectCode* oc ) { barf("loadObj: no verify method"); # endif if (!r) { - IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n")); return r; } @@ -2121,13 +2247,13 @@ loadOc( ObjectCode* oc ) { barf("loadObj: no getNames method"); # endif if (!r) { - IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n")); return r; } /* loaded, but not resolved yet */ oc->status = OBJECT_LOADED; - IF_DEBUG(linker, debugBelch("loadObj done.\n")); + IF_DEBUG(linker, debugBelch("loadOc: done.\n")); return 1; } @@ -2233,11 +2359,13 @@ unloadObj( char *path ) * which may be prodded during relocation, and abort if we try and write * outside any of these. */ -static void addProddableBlock ( ObjectCode* oc, void* start, int size ) +static void +addProddableBlock ( ObjectCode* oc, void* start, int size ) { ProddableBlock* pb = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock"); - IF_DEBUG(linker, debugBelch("addProddableBlock %p %p %d\n", oc, start, size)); + + IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size)); ASSERT(size > 0); pb->start = start; pb->size = size; @@ -2245,9 +2373,11 @@ static void addProddableBlock ( ObjectCode* oc, void* start, int size ) oc->proddables = pb; } -static void checkProddableBlock ( ObjectCode* oc, void* addr ) +static void +checkProddableBlock (ObjectCode *oc, void *addr ) { ProddableBlock* pb; + for (pb = oc->proddables; pb != NULL; pb = pb->next) { char* s = (char*)(pb->start); char* e = s + pb->size - 1; @@ -2263,7 +2393,8 @@ static void checkProddableBlock ( ObjectCode* oc, void* addr ) /* ----------------------------------------------------------------------------- * Section management. */ -static void addSection ( ObjectCode* oc, SectionKind kind, +static void +addSection ( ObjectCode* oc, SectionKind kind, void* start, void* end ) { Section* s = stgMallocBytes(sizeof(Section), "addSection"); @@ -2272,10 +2403,9 @@ static void addSection ( ObjectCode* oc, SectionKind kind, s->kind = kind; s->next = oc->sections; oc->sections = s; - /* - debugBelch("addSection: %p-%p (size %d), kind %d\n", - start, ((char*)end)-1, end - start + 1, kind ); - */ + + IF_DEBUG(linker, debugBelch("addSection: %p-%p (size %ld), kind %d\n", + start, ((char*)end)-1, (long)end - (long)start + 1, kind )); } @@ -2416,7 +2546,9 @@ static SymbolExtra* makeSymbolExtra( ObjectCode* oc, Because the PPC has split data/instruction caches, we have to do that whenever we modify code at runtime. */ -static void ocFlushInstructionCacheFrom(void* begin, size_t length) + +static void +ocFlushInstructionCacheFrom(void* begin, size_t length) { size_t n = (length + 3) / 4; unsigned long* p = begin; @@ -2435,15 +2567,22 @@ static void ocFlushInstructionCacheFrom(void* begin, size_t length) "isync" ); } -static void ocFlushInstructionCache( ObjectCode *oc ) + +static void +ocFlushInstructionCache( ObjectCode *oc ) { /* The main object code */ - ocFlushInstructionCacheFrom(oc->image + oc->misalignment, oc->fileSize); + ocFlushInstructionCacheFrom(oc->image +#ifdef darwin_HOST_OS + + oc->misalignment +#endif + , oc->fileSize); /* Jump Islands */ ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras); } -#endif +#endif /* powerpc_HOST_ARCH */ + /* -------------------------------------------------------------------------- * PEi386 specifics (Win32 targets) @@ -4413,79 +4552,100 @@ static int ocAllocateSymbolExtras_ELF( ObjectCode *oc ) #endif #ifdef powerpc_HOST_ARCH -static int ocAllocateSymbolExtras_MachO(ObjectCode* oc) +static int +ocAllocateSymbolExtras_MachO(ObjectCode* oc) { struct mach_header *header = (struct mach_header *) oc->image; struct load_command *lc = (struct load_command *) (header + 1); unsigned i; - for( i = 0; i < header->ncmds; i++ ) - { - if( lc->cmd == LC_SYMTAB ) - { + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n")); + + for (i = 0; i < header->ncmds; i++) { + if (lc->cmd == LC_SYMTAB) { + // Find out the first and last undefined external // symbol, so we don't have to allocate too many - // jump islands. + // jump islands/GOT entries. + struct symtab_command *symLC = (struct symtab_command *) lc; unsigned min = symLC->nsyms, max = 0; struct nlist *nlist = symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff) : NULL; - for(i=0;insyms;i++) - { - if(nlist[i].n_type & N_STAB) + + for (i = 0; i < symLC->nsyms; i++) { + + if (nlist[i].n_type & N_STAB) { ; - else if(nlist[i].n_type & N_EXT) - { + } else if (nlist[i].n_type & N_EXT) { + if((nlist[i].n_type & N_TYPE) == N_UNDF - && (nlist[i].n_value == 0)) - { - if(i < min) + && (nlist[i].n_value == 0)) { + + if (i < min) { min = i; - if(i > max) + } + + if (i > max) { max = i; } } } - if(max >= min) + } + + if (max >= min) { return ocAllocateSymbolExtras(oc, max - min + 1, min); + } break; } lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize ); } + return ocAllocateSymbolExtras(oc,0,0); } + #endif #ifdef x86_64_HOST_ARCH -static int ocAllocateSymbolExtras_MachO(ObjectCode* oc) +static int +ocAllocateSymbolExtras_MachO(ObjectCode* oc) { struct mach_header *header = (struct mach_header *) oc->image; struct load_command *lc = (struct load_command *) (header + 1); unsigned i; - for( i = 0; i < header->ncmds; i++ ) - { - if( lc->cmd == LC_SYMTAB ) - { + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n")); + + for (i = 0; i < header->ncmds; i++) { + if (lc->cmd == LC_SYMTAB) { + // Just allocate one entry for every symbol struct symtab_command *symLC = (struct symtab_command *) lc; + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocate %d symbols\n", symLC->nsyms)); + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n")); return ocAllocateSymbolExtras(oc, symLC->nsyms, 0); } lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize ); } + + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocated no symbols\n")); + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n")); return ocAllocateSymbolExtras(oc,0,0); } #endif -static int ocVerifyImage_MachO(ObjectCode* oc) +static int +ocVerifyImage_MachO(ObjectCode * oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; + IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: start\n")); + #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH if(header->magic != MH_MAGIC_64) { errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n", @@ -4499,11 +4659,14 @@ static int ocVerifyImage_MachO(ObjectCode* oc) return 0; } #endif + // FIXME: do some more verifying here + IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: done\n")); return 1; } -static int resolveImports( +static int +resolveImports( ObjectCode* oc, char *image, struct symtab_command *symLC, @@ -4518,12 +4681,13 @@ static int resolveImports( #if i386_HOST_ARCH int isJumpTable = 0; - if(!strcmp(sect->sectname,"__jump_table")) - { + + if (strcmp(sect->sectname,"__jump_table") == 0) { isJumpTable = 1; itemSize = 5; ASSERT(sect->reserved2 == itemSize); } + #endif for(i=0; i*itemSize < sect->size;i++) @@ -4534,6 +4698,7 @@ static int resolveImports( void *addr = NULL; IF_DEBUG(linker, debugBelch("resolveImports: resolving %s\n", nm)); + if ((symbol->n_type & N_TYPE) == N_UNDF && (symbol->n_type & N_EXT) && (symbol->n_value != 0)) { addr = (void*) (symbol->n_value); @@ -4550,10 +4715,10 @@ static int resolveImports( ASSERT(addr); #if i386_HOST_ARCH - if(isJumpTable) - { + if (isJumpTable) { checkProddableBlock(oc,image + sect->offset + i*itemSize); - *(image + sect->offset + i*itemSize) = 0xe9; // jmp + + *(image + sect->offset + i * itemSize) = 0xe9; // jmp opcode *(unsigned*)(image + sect->offset + i*itemSize + 1) = (char*)addr - (image + sect->offset + i*itemSize + 5); } @@ -4773,10 +4938,9 @@ static int relocateSection( // and use #ifdefs for the other types. // Step 1: Figure out what the relocated value should be - if(scat->r_type == GENERIC_RELOC_VANILLA) - { - word = *wordPtr + (unsigned long) relocateAddress( - oc, + if (scat->r_type == GENERIC_RELOC_VANILLA) { + word = *wordPtr + + (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value) @@ -4796,9 +4960,10 @@ static int relocateSection( struct scattered_relocation_info *pair = (struct scattered_relocation_info*) &relocs[i+1]; - if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR) + if (!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR) { barf("Invalid Mach-O file: " "RELOC_*_SECTDIFF not followed by RELOC_PAIR"); + } word = (unsigned long) (relocateAddress(oc, nSections, sections, scat->r_value) @@ -4812,9 +4977,11 @@ static int relocateSection( || scat->r_type == PPC_RELOC_LO14) { // these are generated by label+offset things struct relocation_info *pair = &relocs[i+1]; - if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR) + + if ((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR) { barf("Invalid Mach-O file: " "PPC_RELOC_* not followed by PPC_RELOC_PAIR"); + } if(scat->r_type == PPC_RELOC_LO16) { @@ -4845,8 +5012,7 @@ static int relocateSection( i++; } #endif - else - { + else { barf ("Don't know how to handle this Mach-O " "scattered relocation entry: " "object file %s; entry type %ld; " @@ -4869,15 +5035,18 @@ static int relocateSection( *wordPtr = word; } #ifdef powerpc_HOST_ARCH - else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16) + else if (scat->r_type == PPC_RELOC_LO16_SECTDIFF + || scat->r_type == PPC_RELOC_LO16) { ((unsigned short*) wordPtr)[1] = word & 0xFFFF; } - else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16) + else if (scat->r_type == PPC_RELOC_HI16_SECTDIFF + || scat->r_type == PPC_RELOC_HI16) { ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF; } - else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16) + else if (scat->r_type == PPC_RELOC_HA16_SECTDIFF + || scat->r_type == PPC_RELOC_HA16) { ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF) + ((word & (1<<15)) ? 1 : 0); @@ -4912,11 +5081,12 @@ static int relocateSection( else /* !(relocs[i].r_address & R_SCATTERED) */ { struct relocation_info *reloc = &relocs[i]; - if(reloc->r_pcrel && !reloc->r_extern) + if (reloc->r_pcrel && !reloc->r_extern) { + IF_DEBUG(linker, debugBelch("relocateSection: pc relative but not external, skipping\n")); continue; + } - if(reloc->r_length == 2) - { + if (reloc->r_length == 2) { unsigned long word = 0; #ifdef powerpc_HOST_ARCH unsigned long jumpIsland = 0; @@ -4928,34 +5098,28 @@ static int relocateSection( unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address); checkProddableBlock(oc,wordPtr); - if(reloc->r_type == GENERIC_RELOC_VANILLA) - { + if (reloc->r_type == GENERIC_RELOC_VANILLA) { word = *wordPtr; } #ifdef powerpc_HOST_ARCH - else if(reloc->r_type == PPC_RELOC_LO16) - { + else if (reloc->r_type == PPC_RELOC_LO16) { word = ((unsigned short*) wordPtr)[1]; word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16; } - else if(reloc->r_type == PPC_RELOC_HI16) - { + else if (reloc->r_type == PPC_RELOC_HI16) { word = ((unsigned short*) wordPtr)[1] << 16; word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF); } - else if(reloc->r_type == PPC_RELOC_HA16) - { + else if (reloc->r_type == PPC_RELOC_HA16) { word = ((unsigned short*) wordPtr)[1] << 16; word += ((short)relocs[i+1].r_address & (short)0xFFFF); } - else if(reloc->r_type == PPC_RELOC_BR24) - { + else if (reloc->r_type == PPC_RELOC_BR24) { word = *wordPtr; word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0); } #endif - else - { + else { barf("Can't handle this Mach-O relocation entry " "(not scattered): " "object file %s; entry type %ld; address %#lx\n", @@ -4965,28 +5129,24 @@ static int relocateSection( return 0; } - if(!reloc->r_extern) - { - long delta = - sections[reloc->r_symbolnum-1].offset + if (!reloc->r_extern) { + long delta = sections[reloc->r_symbolnum-1].offset - sections[reloc->r_symbolnum-1].addr + ((long) image); word += delta; } - else - { + else { struct nlist *symbol = &nlist[reloc->r_symbolnum]; char *nm = image + symLC->stroff + symbol->n_un.n_strx; void *symbolAddress = lookupSymbol(nm); - if(!symbolAddress) - { + + if (!symbolAddress) { errorBelch("\nunknown symbol `%s'", nm); return 0; } - if(reloc->r_pcrel) - { + if (reloc->r_pcrel) { #ifdef powerpc_HOST_ARCH // In the .o file, this should be a relative jump to NULL // and we'll change it to a relative jump to the symbol @@ -4996,8 +5156,7 @@ static int relocateSection( reloc->r_symbolnum, (unsigned long) symbolAddress) -> jumpIsland; - if(jumpIsland != 0) - { + if (jumpIsland != 0) { offsetToJumpIsland = word + jumpIsland - (((long)image) + sect->offset - sect->addr); } @@ -5005,14 +5164,12 @@ static int relocateSection( word += (unsigned long) symbolAddress - (((long)image) + sect->offset - sect->addr); } - else - { + else { word += (unsigned long) symbolAddress; } } - if(reloc->r_type == GENERIC_RELOC_VANILLA) - { + if (reloc->r_type == GENERIC_RELOC_VANILLA) { *wordPtr = word; continue; } @@ -5020,34 +5177,36 @@ static int relocateSection( else if(reloc->r_type == PPC_RELOC_LO16) { ((unsigned short*) wordPtr)[1] = word & 0xFFFF; - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_HI16) { ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF; - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_HA16) { ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF) + ((word & (1<<15)) ? 1 : 0); - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_BR24) { - if((word & 0x03) != 0) + if ((word & 0x03) != 0) { barf("%s: unconditional relative branch with a displacement " "which isn't a multiple of 4 bytes: %#lx", OC_INFORMATIVE_FILENAME(oc), word); + } if((word & 0xFE000000) != 0xFE000000 && - (word & 0xFE000000) != 0x00000000) - { + (word & 0xFE000000) != 0x00000000) { // The branch offset is too large. // Therefore, we try to use a jump island. - if(jumpIsland == 0) - { + if (jumpIsland == 0) { barf("%s: unconditional relative branch out of range: " "no jump island available: %#lx", OC_INFORMATIVE_FILENAME(oc), @@ -5055,13 +5214,15 @@ static int relocateSection( } word = offsetToJumpIsland; + if((word & 0xFE000000) != 0xFE000000 && - (word & 0xFE000000) != 0x00000000) + (word & 0xFE000000) != 0x00000000) { barf("%s: unconditional relative branch out of range: " "jump island out of range: %#lx", OC_INFORMATIVE_FILENAME(oc), word); } + } *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC); continue; } @@ -5082,11 +5243,13 @@ static int relocateSection( } #endif } + IF_DEBUG(linker, debugBelch("relocateSection: done\n")); return 1; } -static int ocGetNames_MachO(ObjectCode* oc) +static int +ocGetNames_MachO(ObjectCode* oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; @@ -5104,10 +5267,13 @@ static int ocGetNames_MachO(ObjectCode* oc) for(i=0;incmds;i++) { - if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) + if (lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) { segLC = (struct segment_command*) lc; - else if(lc->cmd == LC_SYMTAB) + } + else if (lc->cmd == LC_SYMTAB) { symLC = (struct symtab_command*) lc; + } + lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize ); } @@ -5115,14 +5281,19 @@ static int ocGetNames_MachO(ObjectCode* oc) nlist = symLC ? (struct nlist*) (image + symLC->symoff) : NULL; - if(!segLC) + if (!segLC) { barf("ocGetNames_MachO: no segment load command"); + } + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: will load %d sections\n", segLC->nsects)); for(i=0;insects;i++) { - IF_DEBUG(linker, debugBelch("ocGetNames_MachO: segment %d\n", i)); - if (sections[i].size == 0) + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: section %d\n", i)); + + if (sections[i].size == 0) { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: found a zero length section, skipping\n")); continue; + } if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL) { @@ -5131,36 +5302,47 @@ static int ocGetNames_MachO(ObjectCode* oc) sections[i].offset = zeroFillArea - image; } - if(!strcmp(sections[i].sectname,"__text")) + if (!strcmp(sections[i].sectname,"__text")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __text section\n")); addSection(oc, SECTIONKIND_CODE_OR_RODATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - else if(!strcmp(sections[i].sectname,"__const")) + } + else if (!strcmp(sections[i].sectname,"__const")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __const section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - else if(!strcmp(sections[i].sectname,"__data")) + } + else if (!strcmp(sections[i].sectname,"__data")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __data section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); + } else if(!strcmp(sections[i].sectname,"__bss") - || !strcmp(sections[i].sectname,"__common")) + || !strcmp(sections[i].sectname,"__common")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __bss section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - - addProddableBlock(oc, (void*) (image + sections[i].offset), + } + addProddableBlock(oc, + (void *) (image + sections[i].offset), sections[i].size); } // count external symbols defined here oc->n_symbols = 0; - if(symLC) - { - for(i=0;insyms;i++) - { - if(nlist[i].n_type & N_STAB) + if (symLC) { + for (i = 0; i < symLC->nsyms; i++) { + if (nlist[i].n_type & N_STAB) { ; + } else if(nlist[i].n_type & N_EXT) { if((nlist[i].n_type & N_TYPE) == N_UNDF @@ -5204,19 +5386,27 @@ static int ocGetNames_MachO(ObjectCode* oc) oc->symbols[curSymbol++] = nm; } } + else + { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: \t...not external, skipping\n")); + } + } + else + { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: \t...not defined in this section, skipping\n")); } } } commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)"); commonCounter = (unsigned long)commonStorage; - if(symLC) - { - for(i=0;insyms;i++) - { + + if (symLC) { + for (i = 0; i < symLC->nsyms; i++) { if((nlist[i].n_type & N_TYPE) == N_UNDF - && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0)) - { + && (nlist[i].n_type & N_EXT) + && (nlist[i].n_value != 0)) { + char *nm = image + symLC->stroff + nlist[i].n_un.n_strx; unsigned long sz = nlist[i].n_value; @@ -5231,10 +5421,13 @@ static int ocGetNames_MachO(ObjectCode* oc) } } } + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: done\n")); return 1; } -static int ocResolve_MachO(ObjectCode* oc) +static int +ocResolve_MachO(ObjectCode* oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; @@ -5249,12 +5442,19 @@ static int ocResolve_MachO(ObjectCode* oc) IF_DEBUG(linker, debugBelch("ocResolve_MachO: start\n")); for (i = 0; i < header->ncmds; i++) { - if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) + if (lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) { segLC = (struct segment_command*) lc; - else if(lc->cmd == LC_SYMTAB) + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a 32 or 64 bit segment load command\n")); + } + else if (lc->cmd == LC_SYMTAB) { symLC = (struct symtab_command*) lc; - else if(lc->cmd == LC_DYSYMTAB) + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a symbol table load command\n")); + } + else if (lc->cmd == LC_DYSYMTAB) { dsymLC = (struct dysymtab_command*) lc; + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a dynamic symbol table load command\n")); + } + lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize ); } @@ -5322,7 +5522,8 @@ static int ocResolve_MachO(ObjectCode* oc) extern void* symbolsWithoutUnderscore[]; -static void machoInitSymbolsWithoutUnderscore() +static void +machoInitSymbolsWithoutUnderscore(void) { void **p = symbolsWithoutUnderscore; __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:"); @@ -5350,7 +5551,8 @@ static void machoInitSymbolsWithoutUnderscore() * Figure out by how much to shift the entire Mach-O file in memory * when loading so that its single segment ends up 16-byte-aligned */ -static int machoGetMisalignment( FILE * f ) +static int +machoGetMisalignment( FILE * f ) { struct mach_header header; int misalignment; diff --git a/rts/Main.c b/rts/Main.c index c1b028f..c7a559f 100644 --- a/rts/Main.c +++ b/rts/Main.c @@ -15,16 +15,10 @@ #include "Rts.h" #include "RtsMain.h" -/* The symbol for the Haskell Main module's init function. It is safe to refer - * to it here because this Main.o object file will only be linked in if we are - * linking a Haskell program that uses a Haskell Main.main function. - */ -extern void __stginit_ZCMain(void); - /* Similarly, we can refer to the ZCMain_main_closure here */ extern StgClosure ZCMain_main_closure; int main(int argc, char *argv[]) { - return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure); + return hs_main(argc, argv, &ZCMain_main_closure); } diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 701654a..5c9cfb7 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -230,6 +230,25 @@ stg_newMutVarzh RET_P(mv); } +stg_casMutVarzh + /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */ +{ + W_ mv, old, new, h; + + mv = R1; + old = R2; + new = R3; + + (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, + old, new) []; + if (h != old) { + RET_NP(1,h); + } else { + RET_NP(0,h); + } +} + + stg_atomicModifyMutVarzh { W_ mv, f, z, x, y, r, h; diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 39b64d4..9bd707f 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -309,7 +309,7 @@ void initProfiling1 (void) { } -void freeProfiling1 (void) +void freeProfiling (void) { } @@ -812,7 +812,7 @@ dumpCensus( Census *census ) rs->id = -(rs->id); // report in the unit of bytes: * sizeof(StgWord) - printRetainerSetShort(hp_file, rs); + printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength); break; } default: diff --git a/rts/Profiling.c b/rts/Profiling.c index 1d8627c..5648f31 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -34,9 +34,9 @@ Arena *prof_arena; * closure_cats */ -unsigned int CC_ID; -unsigned int CCS_ID; -unsigned int HP_ID; +unsigned int CC_ID = 1; +unsigned int CCS_ID = 1; +unsigned int HP_ID = 1; /* figures for the profiling report. */ @@ -58,8 +58,8 @@ CostCentreStack *CCCS; /* Linked lists to keep track of cc's and ccs's that haven't * been declared in the log file yet */ -CostCentre *CC_LIST; -CostCentreStack *CCS_LIST; +CostCentre *CC_LIST = NULL; +CostCentreStack *CCS_LIST = NULL; /* * Built-in cost centres and cost-centre stacks: @@ -152,41 +152,10 @@ initProfiling1 (void) /* for the benefit of allocate()... */ CCCS = CCS_SYSTEM; - - /* Initialize counters for IDs */ - CC_ID = 1; - CCS_ID = 1; - HP_ID = 1; - - /* Initialize Declaration lists to NULL */ - CC_LIST = NULL; - CCS_LIST = NULL; - - /* Register all the cost centres / stacks in the program - * CC_MAIN gets link = 0, all others have non-zero link. - */ - REGISTER_CC(CC_MAIN); - REGISTER_CC(CC_SYSTEM); - REGISTER_CC(CC_GC); - REGISTER_CC(CC_OVERHEAD); - REGISTER_CC(CC_SUBSUMED); - REGISTER_CC(CC_DONT_CARE); - REGISTER_CCS(CCS_MAIN); - REGISTER_CCS(CCS_SYSTEM); - REGISTER_CCS(CCS_GC); - REGISTER_CCS(CCS_OVERHEAD); - REGISTER_CCS(CCS_SUBSUMED); - REGISTER_CCS(CCS_DONT_CARE); - - CCCS = CCS_OVERHEAD; - - /* cost centres are registered by the per-module - * initialisation code now... - */ } void -freeProfiling1 (void) +freeProfiling (void) { arenaFree(prof_arena); } @@ -202,17 +171,36 @@ initProfiling2 (void) * information into it. */ initProfilingLogFile(); + /* Register all the cost centres / stacks in the program + * CC_MAIN gets link = 0, all others have non-zero link. + */ + REGISTER_CC(CC_MAIN); + REGISTER_CC(CC_SYSTEM); + REGISTER_CC(CC_GC); + REGISTER_CC(CC_OVERHEAD); + REGISTER_CC(CC_SUBSUMED); + REGISTER_CC(CC_DONT_CARE); + + REGISTER_CCS(CCS_SYSTEM); + REGISTER_CCS(CCS_GC); + REGISTER_CCS(CCS_OVERHEAD); + REGISTER_CCS(CCS_SUBSUMED); + REGISTER_CCS(CCS_DONT_CARE); + REGISTER_CCS(CCS_MAIN); + /* find all the "special" cost centre stacks, and make them children * of CCS_MAIN. */ - ASSERT(CCS_MAIN->prevStack == 0); + ASSERT(CCS_LIST == CCS_MAIN); + CCS_LIST = CCS_LIST->prevStack; + CCS_MAIN->prevStack = NULL; CCS_MAIN->root = CC_MAIN; ccsSetSelected(CCS_MAIN); DecCCS(CCS_MAIN); - for (ccs = CCS_LIST; ccs != CCS_MAIN; ) { + for (ccs = CCS_LIST; ccs != NULL; ) { next = ccs->prevStack; - ccs->prevStack = 0; + ccs->prevStack = NULL; ActualPush_(CCS_MAIN,ccs->cc,ccs); ccs->root = ccs->cc; ccs = next; diff --git a/rts/Profiling.h b/rts/Profiling.h index 3a4184f..e27ad4c 100644 --- a/rts/Profiling.h +++ b/rts/Profiling.h @@ -14,9 +14,9 @@ #include "BeginPrivate.h" void initProfiling1 (void); -void freeProfiling1 (void); void initProfiling2 (void); void endProfiling (void); +void freeProfiling (void); extern FILE *prof_file; extern FILE *hp_file; diff --git a/rts/RetainerSet.c b/rts/RetainerSet.c index 5e9b37c..d93ae4b 100644 --- a/rts/RetainerSet.c +++ b/rts/RetainerSet.c @@ -265,35 +265,34 @@ printRetainer(FILE *f, retainer cc) #if defined(RETAINER_SCHEME_INFO) // Retainer scheme 1: retainer = info table void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); // size = strlen(tmp); } } @@ -302,10 +301,9 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; @@ -313,35 +311,34 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CCS) // Retainer scheme 2: retainer = cost centre stack void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; - int size; + char tmp[max_length + 1]; + nat size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); // size = strlen(tmp); } } @@ -350,46 +347,44 @@ printRetainerSetShort(FILE *f, RetainerSet *rs) #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre static void -printRetainerSetShort(FILE *f, retainerSet *rs) +printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); // size = strlen(tmp); } } fprintf(f, tmp); /* - #define MAX_RETAINER_SET_SPACE 24 #define DOT_NUMBER 3 - // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0') - // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for + // 1. 32 > max_length + 1 (1 for '\0') + // 2. (max_length - DOT_NUMBER ) characters should be enough for // printing one natural number (plus '(' and ')'). char tmp[32]; int size, ts; @@ -400,12 +395,12 @@ printRetainerSetShort(FILE *f, retainerSet *rs) // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER); + ASSERT(size < max_length - DOT_NUMBER); for (j = 0; j < rs->num; j++) { ts = strlen(rs->element[j]->label); if (j < rs->num - 1) { - if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts + 1 > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } @@ -413,7 +408,7 @@ printRetainerSetShort(FILE *f, retainerSet *rs) size += ts + 1; } else { - if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } diff --git a/rts/RetainerSet.h b/rts/RetainerSet.h index 74152b9..5004527 100644 --- a/rts/RetainerSet.h +++ b/rts/RetainerSet.h @@ -165,7 +165,7 @@ void traverseAllRetainerSet(void (*f)(RetainerSet *)); #ifdef SECOND_APPROACH // Prints a single retainer set. -void printRetainerSetShort(FILE *, RetainerSet *); +void printRetainerSetShort(FILE *, RetainerSet *, nat); #endif // Print the statistics on all the retainer sets. diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 2530edd..408e1c7 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -13,6 +13,7 @@ #include "RtsOpts.h" #include "RtsUtils.h" #include "Profiling.h" +#include "RtsFlags.h" #ifdef HAVE_CTYPE_H #include @@ -44,20 +45,26 @@ char *rts_argv[MAX_RTS_ARGS]; Static function decls -------------------------------------------------------------------------- */ -static int /* return NULL on error */ -open_stats_file ( - I_ arg, - int argc, char *argv[], - int rts_argc, char *rts_argv[], - const char *FILENAME_FMT, - FILE **file_ret); +static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled); + +static void normaliseRtsOpts (void); + +static void initStatsFile (FILE *f); + +static int openStatsFile (char *filename, const char *FILENAME_FMT, + FILE **file_ret); + +static StgWord64 decodeSize (const char *flag, nat offset, + StgWord64 min, StgWord64 max); + +static void bad_option (const char *s); -static StgWord64 decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max); -static void bad_option(const char *s); #ifdef TRACING static void read_trace_flags(char *arg); #endif +static void errorUsage (void) GNU_ATTRIBUTE(__noreturn__); + /* ----------------------------------------------------------------------------- * Command-line option parsing routines. * ---------------------------------------------------------------------------*/ @@ -360,8 +367,7 @@ strequal(const char *a, const char * b) return(strcmp(a, b) == 0); } -static void -splitRtsFlags(char *s, int *rts_argc, char *rts_argv[]) +static void splitRtsFlags(char *s) { char *c1, *c2; @@ -373,11 +379,11 @@ splitRtsFlags(char *s, int *rts_argc, char *rts_argv[]) if (c1 == c2) { break; } - if (*rts_argc < MAX_RTS_ARGS-1) { + if (rts_argc < MAX_RTS_ARGS-1) { s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()"); strncpy(s, c1, c2-c1); s[c2-c1] = '\0'; - rts_argv[(*rts_argc)++] = s; + rts_argv[rts_argc++] = s; } else { barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1); } @@ -386,27 +392,48 @@ splitRtsFlags(char *s, int *rts_argc, char *rts_argv[]) } while (*c1 != '\0'); } -void -setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) +/* ----------------------------------------------------------------------------- + Parse the command line arguments, collecting options for the RTS. + + On return: + - argv[] is *modified*, any RTS options have been stripped out + - *argc contains the new count of arguments in argv[] + + - rts_argv[] (global) contains the collected RTS args + - rts_argc (global) contains the count of args in rts_argv + + - prog_argv[] (global) contains the non-RTS args (== argv) + - prog_argc (global) contains the count of args in prog_argv + + - prog_name (global) contains the basename of argv[0] + + -------------------------------------------------------------------------- */ + +void setupRtsFlags (int *argc, char *argv[]) { - rtsBool error = rtsFalse; - I_ mode; - I_ arg, total_arg; + nat mode; + nat total_arg; + nat arg, rts_argc0; setProgName (argv); total_arg = *argc; arg = 1; *argc = 1; - *rts_argc = 0; + rts_argc = 0; + + rts_argc0 = rts_argc; // process arguments from the ghc_rts_opts global variable first. // (arguments from the GHCRTS environment variable and the command // line override these). { if (ghc_rts_opts != NULL) { - splitRtsFlags(ghc_rts_opts, rts_argc, rts_argv); - } + splitRtsFlags(ghc_rts_opts); + // opts from ghc_rts_opts are always enabled: + procRtsOpts(rts_argc0, RtsOptsAll); + rts_argc0 = rts_argc; + } } // process arguments from the GHCRTS environment variable next @@ -415,14 +442,15 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) char *ghc_rts = getenv("GHCRTS"); if (ghc_rts != NULL) { - if (rtsOptsEnabled != rtsOptsNone) { - splitRtsFlags(ghc_rts, rts_argc, rts_argv); - } - else { + if (rtsOptsEnabled == RtsOptsNone) { errorBelch("Warning: Ignoring GHCRTS variable as RTS options are disabled.\n Link with -rtsopts to enable them."); // We don't actually exit, just warn + } else { + splitRtsFlags(ghc_rts); + procRtsOpts(rts_argc0, rtsOptsEnabled); + rts_argc0 = rts_argc; } - } + } } // Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts @@ -440,19 +468,13 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) break; } else if (strequal("+RTS", argv[arg])) { - if (rtsOptsEnabled != rtsOptsNone) { - mode = RTS; - } - else { - errorBelch("RTS options are disabled. Link with -rtsopts to enable them."); - stg_exit(EXIT_FAILURE); - } - } + mode = RTS; + } else if (strequal("-RTS", argv[arg])) { mode = PGM; } - else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) { - rts_argv[(*rts_argc)++] = argv[arg]; + else if (mode == RTS && rts_argc < MAX_RTS_ARGS-1) { + rts_argv[rts_argc++] = argv[arg]; } else if (mode == PGM) { argv[(*argc)++] = argv[arg]; @@ -466,17 +488,45 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) argv[(*argc)++] = argv[arg]; } argv[*argc] = (char *) 0; - rts_argv[*rts_argc] = (char *) 0; + rts_argv[rts_argc] = (char *) 0; + + procRtsOpts(rts_argc0, rtsOptsEnabled); + + normaliseRtsOpts(); + + setProgArgv(*argc, argv); + + if (RtsFlags.GcFlags.statsFile != NULL) { + initStatsFile (RtsFlags.GcFlags.statsFile); + } + if (RtsFlags.TickyFlags.tickyFile != NULL) { + initStatsFile (RtsFlags.GcFlags.statsFile); + } +} + +/* ----------------------------------------------------------------------------- + * procRtsOpts: Process rts_argv between rts_argc0 and rts_argc. + * -------------------------------------------------------------------------- */ + +static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled) +{ + rtsBool error = rtsFalse; + int arg; // Process RTS (rts_argv) part: mainly to determine statsfile - for (arg = 0; arg < *rts_argc; arg++) { - if (rts_argv[arg][0] != '-') { + for (arg = rts_argc0; arg < rts_argc; arg++) { + if (rts_argv[arg][0] != '-') { fflush(stdout); errorBelch("unexpected RTS argument: %s", rts_argv[arg]); error = rtsTrue; } else { + if (enabled == RtsOptsNone) { + errorBelch("RTS options are disabled. Link with -rtsopts to enable them."); + stg_exit(EXIT_FAILURE); + } + switch(rts_argv[arg][1]) { case '-': if (strequal("info", &rts_argv[arg][2])) { @@ -488,8 +538,7 @@ setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) break; } - if (rtsOptsEnabled != rtsOptsAll) - { + if (enabled == RtsOptsSafeOnly) { errorBelch("Most RTS options are disabled. Link with -rtsopts to enable them."); stg_exit(EXIT_FAILURE); } @@ -791,9 +840,8 @@ error = rtsTrue; stats: { int r; - r = open_stats_file(arg, *argc, argv, - *rts_argc, rts_argv, NULL, - &RtsFlags.GcFlags.statsFile); + r = openStatsFile(rts_argv[arg]+2, NULL, + &RtsFlags.GcFlags.statsFile); if (r == -1) { error = rtsTrue; } } break; @@ -1097,9 +1145,9 @@ error = rtsTrue; { int r; - r = open_stats_file(arg, *argc, argv, - *rts_argc, rts_argv, TICKY_FILENAME_FMT, - &RtsFlags.TickyFlags.tickyFile); + r = openStatsFile(rts_argv[arg]+2, + TICKY_FILENAME_FMT, + &RtsFlags.TickyFlags.tickyFile); if (r == -1) { error = rtsTrue; } } ) break; @@ -1184,6 +1232,16 @@ error = rtsTrue; } } + if (error) errorUsage(); +} + +/* ----------------------------------------------------------------------------- + * normaliseRtsOpts: Set some derived values, and make sure things are + * within sensible ranges. + * -------------------------------------------------------------------------- */ + +static void normaliseRtsOpts (void) +{ if (RtsFlags.MiscFlags.tickInterval < 0) { RtsFlags.MiscFlags.tickInterval = 50; } @@ -1235,20 +1293,20 @@ error = rtsTrue; if (RtsFlags.GcFlags.stkChunkBufferSize > RtsFlags.GcFlags.stkChunkSize / 2) { errorBelch("stack chunk buffer size (-kb) must be less than 50%% of the stack chunk size (-kc)"); - error = rtsTrue; + errorUsage(); } +} - if (error) { - const char **p; +static void errorUsage (void) +{ + const char **p; - fflush(stdout); - for (p = usage_text; *p; p++) - errorBelch("%s", *p); - stg_exit(EXIT_FAILURE); - } + fflush(stdout); + for (p = usage_text; *p; p++) + errorBelch("%s", *p); + stg_exit(EXIT_FAILURE); } - static void stats_fprintf(FILE *f, char *s, ...) { @@ -1262,49 +1320,62 @@ stats_fprintf(FILE *f, char *s, ...) va_end(ap); } -static int /* return -1 on error */ -open_stats_file ( - I_ arg, - int argc, char *argv[], - int rts_argc, char *rts_argv[], - const char *FILENAME_FMT, - FILE **file_ret) +/* ----------------------------------------------------------------------------- + * openStatsFile: open a file in which to put some runtime stats + * -------------------------------------------------------------------------- */ + +static int // return -1 on error +openStatsFile (char *filename, // filename, or NULL + const char *filename_fmt, // if filename == NULL, use + // this fmt with sprintf to + // generate the filename. %s + // expands to the program name. + FILE **file_ret) // return the FILE* { FILE *f = NULL; - if (strequal(rts_argv[arg]+2, "stderr") - || (FILENAME_FMT == NULL && rts_argv[arg][2] == '\0')) { + if (strequal(filename, "stderr") + || (filename_fmt == NULL && *filename == '\0')) { f = NULL; /* NULL means use debugBelch */ } else { - if (rts_argv[arg][2] != '\0') { /* stats file specified */ - f = fopen(rts_argv[arg]+2,"w"); + if (*filename != '\0') { /* stats file specified */ + f = fopen(filename,"w"); } else { char stats_filename[STATS_FILENAME_MAXLEN]; /* default . */ - sprintf(stats_filename, FILENAME_FMT, argv[0]); + sprintf(stats_filename, filename_fmt, prog_name); f = fopen(stats_filename,"w"); } if (f == NULL) { - errorBelch("Can't open stats file %s\n", rts_argv[arg]+2); + errorBelch("Can't open stats file %s\n", filename); return -1; } } *file_ret = f; - { - /* Write argv and rtsv into start of stats file */ - int count; - for(count = 0; count < argc; count++) { - stats_fprintf(f, "%s ", argv[count]); - } - stats_fprintf(f, "+RTS "); - for(count = 0; count < rts_argc; count++) - stats_fprintf(f, "%s ", rts_argv[count]); - stats_fprintf(f, "\n"); - } return 0; } +/* ----------------------------------------------------------------------------- + * initStatsFile: write a line to the file containing the program name + * and the arguments it was invoked with. +-------------------------------------------------------------------------- */ +static void initStatsFile (FILE *f) +{ + /* Write prog_argv and rts_argv into start of stats file */ + int count; + for (count = 0; count < prog_argc; count++) { + stats_fprintf(f, "%s ", prog_argv[count]); + } + stats_fprintf(f, "+RTS "); + for (count = 0; count < rts_argc; count++) + stats_fprintf(f, "%s ", rts_argv[count]); + stats_fprintf(f, "\n"); +} + +/* ----------------------------------------------------------------------------- + * decodeSize: parse a string containing a size, like 300K or 1.2M +-------------------------------------------------------------------------- */ static StgWord64 decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) @@ -1420,14 +1491,9 @@ getProgArgv(int *argc, char **argv[]) void setProgArgv(int argc, char *argv[]) { - /* Usually this is done by startupHaskell, so we don't need to call this. - However, sometimes Hugs wants to change the arguments which Haskell - getArgs >>= ... will be fed. So you can do that by calling here - _after_ calling startupHaskell. - */ - prog_argc = argc; - prog_argv = argv; - setProgName(prog_argv); + prog_argc = argc; + prog_argv = argv; + setProgName(prog_argv); } /* These functions record and recall the full arguments, including the diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h new file mode 100644 index 0000000..3ebfef6 --- /dev/null +++ b/rts/RtsFlags.h @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The AQUA Project, Glasgow University, 1994-1997 + * (c) The GHC Team, 1998-2006 + * + * Functions for parsing the argument list. + * + * ---------------------------------------------------------------------------*/ + +#ifndef RTSFLAGS_H +#define RTSFLAGS_H + +#include "BeginPrivate.h" + +/* Routines that operate-on/to-do-with RTS flags: */ + +void initRtsFlagsDefaults (void); +void setupRtsFlags (int *argc, char *argv[]); +void setProgName (char *argv[]); + +#include "EndPrivate.h" + +#endif /* RTSFLAGS_H */ diff --git a/rts/RtsMain.c b/rts/RtsMain.c index b6cf546..0ed6df4 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -28,13 +28,10 @@ # include #endif -extern void __stginit_ZCMain(void); - /* Annoying global vars for passing parameters to real_main() below * This is to get around problem with Windows SEH, see hs_main(). */ static int progargc; static char **progargv; -static void (*progmain_init)(void); /* This will be __stginit_ZCMain */ static StgClosure *progmain_closure; /* This will be ZCMain_main_closure */ /* Hack: we assume that we're building a batch-mode system unless @@ -47,7 +44,7 @@ static void real_main(void) SchedulerStatus status; /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ - startupHaskell(progargc,progargv,progmain_init); + startupHaskell(progargc,progargv,NULL); /* kick off the computation by creating the main thread with a pointer to mainIO_closure representing the computation of the overall program; @@ -95,18 +92,17 @@ static void real_main(void) * This gets called from a tiny main function which gets linked into each * compiled Haskell program that uses a Haskell main function. * - * We expect the caller to pass __stginit_ZCMain for main_init and - * ZCMain_main_closure for main_closure. The reason we cannot refer to - * these symbols directly is because we're inside the rts and we do not know - * for sure that we'll be using a Haskell main function. + * We expect the caller to pass ZCMain_main_closure for + * main_closure. The reason we cannot refer to this symbol directly + * is because we're inside the rts and we do not know for sure that + * we'll be using a Haskell main function. */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure) +int hs_main(int argc, char *argv[], StgClosure *main_closure) { /* We do this dance with argc and argv as otherwise the SEH exception stuff (the BEGIN/END CATCH below) on Windows gets confused */ progargc = argc; progargv = argv; - progmain_init = main_init; progmain_closure = main_closure; #if defined(mingw32_HOST_OS) diff --git a/rts/RtsMain.h b/rts/RtsMain.h index 4aabc56..24e5819 100644 --- a/rts/RtsMain.h +++ b/rts/RtsMain.h @@ -13,6 +13,6 @@ * The entry point for Haskell programs that use a Haskell main function * -------------------------------------------------------------------------- */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure); +int hs_main(int argc, char *argv[], StgClosure *main_closure); #endif /* RTSMAIN_H */ diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 266c048..236d07a 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -16,6 +16,7 @@ #include "HsFFI.h" #include "sm/Storage.h" +#include "RtsFlags.h" #include "RtsUtils.h" #include "Prelude.h" #include "Schedule.h" /* initScheduler */ @@ -129,8 +130,7 @@ hs_init(int *argc, char **argv[]) /* Parse the flags, separating the RTS flags from the programs args */ if (argc != NULL && argv != NULL) { setFullProgArgv(*argc,*argv); - setupRtsFlags(argc, *argv, &rts_argc, rts_argv); - setProgArgv(*argc,*argv); + setupRtsFlags(argc, *argv); } /* Initialise the stats department, phase 1 */ @@ -224,90 +224,37 @@ hs_init(int *argc, char **argv[]) x86_init_fpu(); #endif + startupHpc(); + + // This must be done after module initialisation. + // ToDo: make this work in the presence of multiple hs_add_root()s. + initProfiling2(); + + // ditto. +#if defined(THREADED_RTS) + ioManagerStart(); +#endif + /* Record initialization times */ stat_endInit(); } // Compatibility interface void -startupHaskell(int argc, char *argv[], void (*init_root)(void)) +startupHaskell(int argc, char *argv[], void (*init_root)(void) STG_UNUSED) { hs_init(&argc, &argv); - if(init_root) - hs_add_root(init_root); } /* ----------------------------------------------------------------------------- - Per-module initialisation - - This process traverses all the compiled modules in the program - starting with "Main", and performing per-module initialisation for - each one. - - So far, two things happen at initialisation time: - - - we register stable names for each foreign-exported function - in that module. This prevents foreign-exported entities, and - things they depend on, from being garbage collected. - - - we supply a unique integer to each statically declared cost - centre and cost centre stack in the program. - - The code generator inserts a small function "__stginit_" in each - module and calls the registration functions in each of the modules it - imports. - - The init* functions are compiled in the same way as STG code, - i.e. without normal C call/return conventions. Hence we must use - StgRun to call this stuff. + hs_add_root: backwards compatibility. (see #3252) -------------------------------------------------------------------------- */ -/* The init functions use an explicit stack... - */ -#define INIT_STACK_BLOCKS 4 -static StgFunPtr *init_stack = NULL; - void -hs_add_root(void (*init_root)(void)) +hs_add_root(void (*init_root)(void) STG_UNUSED) { - bdescr *bd; - nat init_sp; - Capability *cap; - - cap = rts_lock(); - - if (hs_init_count <= 0) { - barf("hs_add_root() must be called after hs_init()"); - } - - /* The initialisation stack grows downward, with sp pointing - to the last occupied word */ - init_sp = INIT_STACK_BLOCKS*BLOCK_SIZE_W; - bd = allocGroup_lock(INIT_STACK_BLOCKS); - init_stack = (StgFunPtr *)bd->start; - init_stack[--init_sp] = (StgFunPtr)stg_init_finish; - if (init_root != NULL) { - init_stack[--init_sp] = (StgFunPtr)init_root; - } - - cap->r.rSp = (P_)(init_stack + init_sp); - StgRun((StgFunPtr)stg_init, &cap->r); - - freeGroup_lock(bd); - - startupHpc(); - - // This must be done after module initialisation. - // ToDo: make this work in the presence of multiple hs_add_root()s. - initProfiling2(); - - rts_unlock(cap); - - // ditto. -#if defined(THREADED_RTS) - ioManagerStart(); -#endif + /* nothing */ } /* ---------------------------------------------------------------------------- @@ -424,7 +371,7 @@ hs_exit_(rtsBool wait_foreign) #endif endProfiling(); - freeProfiling1(); + freeProfiling(); #ifdef PROFILING // Originally, this was in report_ccs_profiling(). Now, retainer diff --git a/rts/STM.c b/rts/STM.c index 3de42e2..e8d3fc0 100644 --- a/rts/STM.c +++ b/rts/STM.c @@ -879,17 +879,12 @@ static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) { /************************************************************************/ -void stmPreGCHook() { - nat i; - +void stmPreGCHook (Capability *cap) { lock_stm(NO_TREC); TRACE("stmPreGCHook"); - for (i = 0; i < n_capabilities; i ++) { - Capability *cap = &capabilities[i]; - cap -> free_tvar_watch_queues = END_STM_WATCH_QUEUE; - cap -> free_trec_chunks = END_STM_CHUNK_LIST; - cap -> free_trec_headers = NO_TREC; - } + cap->free_tvar_watch_queues = END_STM_WATCH_QUEUE; + cap->free_trec_chunks = END_STM_CHUNK_LIST; + cap->free_trec_headers = NO_TREC; unlock_stm(NO_TREC); } diff --git a/rts/STM.h b/rts/STM.h index f15a681..dd11bb8 100644 --- a/rts/STM.h +++ b/rts/STM.h @@ -48,7 +48,7 @@ -------------- */ -void stmPreGCHook(void); +void stmPreGCHook(Capability *cap); /*---------------------------------------------------------------------- diff --git a/rts/Schedule.c b/rts/Schedule.c index 382ba97..f5cb568 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -2069,6 +2069,16 @@ freeScheduler( void ) #endif } +void markScheduler (evac_fn evac USED_IF_NOT_THREADS, + void *user USED_IF_NOT_THREADS) +{ +#if !defined(THREADED_RTS) + evac(user, (StgClosure **)(void *)&blocked_queue_hd); + evac(user, (StgClosure **)(void *)&blocked_queue_tl); + evac(user, (StgClosure **)(void *)&sleeping_queue); +#endif +} + /* ----------------------------------------------------------------------------- performGC diff --git a/rts/Schedule.h b/rts/Schedule.h index edba8f5..549f555 100644 --- a/rts/Schedule.h +++ b/rts/Schedule.h @@ -23,6 +23,7 @@ void initScheduler (void); void exitScheduler (rtsBool wait_foreign); void freeScheduler (void); +void markScheduler (evac_fn evac, void *user); // Place a new thread on the run queue of the current Capability void scheduleThread (Capability *cap, StgTSO *tso); diff --git a/rts/Stats.c b/rts/Stats.c index 4b9f6d8..fa38472 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -16,6 +16,8 @@ #include "GetTime.h" #include "sm/Storage.h" #include "sm/GC.h" // gc_alloc_block_sync, whitehole_spin +#include "sm/GCThread.h" +#include "sm/BlockAlloc.h" #if USE_PAPI #include "Papi.h" @@ -26,31 +28,23 @@ #define TICK_TO_DBL(t) ((double)(t) / TICKS_PER_SECOND) -static Ticks ElapsedTimeStart = 0; +static Ticks + start_init_cpu, start_init_elapsed, + end_init_cpu, end_init_elapsed, + start_exit_cpu, start_exit_elapsed, + end_exit_cpu, end_exit_elapsed; -static Ticks InitUserTime = 0; -static Ticks InitElapsedTime = 0; -static Ticks InitElapsedStamp = 0; +static Ticks GC_tot_cpu = 0; -static Ticks MutUserTime = 0; -static Ticks MutElapsedTime = 0; -static Ticks MutElapsedStamp = 0; - -static Ticks ExitUserTime = 0; -static Ticks ExitElapsedTime = 0; - -static StgWord64 GC_tot_alloc = 0; -static StgWord64 GC_tot_copied = 0; +static StgWord64 GC_tot_alloc = 0; +static StgWord64 GC_tot_copied = 0; static StgWord64 GC_par_max_copied = 0; static StgWord64 GC_par_avg_copied = 0; -static Ticks GC_start_time = 0, GC_tot_time = 0; /* User GC Time */ -static Ticks GCe_start_time = 0, GCe_tot_time = 0; /* Elapsed GC time */ - #ifdef PROFILING -static Ticks RP_start_time = 0, RP_tot_time = 0; /* retainer prof user time */ -static Ticks RPe_start_time = 0, RPe_tot_time = 0; /* retainer prof elap time */ +static Ticks RP_start_time = 0, RP_tot_time = 0; // retainer prof user time +static Ticks RPe_start_time = 0, RPe_tot_time = 0; // retainer prof elap time static Ticks HC_start_time, HC_tot_time = 0; // heap census prof user time static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time @@ -62,99 +56,81 @@ static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time #define PROF_VAL(x) 0 #endif -static lnat MaxResidency = 0; // in words; for stats only -static lnat AvgResidency = 0; -static lnat ResidencySamples = 0; // for stats only -static lnat MaxSlop = 0; +static lnat max_residency = 0; // in words; for stats only +static lnat avg_residency = 0; +static lnat residency_samples = 0; // for stats only +static lnat max_slop = 0; -static lnat GC_start_faults = 0, GC_end_faults = 0; +static lnat GC_end_faults = 0; -static Ticks *GC_coll_times = NULL; -static Ticks *GC_coll_etimes = NULL; +static Ticks *GC_coll_cpu = NULL; +static Ticks *GC_coll_elapsed = NULL; +static Ticks *GC_coll_max_pause = NULL; static void statsFlush( void ); static void statsClose( void ); -Ticks stat_getElapsedGCTime(void) -{ - return GCe_tot_time; -} +/* ----------------------------------------------------------------------------- + Current elapsed time + ------------------------------------------------------------------------- */ Ticks stat_getElapsedTime(void) { - return getProcessElapsedTime() - ElapsedTimeStart; + return getProcessElapsedTime() - start_init_elapsed; } -/* mut_user_time_during_GC() and mut_user_time() - * - * The former function can be used to get the current mutator time - * *during* a GC, i.e. between stat_startGC and stat_endGC. This is - * used in the heap profiler for accurately time stamping the heap - * sample. - * - * ATTENTION: mut_user_time_during_GC() relies on GC_start_time being - * defined in stat_startGC() - to minimise system calls, - * GC_start_time is, however, only defined when really needed (check - * stat_startGC() for details) - */ -double -mut_user_time_during_GC( void ) -{ - return TICK_TO_DBL(GC_start_time - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time)); -} +/* --------------------------------------------------------------------------- + Measure the current MUT time, for profiling + ------------------------------------------------------------------------ */ double mut_user_time( void ) { - Ticks user; - user = getProcessCPUTime(); - return TICK_TO_DBL(user - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time)); + Ticks cpu; + cpu = getProcessCPUTime(); + return TICK_TO_DBL(cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time)); } #ifdef PROFILING /* - mut_user_time_during_RP() is similar to mut_user_time_during_GC(); - it returns the MUT time during retainer profiling. + mut_user_time_during_RP() returns the MUT time during retainer profiling. The same is for mut_user_time_during_HC(); */ double mut_user_time_during_RP( void ) { - return TICK_TO_DBL(RP_start_time - GC_tot_time - RP_tot_time - HC_tot_time); + return TICK_TO_DBL(RP_start_time - GC_tot_cpu - RP_tot_time - HC_tot_time); } double mut_user_time_during_heap_census( void ) { - return TICK_TO_DBL(HC_start_time - GC_tot_time - RP_tot_time - HC_tot_time); + return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time - HC_tot_time); } #endif /* PROFILING */ -// initStats0() has no dependencies, it can be called right at the beginning +/* --------------------------------------------------------------------------- + initStats0() has no dependencies, it can be called right at the beginning + ------------------------------------------------------------------------ */ + void initStats0(void) { - ElapsedTimeStart = 0; - - InitUserTime = 0; - InitElapsedTime = 0; - InitElapsedStamp = 0; - - MutUserTime = 0; - MutElapsedTime = 0; - MutElapsedStamp = 0; + start_init_cpu = 0; + start_init_elapsed = 0; + end_init_cpu = 0; + end_init_elapsed = 0; - ExitUserTime = 0; - ExitElapsedTime = 0; + start_exit_cpu = 0; + start_exit_elapsed = 0; + end_exit_cpu = 0; + end_exit_elapsed = 0; GC_tot_alloc = 0; GC_tot_copied = 0; GC_par_max_copied = 0; GC_par_avg_copied = 0; - GC_start_time = 0; - GC_tot_time = 0; - GCe_start_time = 0; - GCe_tot_time = 0; + GC_tot_cpu = 0; #ifdef PROFILING RP_start_time = 0; @@ -168,16 +144,18 @@ initStats0(void) HCe_tot_time = 0; #endif - MaxResidency = 0; - AvgResidency = 0; - ResidencySamples = 0; - MaxSlop = 0; + max_residency = 0; + avg_residency = 0; + residency_samples = 0; + max_slop = 0; - GC_start_faults = 0; GC_end_faults = 0; } -// initStats1() can be called after setupRtsFlags() +/* --------------------------------------------------------------------------- + initStats1() can be called after setupRtsFlags() + ------------------------------------------------------------------------ */ + void initStats1 (void) { @@ -187,17 +165,22 @@ initStats1 (void) statsPrintf(" Alloc Copied Live GC GC TOT TOT Page Flts\n"); statsPrintf(" bytes bytes bytes user elap user elap\n"); } - GC_coll_times = + GC_coll_cpu = + (Ticks *)stgMallocBytes( + sizeof(Ticks)*RtsFlags.GcFlags.generations, + "initStats"); + GC_coll_elapsed = (Ticks *)stgMallocBytes( sizeof(Ticks)*RtsFlags.GcFlags.generations, "initStats"); - GC_coll_etimes = + GC_coll_max_pause = (Ticks *)stgMallocBytes( sizeof(Ticks)*RtsFlags.GcFlags.generations, "initStats"); for (i = 0; i < RtsFlags.GcFlags.generations; i++) { - GC_coll_times[i] = 0; - GC_coll_etimes[i] = 0; + GC_coll_cpu[i] = 0; + GC_coll_elapsed[i] = 0; + GC_coll_max_pause[i] = 0; } } @@ -208,26 +191,14 @@ initStats1 (void) void stat_startInit(void) { - Ticks elapsed; - - elapsed = getProcessElapsedTime(); - ElapsedTimeStart = elapsed; + getProcessTimes(&start_init_cpu, &start_init_elapsed); } void stat_endInit(void) { - Ticks user, elapsed; - - getProcessTimes(&user, &elapsed); + getProcessTimes(&end_init_cpu, &end_init_elapsed); - InitUserTime = user; - InitElapsedStamp = elapsed; - if (ElapsedTimeStart > elapsed) { - InitElapsedTime = 0; - } else { - InitElapsedTime = elapsed - ElapsedTimeStart; - } #if USE_PAPI /* We start counting events for the mutator * when garbage collection starts @@ -249,18 +220,7 @@ stat_endInit(void) void stat_startExit(void) { - Ticks user, elapsed; - - getProcessTimes(&user, &elapsed); - - MutElapsedStamp = elapsed; - MutElapsedTime = elapsed - GCe_tot_time - - PROF_VAL(RPe_tot_time + HCe_tot_time) - InitElapsedStamp; - if (MutElapsedTime < 0) { MutElapsedTime = 0; } /* sometimes -0.00 */ - - MutUserTime = user - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime; - if (MutUserTime < 0) { MutUserTime = 0; } + getProcessTimes(&start_exit_cpu, &start_exit_elapsed); #if USE_PAPI /* We stop counting mutator events @@ -269,25 +229,13 @@ stat_startExit(void) /* This flag is needed, because GC is run once more after this function */ papi_is_reporting = 0; - #endif } void stat_endExit(void) { - Ticks user, elapsed; - - getProcessTimes(&user, &elapsed); - - ExitUserTime = user - MutUserTime - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime; - ExitElapsedTime = elapsed - MutElapsedStamp; - if (ExitUserTime < 0) { - ExitUserTime = 0; - } - if (ExitElapsedTime < 0) { - ExitElapsedTime = 0; - } + getProcessTimes(&end_exit_cpu, &end_exit_elapsed); } /* ----------------------------------------------------------------------------- @@ -296,13 +244,8 @@ stat_endExit(void) static nat rub_bell = 0; -/* initialise global variables needed during GC - * - * * GC_start_time is read in mut_user_time_during_GC(), which in turn is - * needed if either PROFILING or DEBUGing is enabled - */ void -stat_startGC(void) +stat_startGC (gc_thread *gct) { nat bell = RtsFlags.GcFlags.ringBell; @@ -315,16 +258,6 @@ stat_startGC(void) } } - if (RtsFlags.GcFlags.giveStats != NO_GC_STATS - || RtsFlags.ProfFlags.doHeapProfile) - // heap profiling needs GC_tot_time - { - getProcessTimes(&GC_start_time, &GCe_start_time); - if (RtsFlags.GcFlags.giveStats) { - GC_start_faults = getPageFaults(); - } - } - #if USE_PAPI if(papi_is_reporting) { /* Switch to counting GC events */ @@ -333,6 +266,40 @@ stat_startGC(void) } #endif + getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); + gct->gc_start_thread_cpu = getThreadCPUTime(); + + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + gct->gc_start_faults = getPageFaults(); + } +} + +void +stat_gcWorkerThreadStart (gc_thread *gct) +{ + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); + gct->gc_start_thread_cpu = getThreadCPUTime(); + } +} + +void +stat_gcWorkerThreadDone (gc_thread *gct) +{ + Ticks thread_cpu, elapsed, gc_cpu, gc_elapsed; + + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + elapsed = getProcessElapsedTime(); + thread_cpu = getThreadCPUTime(); + + gc_cpu = thread_cpu - gct->gc_start_thread_cpu; + gc_elapsed = elapsed - gct->gc_start_elapsed; + + taskDoneGC(gct->cap->running_task, gc_cpu, gc_elapsed); + } } /* ----------------------------------------------------------------------------- @@ -340,67 +307,65 @@ stat_startGC(void) -------------------------------------------------------------------------- */ void -stat_endGC (lnat alloc, lnat live, lnat copied, lnat gen, +stat_endGC (gc_thread *gct, + lnat alloc, lnat live, lnat copied, nat gen, lnat max_copied, lnat avg_copied, lnat slop) { if (RtsFlags.GcFlags.giveStats != NO_GC_STATS || RtsFlags.ProfFlags.doHeapProfile) // heap profiling needs GC_tot_time { - Ticks time, etime, gc_time, gc_etime; - - getProcessTimes(&time, &etime); - gc_time = time - GC_start_time; - gc_etime = etime - GCe_start_time; + Ticks cpu, elapsed, thread_gc_cpu, gc_cpu, gc_elapsed; - if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { + getProcessTimes(&cpu, &elapsed); + gc_elapsed = elapsed - gct->gc_start_elapsed; + + thread_gc_cpu = getThreadCPUTime() - gct->gc_start_thread_cpu; + + gc_cpu = cpu - gct->gc_start_cpu; + + taskDoneGC(gct->cap->running_task, thread_gc_cpu, gc_elapsed); + + if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { nat faults = getPageFaults(); statsPrintf("%9ld %9ld %9ld", alloc*sizeof(W_), copied*sizeof(W_), live*sizeof(W_)); - statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2ld)\n", - TICK_TO_DBL(gc_time), - TICK_TO_DBL(gc_etime), - TICK_TO_DBL(time), - TICK_TO_DBL(etime - ElapsedTimeStart), - faults - GC_start_faults, - GC_start_faults - GC_end_faults, - gen); - - GC_end_faults = faults; + statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2d)\n", + TICK_TO_DBL(gc_cpu), + TICK_TO_DBL(gc_elapsed), + TICK_TO_DBL(cpu), + TICK_TO_DBL(elapsed - start_init_elapsed), + faults - gct->gc_start_faults, + gct->gc_start_faults - GC_end_faults, + gen); + + GC_end_faults = faults; statsFlush(); } - GC_coll_times[gen] += gc_time; - GC_coll_etimes[gen] += gc_etime; + GC_coll_cpu[gen] += gc_cpu; + GC_coll_elapsed[gen] += gc_elapsed; + if (GC_coll_max_pause[gen] < gc_elapsed) { + GC_coll_max_pause[gen] = gc_elapsed; + } GC_tot_copied += (StgWord64) copied; GC_tot_alloc += (StgWord64) alloc; GC_par_max_copied += (StgWord64) max_copied; GC_par_avg_copied += (StgWord64) avg_copied; - GC_tot_time += gc_time; - GCe_tot_time += gc_etime; - -#if defined(THREADED_RTS) - { - Task *task; - if ((task = myTask()) != NULL) { - task->gc_time += gc_time; - task->gc_etime += gc_etime; - } - } -#endif + GC_tot_cpu += gc_cpu; if (gen == RtsFlags.GcFlags.generations-1) { /* major GC? */ - if (live > MaxResidency) { - MaxResidency = live; + if (live > max_residency) { + max_residency = live; } - ResidencySamples++; - AvgResidency += live; + residency_samples++; + avg_residency += live; } - if (slop > MaxSlop) MaxSlop = slop; + if (slop > max_slop) max_slop = slop; } if (rub_bell) { @@ -539,20 +504,28 @@ StgInt TOTAL_CALLS=1; statsPrintf(" (SLOW_CALLS_" #arity ") %% of (TOTAL_CALLS) : %.1f%%\n", \ SLOW_CALLS_##arity * 100.0/TOTAL_CALLS) -extern lnat hw_alloc_blocks; - void stat_exit(int alloc) { + generation *gen; + Ticks gc_cpu = 0; + Ticks gc_elapsed = 0; + Ticks init_cpu = 0; + Ticks init_elapsed = 0; + Ticks mut_cpu = 0; + Ticks mut_elapsed = 0; + Ticks exit_cpu = 0; + Ticks exit_elapsed = 0; + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { char temp[BIG_STRING_LEN]; - Ticks time; - Ticks etime; - nat g, total_collections = 0; + Ticks tot_cpu; + Ticks tot_elapsed; + nat i, g, total_collections = 0; - getProcessTimes( &time, &etime ); - etime -= ElapsedTimeStart; + getProcessTimes( &tot_cpu, &tot_elapsed ); + tot_elapsed -= start_init_elapsed; GC_tot_alloc += alloc; @@ -560,15 +533,20 @@ stat_exit(int alloc) for (g = 0; g < RtsFlags.GcFlags.generations; g++) total_collections += generations[g].collections; - /* avoid divide by zero if time is measured as 0.00 seconds -- SDM */ - if (time == 0.0) time = 1; - if (etime == 0.0) etime = 1; + /* avoid divide by zero if tot_cpu is measured as 0.00 seconds -- SDM */ + if (tot_cpu == 0.0) tot_cpu = 1; + if (tot_elapsed == 0.0) tot_elapsed = 1; if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) { statsPrintf("%9ld %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", ""); statsPrintf(" %5.2f %5.2f\n\n", 0.0, 0.0); } + for (i = 0; i < RtsFlags.GcFlags.generations; i++) { + gc_cpu += GC_coll_cpu[i]; + gc_elapsed += GC_coll_elapsed[i]; + } + if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) { showStgWord64(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); @@ -578,14 +556,14 @@ stat_exit(int alloc) temp, rtsTrue/*commas*/); statsPrintf("%16s bytes copied during GC\n", temp); - if ( ResidencySamples > 0 ) { - showStgWord64(MaxResidency*sizeof(W_), + if ( residency_samples > 0 ) { + showStgWord64(max_residency*sizeof(W_), temp, rtsTrue/*commas*/); statsPrintf("%16s bytes maximum residency (%ld sample(s))\n", - temp, ResidencySamples); + temp, residency_samples); } - showStgWord64(MaxSlop*sizeof(W_), temp, rtsTrue/*commas*/); + showStgWord64(max_slop*sizeof(W_), temp, rtsTrue/*commas*/); statsPrintf("%16s bytes maximum slop\n", temp); statsPrintf("%16ld MB total memory in use (%ld MB lost due to fragmentation)\n\n", @@ -593,13 +571,18 @@ stat_exit(int alloc) (peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_))); /* Print garbage collections in each gen */ - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - statsPrintf(" Generation %d: %5d collections, %5d parallel, %5.2fs, %5.2fs elapsed\n", - g, generations[g].collections, - generations[g].par_collections, - TICK_TO_DBL(GC_coll_times[g]), - TICK_TO_DBL(GC_coll_etimes[g])); - } + statsPrintf(" Tot time (elapsed) Avg pause Max pause\n"); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + gen = &generations[g]; + statsPrintf(" Gen %2d %5d colls, %5d par %5.2fs %5.2fs %3.4fs %3.4fs\n", + gen->no, + gen->collections, + gen->par_collections, + TICK_TO_DBL(GC_coll_cpu[g]), + TICK_TO_DBL(GC_coll_elapsed[g]), + gen->collections == 0 ? 0 : TICK_TO_DBL(GC_coll_elapsed[g] / gen->collections), + TICK_TO_DBL(GC_coll_max_pause[g])); + } #if defined(THREADED_RTS) if (RtsFlags.ParFlags.parGcEnabled) { @@ -610,8 +593,7 @@ stat_exit(int alloc) ); } #endif - - statsPrintf("\n"); + statsPrintf("\n"); #if defined(THREADED_RTS) { @@ -653,44 +635,60 @@ stat_exit(int alloc) } #endif - statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(InitUserTime), TICK_TO_DBL(InitElapsedTime)); - statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(MutUserTime), TICK_TO_DBL(MutElapsedTime)); - statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(GC_tot_time), TICK_TO_DBL(GCe_tot_time)); + init_cpu = end_init_cpu - start_init_cpu; + init_elapsed = end_init_elapsed - start_init_elapsed; + + exit_cpu = end_exit_cpu - start_exit_cpu; + exit_elapsed = end_exit_elapsed - start_exit_elapsed; + + statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed)); + + mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; + + mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu + - PROF_VAL(RP_tot_time + HC_tot_time); + if (mut_cpu < 0) { mut_cpu = 0; } + + statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed)); + statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); + #ifdef PROFILING - statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(RP_tot_time), TICK_TO_DBL(RPe_tot_time)); - statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(HC_tot_time), TICK_TO_DBL(HCe_tot_time)); #endif - statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(ExitUserTime), TICK_TO_DBL(ExitElapsedTime)); - statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", - TICK_TO_DBL(time), TICK_TO_DBL(etime)); - statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", - TICK_TO_DBL(GC_tot_time)*100/TICK_TO_DBL(time), - TICK_TO_DBL(GCe_tot_time)*100/TICK_TO_DBL(etime)); - - if (time - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time) == 0) + statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(exit_cpu), TICK_TO_DBL(exit_elapsed)); + statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", + TICK_TO_DBL(tot_cpu), TICK_TO_DBL(tot_elapsed)); +#ifndef THREADED_RTS + statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", + TICK_TO_DBL(gc_cpu)*100/TICK_TO_DBL(tot_cpu), + TICK_TO_DBL(gc_elapsed)*100/TICK_TO_DBL(tot_elapsed)); +#endif + + if (tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time) == 0) showStgWord64(0, temp, rtsTrue/*commas*/); else showStgWord64( (StgWord64)((GC_tot_alloc*sizeof(W_))/ - TICK_TO_DBL(time - GC_tot_time - + TICK_TO_DBL(tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time))), temp, rtsTrue/*commas*/); statsPrintf(" Alloc rate %s bytes per MUT second\n\n", temp); statsPrintf(" Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n", - TICK_TO_DBL(time - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime) * 100 - / TICK_TO_DBL(time), - TICK_TO_DBL(time - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime) * 100 - / TICK_TO_DBL(etime)); + TICK_TO_DBL(tot_cpu - GC_tot_cpu - + PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 + / TICK_TO_DBL(tot_cpu), + TICK_TO_DBL(tot_cpu - GC_tot_cpu - + PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 + / TICK_TO_DBL(tot_elapsed)); /* TICK_PRINT(1); @@ -741,26 +739,32 @@ stat_exit(int alloc) statsPrintf(fmt1, GC_tot_alloc*(StgWord64)sizeof(W_)); statsPrintf(fmt2, total_collections, - ResidencySamples == 0 ? 0 : - AvgResidency*sizeof(W_)/ResidencySamples, - MaxResidency*sizeof(W_), - ResidencySamples, + residency_samples == 0 ? 0 : + avg_residency*sizeof(W_)/residency_samples, + max_residency*sizeof(W_), + residency_samples, (unsigned long)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)), - TICK_TO_DBL(InitUserTime), TICK_TO_DBL(InitElapsedTime), - TICK_TO_DBL(MutUserTime), TICK_TO_DBL(MutElapsedTime), - TICK_TO_DBL(GC_tot_time), TICK_TO_DBL(GCe_tot_time)); + TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed), + TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed), + TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); } statsFlush(); statsClose(); } - if (GC_coll_times) - stgFree(GC_coll_times); - GC_coll_times = NULL; - if (GC_coll_etimes) - stgFree(GC_coll_etimes); - GC_coll_etimes = NULL; + if (GC_coll_cpu) { + stgFree(GC_coll_cpu); + GC_coll_cpu = NULL; + } + if (GC_coll_elapsed) { + stgFree(GC_coll_elapsed); + GC_coll_elapsed = NULL; + } + if (GC_coll_max_pause) { + stgFree(GC_coll_max_pause); + GC_coll_max_pause = NULL; + } } /* ----------------------------------------------------------------------------- @@ -800,6 +804,15 @@ statDescribeGens(void) mut = 0; for (i = 0; i < n_capabilities; i++) { mut += countOccupied(capabilities[i].mut_lists[g]); + + // Add the pinned object block. + bd = capabilities[i].pinned_object_block; + if (bd != NULL) { + gen_live += bd->free - bd->start; + gen_blocks += bd->blocks; + } + + gen_live += gcThreadLiveWords(i,g); gen_live += gcThreadLiveWords(i,g); gen_blocks += gcThreadLiveBlocks(i,g); } diff --git a/rts/Stats.h b/rts/Stats.h index f3a20ae..0c51787 100644 --- a/rts/Stats.h +++ b/rts/Stats.h @@ -13,13 +13,18 @@ #include "BeginPrivate.h" +struct gc_thread_; + void stat_startInit(void); void stat_endInit(void); -void stat_startGC(void); -void stat_endGC (lnat alloc, lnat live, - lnat copied, lnat gen, - lnat max_copied, lnat avg_copied, lnat slop); +void stat_startGC(struct gc_thread_ *gct); +void stat_endGC (struct gc_thread_ *gct, lnat alloc, lnat live, + lnat copied, nat gen, + lnat max_copied, lnat avg_copied, lnat slop); + +void stat_gcWorkerThreadStart (struct gc_thread_ *gct); +void stat_gcWorkerThreadDone (struct gc_thread_ *gct); #ifdef PROFILING void stat_startRP(void); diff --git a/rts/Task.c b/rts/Task.c index a5de804..e77a030 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -318,25 +318,30 @@ void taskTimeStamp (Task *task USED_IF_THREADS) { #if defined(THREADED_RTS) - Ticks currentElapsedTime, currentUserTime, elapsedGCTime; + Ticks currentElapsedTime, currentUserTime; currentUserTime = getThreadCPUTime(); currentElapsedTime = getProcessElapsedTime(); - // XXX this is wrong; we want elapsed GC time since the - // Task started. - elapsedGCTime = stat_getElapsedGCTime(); - - task->mut_time = + task->mut_time = currentUserTime - task->muttimestart - task->gc_time; task->mut_etime = - currentElapsedTime - task->elapsedtimestart - elapsedGCTime; + currentElapsedTime - task->elapsedtimestart - task->gc_etime; + if (task->gc_time < 0) { task->gc_time = 0; } + if (task->gc_etime < 0) { task->gc_etime = 0; } if (task->mut_time < 0) { task->mut_time = 0; } if (task->mut_etime < 0) { task->mut_etime = 0; } #endif } +void +taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time) +{ + task->gc_time += cpu_time; + task->gc_etime += elapsed_time; +} + #if defined(THREADED_RTS) void diff --git a/rts/Task.h b/rts/Task.h index 38e4763..424af60 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -207,6 +207,9 @@ void workerTaskStop (Task *task); // void taskTimeStamp (Task *task); +// The current Task has finished a GC, record the amount of time spent. +void taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time); + // Put the task back on the free list, mark it stopped. Used by // forkProcess(). // diff --git a/rts/ghc.mk b/rts/ghc.mk index 3e0e11a..a236945 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -194,8 +194,8 @@ endif else $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) "$$(RM)" $$(RM_OPTS) $$@ - echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR)" \ - $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ + echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR_STAGE1)" \ + $$(AR_OPTS_STAGE1) $$(EXTRA_AR_ARGS_STAGE1) $$@ endif endif @@ -456,7 +456,7 @@ rts_dist_MKDEPENDC_OPTS += -Irts/dist/build endif -$(eval $(call build-dependencies,rts,dist,1)) +$(eval $(call dependencies,rts,dist,1)) $(rts_dist_depfile_c_asm) : libffi/dist-install/build/ffi.h $(DTRACEPROBES_H) @@ -499,7 +499,7 @@ endif ifneq "$(BINDIST)" "YES" rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o "$(RM)" $(RM_OPTS) $@ - "$(AR)" $(AR_OPTS) $(EXTRA_AR_ARGS) $@ $< + "$(AR_STAGE1)" $(AR_OPTS_STAGE1) $(EXTRA_AR_ARGS_STAGE1) $@ $< endif # ----------------------------------------------------------------------------- diff --git a/rts/hooks/RtsOptsEnabled.c b/rts/hooks/RtsOptsEnabled.c index f5d8157..f20c325 100644 --- a/rts/hooks/RtsOptsEnabled.c +++ b/rts/hooks/RtsOptsEnabled.c @@ -9,5 +9,5 @@ #include "Rts.h" #include "RtsOpts.h" -const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly; +const RtsOptsEnabledEnum rtsOptsEnabled = RtsOptsSafeOnly; diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index ff7480c..1b57c53 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -942,6 +942,8 @@ compact(StgClosure *static_objects) // 1. thread the roots markCapabilities((evac_fn)thread_root, NULL); + markScheduler((evac_fn)thread_root, NULL); + // the weak pointer lists... if (weak_ptr_list != NULL) { thread((void *)&weak_ptr_list); diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index d049f98..fdb5477 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -18,6 +18,7 @@ #include "Storage.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "GCUtils.h" #include "Compact.h" #include "MarkStack.h" diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 4ba05bf..3036140 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -40,6 +40,7 @@ #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "Compact.h" #include "Evac.h" #include "Scav.h" @@ -146,8 +147,8 @@ static void start_gc_threads (void); static void scavenge_until_all_done (void); static StgWord inc_running (void); static StgWord dec_running (void); -static void wakeup_gc_threads (nat n_threads, nat me); -static void shutdown_gc_threads (nat n_threads, nat me); +static void wakeup_gc_threads (nat me); +static void shutdown_gc_threads (nat me); static void collect_gct_blocks (void); #if 0 && defined(DEBUG) @@ -177,7 +178,7 @@ GarbageCollect (rtsBool force_major_gc, generation *gen; lnat live_blocks, live_words, allocated, max_copied, avg_copied; gc_thread *saved_gct; - nat g, t, n; + nat g, n; // necessary if we stole a callee-saves register for gct: saved_gct = gct; @@ -198,11 +199,11 @@ GarbageCollect (rtsBool force_major_gc, ASSERT(sizeof(gen_workspace) == 16 * sizeof(StgWord)); // otherwise adjust the padding in gen_workspace. - // tell the stats department that we've started a GC - stat_startGC(); + // this is the main thread + SET_GCT(gc_threads[cap->no]); - // tell the STM to discard any cached closures it's hoping to re-use - stmPreGCHook(); + // tell the stats department that we've started a GC + stat_startGC(gct); // lock the StablePtr table stablePtrPreGC(); @@ -277,11 +278,6 @@ GarbageCollect (rtsBool force_major_gc, // check sanity *before* GC IF_DEBUG(sanity, checkSanity(rtsFalse /* before GC */, major_gc)); - // Initialise all our gc_thread structures - for (t = 0; t < n_gc_threads; t++) { - init_gc_thread(gc_threads[t]); - } - // Initialise all the generations/steps that we're collecting. for (g = 0; g <= N; g++) { prepare_collected_gen(&generations[g]); @@ -291,6 +287,9 @@ GarbageCollect (rtsBool force_major_gc, prepare_uncollected_gen(&generations[g]); } + // Prepare this gc_thread + init_gc_thread(gct); + /* Allocate a mark stack if we're doing a major collection. */ if (major_gc && oldest_gen->mark) { @@ -305,17 +304,6 @@ GarbageCollect (rtsBool force_major_gc, mark_sp = NULL; } - // this is the main thread -#ifdef THREADED_RTS - if (n_gc_threads == 1) { - SET_GCT(gc_threads[0]); - } else { - SET_GCT(gc_threads[cap->no]); - } -#else -SET_GCT(gc_threads[0]); -#endif - /* ----------------------------------------------------------------------- * follow all the roots that we know about: */ @@ -325,7 +313,9 @@ SET_GCT(gc_threads[0]); // NB. do this after the mutable lists have been saved above, otherwise // the other GC threads will be writing into the old mutable lists. inc_running(); - wakeup_gc_threads(n_gc_threads, gct->thread_index); + wakeup_gc_threads(gct->thread_index); + + traceEventGcWork(gct->cap); // scavenge the capability-private mutable lists. This isn't part // of markSomeCapabilities() because markSomeCapabilities() can only @@ -340,7 +330,7 @@ SET_GCT(gc_threads[0]); #endif } } else { - scavenge_capability_mut_lists(&capabilities[gct->thread_index]); + scavenge_capability_mut_lists(gct->cap); } // follow roots from the CAF list (used by GHCi) @@ -349,8 +339,16 @@ SET_GCT(gc_threads[0]); // follow all the roots that the application knows about. gct->evac_gen_no = 0; - markSomeCapabilities(mark_root, gct, gct->thread_index, n_gc_threads, - rtsTrue/*prune sparks*/); + if (n_gc_threads == 1) { + for (n = 0; n < n_capabilities; n++) { + markCapability(mark_root, gct, &capabilities[n], + rtsTrue/*don't mark sparks*/); + } + } else { + markCapability(mark_root, gct, cap, rtsTrue/*don't mark sparks*/); + } + + markScheduler(mark_root, gct); #if defined(RTS_USER_SIGNALS) // mark the signal handlers (signals should be already blocked) @@ -385,7 +383,7 @@ SET_GCT(gc_threads[0]); break; } - shutdown_gc_threads(n_gc_threads, gct->thread_index); + shutdown_gc_threads(gct->thread_index); // Now see which stable names are still alive. gcStablePtrTable(); @@ -396,7 +394,7 @@ SET_GCT(gc_threads[0]); pruneSparkQueue(&capabilities[n]); } } else { - pruneSparkQueue(&capabilities[gct->thread_index]); + pruneSparkQueue(gct->cap); } #endif @@ -599,11 +597,6 @@ SET_GCT(gc_threads[0]); // update the max size of older generations after a major GC resize_generations(); - // Start a new pinned_object_block - for (n = 0; n < n_capabilities; n++) { - capabilities[n].pinned_object_block = NULL; - } - // Free the mark stack. if (mark_stack_top_bd != NULL) { debugTrace(DEBUG_gc, "mark stack: %d blocks", @@ -645,8 +638,12 @@ SET_GCT(gc_threads[0]); // zero the scavenged static object list if (major_gc) { nat i; - for (i = 0; i < n_gc_threads; i++) { - zero_static_object_list(gc_threads[i]->scavenged_static_objects); + if (n_gc_threads == 1) { + zero_static_object_list(gct->scavenged_static_objects); + } else { + for (i = 0; i < n_gc_threads; i++) { + zero_static_object_list(gc_threads[i]->scavenged_static_objects); + } } } @@ -713,7 +710,8 @@ SET_GCT(gc_threads[0]); #endif // ok, GC over: tell the stats department what happened. - stat_endGC(allocated, live_words, copied, N, max_copied, avg_copied, + stat_endGC(gct, allocated, live_words, + copied, N, max_copied, avg_copied, live_blocks * BLOCK_SIZE_W - live_words /* slop */); // Guess which generation we'll collect *next* time @@ -787,6 +785,8 @@ new_gc_thread (nat n, gc_thread *t) nat g; gen_workspace *ws; + t->cap = &capabilities[n]; + #ifdef THREADED_RTS t->id = 0; initSpinLock(&t->gc_spin); @@ -970,8 +970,6 @@ scavenge_until_all_done (void) loop: - traceEventGcWork(&capabilities[gct->thread_index]); - #if defined(THREADED_RTS) if (n_gc_threads > 1) { scavenge_loop(); @@ -987,7 +985,7 @@ loop: // scavenge_loop() only exits when there's no work to do r = dec_running(); - traceEventGcIdle(&capabilities[gct->thread_index]); + traceEventGcIdle(gct->cap); debugTrace(DEBUG_gc, "%d GC threads still running", r); @@ -995,6 +993,7 @@ loop: // usleep(1); if (any_work()) { inc_running(); + traceEventGcWork(gct->cap); goto loop; } // any_work() does not remove the work from the queue, it @@ -1003,7 +1002,7 @@ loop: // scavenge_loop() to perform any pending work. } - traceEventGcDone(&capabilities[gct->thread_index]); + traceEventGcDone(gct->cap); } #if defined(THREADED_RTS) @@ -1019,6 +1018,8 @@ gcWorkerThread (Capability *cap) gct = gc_threads[cap->no]; gct->id = osThreadId(); + stat_gcWorkerThreadStart(gct); + // Wait until we're told to wake up RELEASE_SPIN_LOCK(&gct->mut_spin); gct->wakeup = GC_THREAD_STANDING_BY; @@ -1032,12 +1033,15 @@ gcWorkerThread (Capability *cap) } papi_thread_start_gc1_count(gct->papi_events); #endif - + + init_gc_thread(gct); + + traceEventGcWork(gct->cap); + // Every thread evacuates some roots. gct->evac_gen_no = 0; - markSomeCapabilities(mark_root, gct, gct->thread_index, n_gc_threads, - rtsTrue/*prune sparks*/); - scavenge_capability_mut_lists(&capabilities[gct->thread_index]); + markCapability(mark_root, gct, cap, rtsTrue/*prune sparks*/); + scavenge_capability_mut_lists(cap); scavenge_until_all_done(); @@ -1064,6 +1068,9 @@ gcWorkerThread (Capability *cap) ACQUIRE_SPIN_LOCK(&gct->mut_spin); debugTrace(DEBUG_gc, "GC thread %d on my way...", gct->thread_index); + // record the time spent doing GC in the Task structure + stat_gcWorkerThreadDone(gct); + SET_GCT(saved_gct); } @@ -1113,11 +1120,14 @@ start_gc_threads (void) } static void -wakeup_gc_threads (nat n_threads USED_IF_THREADS, nat me USED_IF_THREADS) +wakeup_gc_threads (nat me USED_IF_THREADS) { #if defined(THREADED_RTS) nat i; - for (i=0; i < n_threads; i++) { + + if (n_gc_threads == 1) return; + + for (i=0; i < n_gc_threads; i++) { if (i == me) continue; inc_running(); debugTrace(DEBUG_gc, "waking up gc thread %d", i); @@ -1134,11 +1144,14 @@ wakeup_gc_threads (nat n_threads USED_IF_THREADS, nat me USED_IF_THREADS) // standby state, otherwise they may still be executing inside // any_work(), and may even remain awake until the next GC starts. static void -shutdown_gc_threads (nat n_threads USED_IF_THREADS, nat me USED_IF_THREADS) +shutdown_gc_threads (nat me USED_IF_THREADS) { #if defined(THREADED_RTS) nat i; - for (i=0; i < n_threads; i++) { + + if (n_gc_threads == 1) return; + + for (i=0; i < n_gc_threads; i++) { if (i == me) continue; while (gc_threads[i]->wakeup != GC_THREAD_WAITING_TO_CONTINUE) { write_barrier(); } } @@ -1373,7 +1386,7 @@ init_gc_thread (gc_thread *t) t->static_objects = END_OF_STATIC_LIST; t->scavenged_static_objects = END_OF_STATIC_LIST; t->scan_bd = NULL; - t->mut_lists = capabilities[t->thread_index].mut_lists; + t->mut_lists = t->cap->mut_lists; t->evac_gen_no = 0; t->failed_to_evac = rtsFalse; t->eager_promotion = rtsTrue; diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 97af17a..12e106b 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -17,7 +17,7 @@ #include "Capability.h" #include "Trace.h" #include "Schedule.h" -// DO NOT include "GCThread.h", we don't want the register variable +// DO NOT include "GCTDecl.h", we don't want the register variable /* ----------------------------------------------------------------------------- isAlive determines whether the given closure is still alive (after @@ -79,7 +79,7 @@ isAlive(StgClosure *p) if (IS_FORWARDING_PTR(info)) { // alive! - return (StgClosure*)UN_FORWARDING_PTR(info); + return TAG_CLOSURE(tag,(StgClosure*)UN_FORWARDING_PTR(info)); } info = INFO_PTR_TO_STRUCT(info); diff --git a/rts/sm/GCTDecl.h b/rts/sm/GCTDecl.h new file mode 100644 index 0000000..11795ca --- /dev/null +++ b/rts/sm/GCTDecl.h @@ -0,0 +1,98 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 1998-2009 + * + * Documentation on the architecture of the Garbage Collector can be + * found in the online commentary: + * + * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC + * + * ---------------------------------------------------------------------------*/ + +#ifndef SM_GCTDECL_H +#define SM_GCTDECL_H + +#include "BeginPrivate.h" + +/* ----------------------------------------------------------------------------- + The gct variable is thread-local and points to the current thread's + gc_thread structure. It is heavily accessed, so we try to put gct + into a global register variable if possible; if we don't have a + register then use gcc's __thread extension to create a thread-local + variable. + -------------------------------------------------------------------------- */ + +#if defined(THREADED_RTS) + +#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg); + +#define SET_GCT(to) gct = (to) + + + +#if (defined(i386_HOST_ARCH) && defined(linux_HOST_OS)) +// Using __thread is better than stealing a register on x86/Linux, because +// we have too few registers available. In my tests it was worth +// about 5% in GC performance, but of course that might change as gcc +// improves. -- SDM 2009/04/03 +// +// We ought to do the same on MacOS X, but __thread is not +// supported there yet (gcc 4.0.1). + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + + +#elif defined(sparc_HOST_ARCH) +// On SPARC we can't pin gct to a register. Names like %l1 are just offsets +// into the register window, which change on each function call. +// +// There are eight global (non-window) registers, but they're used for other purposes. +// %g0 -- always zero +// %g1 -- volatile over function calls, used by the linker +// %g2-%g3 -- used as scratch regs by the C compiler (caller saves) +// %g4 -- volatile over function calls, used by the linker +// %g5-%g7 -- reserved by the OS + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + + +#elif defined(REG_Base) && !defined(i386_HOST_ARCH) +// on i386, REG_Base is %ebx which is also used for PIC, so we don't +// want to steal it + +GLOBAL_REG_DECL(gc_thread*, gct, REG_Base) +#define DECLARE_GCT /* nothing */ + + +#elif defined(REG_R1) + +GLOBAL_REG_DECL(gc_thread*, gct, REG_R1) +#define DECLARE_GCT /* nothing */ + + +#elif defined(__GNUC__) + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + +#else + +#error Cannot find a way to declare the thread-local gct + +#endif + +#else // not the threaded RTS + +extern StgWord8 the_gc_thread[]; + +#define gct ((gc_thread*)&the_gc_thread) +#define SET_GCT(to) /*nothing*/ +#define DECLARE_GCT /*nothing*/ + +#endif // THREADED_RTS + +#include "EndPrivate.h" + +#endif // SM_GCTDECL_H diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index 62dd1fb..e42a3a1 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -15,6 +15,7 @@ #define SM_GCTHREAD_H #include "WSDeque.h" +#include "GetTime.h" // for Ticks #include "BeginPrivate.h" @@ -115,6 +116,8 @@ typedef struct gen_workspace_ { ------------------------------------------------------------------------- */ typedef struct gc_thread_ { + Capability *cap; + #ifdef THREADED_RTS OSThreadId id; // The OS thread that this struct belongs to SpinLock gc_spin; @@ -162,7 +165,8 @@ typedef struct gc_thread_ { // instead of the to-space // corresponding to the object - lnat thunk_selector_depth; // ummm.... not used as of now + lnat thunk_selector_depth; // used to avoid unbounded recursion in + // evacuate() for THUNK_SELECTOR #ifdef USE_PAPI int papi_events; @@ -177,10 +181,15 @@ typedef struct gc_thread_ { lnat no_work; lnat scav_find_work; + Ticks gc_start_cpu; // process CPU time + Ticks gc_start_elapsed; // process elapsed time + Ticks gc_start_thread_cpu; // thread CPU time + lnat gc_start_faults; + // ------------------- // workspaces - // array of workspaces, indexed by stp->abs_no. This is placed + // array of workspaces, indexed by gen->abs_no. This is placed // directly at the end of the gc_thread structure so that we can get from // the gc_thread pointer to a workspace using only pointer // arithmetic, no memory access. This happens in the inner loop @@ -191,91 +200,8 @@ typedef struct gc_thread_ { extern nat n_gc_threads; -/* ----------------------------------------------------------------------------- - The gct variable is thread-local and points to the current thread's - gc_thread structure. It is heavily accessed, so we try to put gct - into a global register variable if possible; if we don't have a - register then use gcc's __thread extension to create a thread-local - variable. - - Even on x86 where registers are scarce, it is worthwhile using a - register variable here: I measured about a 2-5% slowdown with the - __thread version. - -------------------------------------------------------------------------- */ - extern gc_thread **gc_threads; -#if defined(THREADED_RTS) - -#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg); - -#define SET_GCT(to) gct = (to) - - - -#if (defined(i386_HOST_ARCH) && defined(linux_HOST_OS)) -// Using __thread is better than stealing a register on x86/Linux, because -// we have too few registers available. In my tests it was worth -// about 5% in GC performance, but of course that might change as gcc -// improves. -- SDM 2009/04/03 -// -// We ought to do the same on MacOS X, but __thread is not -// supported there yet (gcc 4.0.1). - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - - -#elif defined(sparc_HOST_ARCH) -// On SPARC we can't pin gct to a register. Names like %l1 are just offsets -// into the register window, which change on each function call. -// -// There are eight global (non-window) registers, but they're used for other purposes. -// %g0 -- always zero -// %g1 -- volatile over function calls, used by the linker -// %g2-%g3 -- used as scratch regs by the C compiler (caller saves) -// %g4 -- volatile over function calls, used by the linker -// %g5-%g7 -- reserved by the OS - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - - -#elif defined(REG_Base) && !defined(i386_HOST_ARCH) -// on i386, REG_Base is %ebx which is also used for PIC, so we don't -// want to steal it - -GLOBAL_REG_DECL(gc_thread*, gct, REG_Base) -#define DECLARE_GCT /* nothing */ - - -#elif defined(REG_R1) - -GLOBAL_REG_DECL(gc_thread*, gct, REG_R1) -#define DECLARE_GCT /* nothing */ - - -#elif defined(__GNUC__) - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - -#else - -#error Cannot find a way to declare the thread-local gct - -#endif - -#else // not the threaded RTS - -extern StgWord8 the_gc_thread[]; - -#define gct ((gc_thread*)&the_gc_thread) -#define SET_GCT(to) /*nothing*/ -#define DECLARE_GCT /*nothing*/ - -#endif - #include "EndPrivate.h" #endif // SM_GCTHREAD_H diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index 8b63674..ef8d0bd 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -18,6 +18,7 @@ #include "Storage.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "GCUtils.h" #include "Printer.h" #include "Trace.h" diff --git a/rts/sm/GCUtils.h b/rts/sm/GCUtils.h index 3fe78a3..d47375d 100644 --- a/rts/sm/GCUtils.h +++ b/rts/sm/GCUtils.h @@ -16,6 +16,8 @@ #include "BeginPrivate.h" +#include "GCTDecl.h" + bdescr *allocBlock_sync(void); void freeChain_sync(bdescr *bd); diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index f4b576a..f9275ec 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -17,6 +17,7 @@ #include "MarkWeak.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "Evac.h" #include "Trace.h" #include "Schedule.h" diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 8ebb9a2..0ec552c 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -789,6 +789,7 @@ findMemoryLeak (void) for (i = 0; i < n_capabilities; i++) { markBlocks(nurseries[i].blocks); + markBlocks(capabilities[i].pinned_object_block); } #ifdef PROFILING @@ -880,6 +881,9 @@ memInventory (rtsBool show) for (i = 0; i < n_capabilities; i++) { ASSERT(countBlocks(nurseries[i].blocks) == nurseries[i].n_blocks); nursery_blocks += nurseries[i].n_blocks; + if (capabilities[i].pinned_object_block != NULL) { + nursery_blocks += capabilities[i].pinned_object_block->blocks; + } } retainer_blocks = 0; diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index ae3433a..f8a9e55 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -657,17 +657,32 @@ allocatePinned (Capability *cap, lnat n) // If we don't have a block of pinned objects yet, or the current // one isn't large enough to hold the new object, allocate a new one. if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) { + // The pinned_object_block remains attached to the capability + // until it is full, even if a GC occurs. We want this + // behaviour because otherwise the unallocated portion of the + // block would be forever slop, and under certain workloads + // (allocating a few ByteStrings per GC) we accumulate a lot + // of slop. + // + // So, the pinned_object_block is initially marked + // BF_EVACUATED so the GC won't touch it. When it is full, + // we place it on the large_objects list, and at the start of + // the next GC the BF_EVACUATED flag will be cleared, and the + // block will be promoted as usual (if anything in it is + // live). ACQUIRE_SM_LOCK; - cap->pinned_object_block = bd = allocBlock(); - dbl_link_onto(bd, &g0->large_objects); - g0->n_large_blocks++; + if (bd != NULL) { + dbl_link_onto(bd, &g0->large_objects); + g0->n_large_blocks++; + g0->n_new_large_words += bd->free - bd->start; + } + cap->pinned_object_block = bd = allocBlock(); RELEASE_SM_LOCK; initBdescr(bd, g0, g0); - bd->flags = BF_PINNED | BF_LARGE; + bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED; bd->free = bd->start; } - g0->n_new_large_words += n; p = bd->free; bd->free += n; return p; diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk index 86f9323..9a66d1b 100644 --- a/rules/build-package-data.mk +++ b/rules/build-package-data.mk @@ -63,6 +63,11 @@ ifeq "$3" "0" $1_$2_CONFIGURE_OPTS += $$(BOOT_PKG_CONSTRAINTS) endif +$1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)" + ifneq "$$(BINDIST)" "YES" ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" $1/$2/inplace-pkg-config : $1/$2/package-data.mk @@ -72,7 +77,7 @@ $1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk # for our build system, and registers the package for use in-place in # the build tree. $1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP) - "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" --with-gcc="$$(WhatGccIsCalled)" --configure-option=--with-cc="$$(WhatGccIsCalled)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 + "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 ifeq "$$($1_$2_PROG)" "" ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO" "$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index 8b67ce2..a7dc918 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -40,12 +40,7 @@ endif # All the .a/.so library file dependencies for this library $1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$2_$3_LIB)) -ifneq "$$(BootingFromHc)" "YES" -$1_$2_$3_MKSTUBOBJS = $$(FIND) $1/$2/build -name "*_stub.$$($3_osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to -# make using cached directory contents, or something. -else -$1_$2_$3_MKSTUBOBJS = true +ifeq "$$(BootingFromHc)" "YES" $1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/') endif @@ -70,7 +65,6 @@ ifeq "$3" "dyn" ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32" $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -78,7 +72,6 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) else $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -90,14 +83,14 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) "$$(RM)" $$(RM_OPTS) $$@ $$@.contents ifeq "$$($1_$2_SplitObjs)" "YES" $$(FIND) $$(patsubst %.$$($3_osuf),%_$$($3_osuf)_split,$$($1_$2_$3_HS_OBJS)) -name '*.$$($3_osuf)' -print >> $$@.contents - echo $$($1_$2_$3_NON_HS_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_NON_HS_OBJS) >> $$@.contents else - echo $$($1_$2_$3_ALL_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_ALL_OBJS) >> $$@.contents endif -ifeq "$$(ArSupportsAtFile)" "YES" - "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ @$$@.contents +ifeq "$$($1_$2_ArSupportsAtFile)" "YES" + "$$($1_$2_AR)" $$($1_$2_AR_OPTS) $$($1_$2_EXTRA_AR_ARGS) $$@ @$$@.contents else - "$$(XARGS)" $$(XARGS_OPTS) "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ < $$@.contents + "$$(XARGS)" $$(XARGS_OPTS) "$$($1_$2_AR)" $$($1_$2_AR_OPTS) $$($1_$2_EXTRA_AR_ARGS) $$@ < $$@.contents endif "$$(RM)" $$(RM_OPTS) $$@.contents endif @@ -121,7 +114,7 @@ BINDIST_LIBS += $$($1_$2_GHCI_LIB) endif endif $$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) - "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS) + "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't bother making ghci libs for bootstrapping packages diff --git a/rules/build-package.mk b/rules/build-package.mk index ac0a8ee..c735e51 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -100,21 +100,7 @@ $(call hs-sources,$1,$2) $(call c-sources,$1,$2) $(call includes-sources,$1,$2) -# --- DEPENDENCIES -# We always have the dependency rules available, as we need to know -# how to build hsc2hs's dependency file in phase 0 -$(call build-dependencies,$1,$2,$3) -ifneq "$(phase)" "0" -# From phase 1 we actually include the dependency files for the -# bootstrapping stuff -ifeq "$3" "0" -$(call include-dependencies,$1,$2,$3) -else ifeq "$(phase)" "final" -# In the final phase, we also include the dependency files for -# everything else -$(call include-dependencies,$1,$2,$3) -endif -endif +$(call dependencies,$1,$2,$3) # Now generate all the build rules for each way in this directory: $$(foreach way,$$($1_$2_WAYS),$$(eval \ diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 5c352a2..99093d3 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -156,7 +156,7 @@ $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2 "$$($1_$2_HC)" -o $$@ $$($1_$2_v_ALL_HC_OPTS) $$(LD_OPTS) $$($1_$2_GHC_LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) else $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. - "$$(CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) + "$$($1_$2_CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) endif # Note [lib-depends] if this program is built with stage1 or greater, we @@ -188,20 +188,6 @@ INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG) endif endif -# --- DEPENDENCIES -# We always have the dependency rules available, as we need to know -# how to build hsc2hs's dependency file in phase 0 -$(call build-dependencies,$1,$2,$3) -ifneq "$(phase)" "0" -# From phase 1 we actually include the dependency files for the -# bootstrapping stuff -ifeq "$3" "0" -$(call include-dependencies,$1,$2,$3) -else ifeq "$(phase)" "final" -# In the final phase, we also include the dependency files for -# everything else -$(call include-dependencies,$1,$2,$3) -endif -endif +$(call dependencies,$1,$2,$3) endef diff --git a/rules/c-suffix-rules.mk b/rules/c-suffix-rules.mk index fa7dd6f..a4a0b57 100644 --- a/rules/c-suffix-rules.mk +++ b/rules/c-suffix-rules.mk @@ -43,19 +43,19 @@ $1/$2/build/%.$$($3_way_)s : $1/%.c $$($1_$2_HC_DEP) else $1/$2/build/%.$$($3_osuf) : $1/%.c | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s - "$$(AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$< + "$$($1_$2_AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$< $1/$2/build/%.$$($3_osuf) : $1/%.S | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@ $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.c - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@ endif diff --git a/rules/dependencies.mk b/rules/dependencies.mk new file mode 100644 index 0000000..42605a5 --- /dev/null +++ b/rules/dependencies.mk @@ -0,0 +1,38 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +define dependencies +$(call trace, dependencies($1,$2,$3)) +$(call profStart, dependencies($1,$2,$3)) +# $1 = dir +# $2 = distdir +# $3 = GHC stage to use (0 == bootstrapping compiler) + +# We always have the dependency rules available, as we need to know +# how to build hsc2hs's dependency file in phase 0 +$(call build-dependencies,$1,$2,$3) + +ifneq "$(phase)" "0" +# From phase 1 we actually include the dependency files for the +# bootstrapping stuff +ifeq "$3" "0" +$(call include-dependencies,$1,$2,$3) +else ifeq "$(phase)" "final" +# In the final phase, we also include the dependency files for +# everything else +$(call include-dependencies,$1,$2,$3) +endif +endif + +$(call profEnd, dependencies($1,$2,$3)) +endef + diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index bebbc4d..5c56169 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -17,9 +17,9 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # Options for a Haskell compilation: # - CONF_HC_OPTS source-tree-wide options, selected at -# configure-time +# configure-time # - SRC_HC_OPTS source-tree-wide options from build.mk -# (optimisation, heap settings) +# (optimisation, heap settings) # - libraries/base_HC_OPTS options from Cabal for libraries/base # for all ways # - libraries/base_MORE_HC_OPTS options from elsewhere in the build @@ -27,7 +27,7 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # - libraries/base_v_HC_OPTS options from libraries/base for way v # - WAY_v_HC_OPTS options for this way # - EXTRA_HC_OPTS options from the command-line -# - -Idir1 -Idir2 ... include-dirs from this package +# - -Idir1 -Idir2 ... include-dirs from this package # - -odir/-hidir/-stubdir put the output files under $3/build # - -osuf/-hisuf/-hcsuf suffixes for the output files in this way @@ -134,6 +134,8 @@ $1_$2_$3_ALL_HSC2HS_OPTS = \ --cflag=-D__GLASGOW_HASKELL__=$$(ProjectVersionInt) \ $$($1_$2_$3_HSC2HS_CC_OPTS) \ $$($1_$2_$3_HSC2HS_LD_OPTS) \ + --cflag=-I$1/$2/build/autogen \ + $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \ $$($$(basename $$<)_HSC2HS_OPTS) \ $$(EXTRA_HSC2HS_OPTS) diff --git a/rules/hs-suffix-rules-srcdir.mk b/rules/hs-suffix-rules-srcdir.mk index 7e9c8d3..bdb9d00 100644 --- a/rules/hs-suffix-rules-srcdir.mk +++ b/rules/hs-suffix-rules-srcdir.mk @@ -52,10 +52,10 @@ endif # .hs->.o rule, I don't know why --SDM $1/$2/build/%.$$($3_osuf) : $1/$4/%.hc includes/ghcautoconf.h includes/ghcplatform.h | $$$$(dir $$$$@)/. - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghcplatform.h - "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ + "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@ # $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)hc # "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ diff --git a/rules/package-config.mk b/rules/package-config.mk index 2091779..177ca25 100644 --- a/rules/package-config.mk +++ b/rules/package-config.mk @@ -16,6 +16,12 @@ $(call trace, package-config($1,$2,$3)) $(call profStart, package-config($1,$2,$3)) $1_$2_HC = $$(GHC_STAGE$3) +$1_$2_CC = $$(CC_STAGE$3) +$1_$2_AS = $$(AS_STAGE$3) +$1_$2_AR = $$(AR_STAGE$3) +$1_$2_AR_OPTS = $$(AR_OPTS_STAGE$3) +$1_$2_EXTRA_AR_ARGS = $$(EXTRA_AR_ARGS_STAGE$3) +$1_$2_ArSupportsAtFile = $$(ArSupportsAtFile_STAGE$3) # configuration stuff that depends on which GHC we're building with ifeq "$3" "0" diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk index 6433957..5cc10dc 100644 --- a/rules/shell-wrapper.mk +++ b/rules/shell-wrapper.mk @@ -74,7 +74,6 @@ install_$1_$2_wrapper: echo 'datadir="$$(datadir)"' >> "$$(WRAPPER)" echo 'bindir="$$(bindir)"' >> "$$(WRAPPER)" echo 'topdir="$$(topdir)"' >> "$$(WRAPPER)" - echo 'pgmgcc="$$(WhatGccIsCalled)"' >> "$$(WRAPPER)" $$($1_$2_SHELL_WRAPPER_EXTRA) $$($1_$2_INSTALL_SHELL_WRAPPER_EXTRA) cat $$($1_$2_SHELL_WRAPPER_NAME) >> "$$(WRAPPER)" diff --git a/settings.in b/settings.in new file mode 100644 index 0000000..5d4e1d3 --- /dev/null +++ b/settings.in @@ -0,0 +1,8 @@ +[("GCC extra via C opts", "@GccExtraViaCOpts@"), + ("C compiler command", "@WhatGccIsCalled@"), + ("C compiler flags", "@CONF_CC_OPTS_STAGE2@"), + ("ar command", "@ArCmd@"), + ("ar flags", "@ArArgs@"), + ("ar supports at file", "@ArSupportsAtFile@"), + ("perl command", "@PerlCmd@")] + diff --git a/sync-all b/sync-all index d89e439..5dc6a40 100755 --- a/sync-all +++ b/sync-all @@ -3,17 +3,71 @@ use strict; use Cwd; +# Usage: +# +# ./sync-all [-q] [-s] [--ignore-failure] [-r repo] +# [--nofib] [--testsuite] [--checked-out] cmd [git flags] +# +# Applies the command "cmd" to each repository in the tree. +# sync-all will try to do the right thing for both git and darcs repositories. +# +# e.g. +# ./sync-all -r http://darcs.haskell.org/ghc get +# To get any repos which do not exist in the local tree +# +# ./sync-all pull +# To pull everything from the default repos +# +# -------------- Flags ------------------- +# -q says to be quite, and -s to be silent. +# +# --ignore-failure says to ignore errors and move on to the next repository +# +# -r repo says to use repo as the location of package repositories +# +# --checked-out says that the remote repo is in checked-out layout, as +# opposed to the layout used for the main repo. By default a repo on +# the local filesystem is assumed to be checked-out, and repos accessed +# via HTTP or SSH are assumed to be in the main repo layout; use +# --checked-out to override the latter. +# +# --nofib, --testsuite also get the nofib and testsuite repos respectively +# +# ------------ Which repos to use ------------- +# sync-all uses the following algorithm to decide which remote repos to use +# +# It always computes the remote repos from a single base, $repo_base +# How is $repo_base set? +# If you say "-r repo", then that's $repo_base +# otherwise $repo_base is set by asking git where the ghc repo came +# from, and removing the last component (e.g. /ghc.git/ of /ghc/). +# +# Then sync-all iterates over the package found in the file +# ./packages; see that file for a description of the contents. +# +# If $repo_base looks like a local filesystem path, or if you give +# the --checked-out flag, sync-all works on repos of form +# $repo_base/ +# otherwise sync-all works on repos of form +# $repo_base/ +# This logic lets you say +# both sync-all -r http://darcs.haskell.org/ghc-6.12 pull +# and sync-all -r ../HEAD pull +# The latter is called a "checked-out tree". + +# NB: sync-all *ignores* the defaultrepo of all repos other than the +# root one. So the remote repos must be laid out in one of the two +# formats given by and in the file 'packages'. + +$| = 1; # autoflush stdout after each print, to avoid output after die + my $defaultrepo; my @packages; my $verbose = 2; my $ignore_failure = 0; -my $want_remote_repo = 0; my $checked_out_flag = 0; my $get_mode; -# Flags specific to a particular command -my $local_repo_unnecessary = 0; - my %tags; # Figure out where to get the other repositories from. @@ -137,17 +191,6 @@ sub scm { } } -sub repoexists { - my ($scm, $localpath) = @_; - - if ($scm eq "darcs") { - -d "$localpath/_darcs"; - } - else { - -d "$localpath/.git"; - } -} - sub scmall { my $command = shift; @@ -157,182 +200,223 @@ sub scmall { my $scm; my $upstream; my $line; + my $branch_name; + my $subcommand; my $path; my $wd_before = getcwd; - my @scm_args; - my $pwd; + my @args; my ($repo_base, $checked_out_tree) = getrepo(); + my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/; + parsePackages; + @args = (); + + if ($command =~ /^remote$/) { + while (@_ > 0 && $_[0] =~ /^-/) { + push(@args,shift); + } + if (@_ < 1) { help(); } + $subcommand = shift; + if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') { + help(); + } + while (@_ > 0 && $_[0] =~ /^-/) { + push(@args,shift); + } + if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) { + help(); + } elsif (@_ < 1) { # set-url + $branch_name = 'origin'; + } else { + $branch_name = shift; + } + } elsif ($command eq 'new') { + if (@_ < 1) { + $branch_name = 'origin'; + } else { + $branch_name = shift; + } + } + + push(@args, @_); + for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - $scm = $$line{"vcs"}; - $upstream = $$line{"upstream"}; + $localpath = $$line{"localpath"}; + $tag = $$line{"tag"}; + $remotepath = $$line{"remotepath"}; + $scm = $$line{"vcs"}; + $upstream = $$line{"upstream"}; - # Check the SCM is OK as early as possible - die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git")); + # Check the SCM is OK as early as possible + die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git")); - # Work out the path for this package in the repo we pulled from - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } + # We can't create directories on GitHub, so we translate + # "package/foo" into "package-foo". + if ($is_github_repo) { + $remotepath =~ s/\//-/; + } - # Work out the arguments we should give to the SCM - if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) { - @scm_args = (($scm eq "darcs" and "whatsnew") - or ($scm eq "git" and "status")); - - # Hack around 'darcs whatsnew' failing if there are no changes - $ignore_failure = 1; - } - elsif ($command =~ /^(?:pus|push)$/) { - @scm_args = "push"; - $want_remote_repo = 1; + # Work out the path for this package in the repo we pulled from + if ($checked_out_tree) { + $path = "$repo_base/$localpath"; + } + else { + $path = "$repo_base/$remotepath"; + } + + if ($command =~ /^(?:g|ge|get)$/) { + # Skip any repositories we have not included the tag for + if (not defined($tags{$tag})) { + $tags{$tag} = 0; } - elsif ($command =~ /^(?:pul|pull)$/) { - @scm_args = "pull"; - $want_remote_repo = 1; - # Q: should we append the -a argument for darcs repos? + if ($tags{$tag} == 0) { + next; } - elsif ($command =~ /^(?:g|ge|get)$/) { - # Skip any repositories we have not included the tag for - if (not defined($tags{$tag})) { - next; - } - - if (-d $localpath) { - warning("$localpath already present; omitting") if $localpath ne "."; - next; + + if (-d $localpath) { + warning("$localpath already present; omitting") + if $localpath ne "."; + if ($scm eq "git") { + scm ($localpath, $scm, "config", "core.ignorecase", "true"); } - + next; + } + + # Note that we use "." as the path, as $localpath + # doesn't exist yet. + if ($scm eq "darcs") { # The first time round the loop, default the get-mode if (not defined($get_mode)) { warning("adding --partial, to override use --complete"); $get_mode = "--partial"; } - - # The only command that doesn't need a repo - $local_repo_unnecessary = 1; - - if ($scm eq "darcs") { - # Note: we can only use the get-mode with darcs for now - @scm_args = ("get", $get_mode, $path, $localpath); - } - else { - @scm_args = ("clone", $path, $localpath); - } + scm (".", $scm, "get", $get_mode, $path, $localpath, @args); } - elsif ($command =~ /^(?:s|se|sen|send)$/) { - @scm_args = (($scm eq "darcs" and "send") - or ($scm eq "git" and "send-email")); - $want_remote_repo = 1; + else { + scm (".", $scm, "clone", $path, $localpath, @args); + scm ($localpath, $scm, "config", "core.ignorecase", "true"); } - elsif ($command =~ /^set-origin$/) { - @scm_args = ("remote", "set-url", "origin", $path); + next; + } + + if (-d "$localpath/_darcs") { + if (-d "$localpath/.git") { + die "Found both _darcs and .git in $localpath"; } - elsif ($command =~ /^fetch$/) { - @scm_args = ("fetch", "origin"); + $scm = "darcs"; + } elsif (-d "$localpath/.git") { + $scm = "git"; + } elsif ($tag eq "") { + die "Required repo $localpath is missing"; + } else { + message "== $localpath repo not present; skipping"; + next; + } + + # Work out the arguments we should give to the SCM + if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) { + if ($scm eq "darcs") { + $command = "whatsnew"; } - elsif ($command =~ /^new$/) { - @scm_args = ("log", "origin.."); + elsif ($scm eq "git") { + $command = "status"; } else { - die "Unknown command: $command"; - } - - # Actually execute the command - if (repoexists ($scm, $localpath)) { - if ($want_remote_repo) { - if ($scm eq "darcs") { - scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path); - } else { - # git pull doesn't like to be used with --work-dir - # I couldn't find an alternative to chdir() here - scm ($localpath, $scm, @scm_args, @_, $path, "master"); - } - } else { - # git status *must* be used with --work-dir, if we don't chdir() to the dir - scm ($localpath, $scm, @scm_args, @_); - } + die "Unknown scm"; } - elsif ($local_repo_unnecessary) { - # Don't bother to change directory in this case - scm (".", $scm, @scm_args, @_); + + # Hack around 'darcs whatsnew' failing if there are no changes + $ignore_failure = 1; + scm ($localpath, $scm, $command, @args); + } + elsif ($command =~ /^commit$/) { + # git fails if there is nothing to commit, so ignore failures + $ignore_failure = 1; + scm ($localpath, $scm, "commit", @args); + } + elsif ($command =~ /^(?:pus|push)$/) { + scm ($localpath, $scm, "push", @args); + } + elsif ($command =~ /^(?:pul|pull)$/) { + scm ($localpath, $scm, "pull", @args); + } + elsif ($command =~ /^(?:s|se|sen|send)$/) { + if ($scm eq "darcs") { + $command = "send"; } - elsif ($tag eq "") { - message "== Required repo $localpath is missing! Skipping"; + elsif ($scm eq "git") { + $command = "send-email"; } else { - message "== $localpath repo not present; skipping"; + die "Unknown scm"; } - } -} - -sub main { - if (! -d ".git" || ! -d "compiler") { - die "error: sync-all must be run from the top level of the ghc tree." - } - - $tags{"-"} = 1; - $tags{"dph"} = 1; - - while ($#_ ne -1) { - my $arg = shift; - # We handle -q here as well as lower down as we need to skip over it - # if it comes before the source-control command - if ($arg eq "-q") { - $verbose = 1; + scm ($localpath, $scm, $command, @args); } - elsif ($arg eq "-s") { - $verbose = 0; + elsif ($command =~ /^fetch$/) { + scm ($localpath, $scm, "fetch", @args); } - elsif ($arg eq "-r") { - $defaultrepo = shift; + elsif ($command =~ /^new$/) { + my @scm_args = ("log", "$branch_name.."); + scm ($localpath, $scm, @scm_args, @args); } - elsif ($arg eq "--ignore-failure") { + elsif ($command =~ /^remote$/) { + my @scm_args; + if ($subcommand eq 'add') { + @scm_args = ("remote", "add", $branch_name, $path); + } elsif ($subcommand eq 'rm') { + @scm_args = ("remote", "rm", $branch_name); + } elsif ($subcommand eq 'set-url') { + @scm_args = ("remote", "set-url", $branch_name, $path); + } + scm ($localpath, $scm, @scm_args, @args); + } + elsif ($command =~ /^checkout$/) { + # Not all repos are necessarily branched, so ignore failure $ignore_failure = 1; + scm ($localpath, $scm, "checkout", @args) + unless $scm eq "darcs"; } - elsif ($arg eq "--complete" || $arg eq "--partial") { - $get_mode = $arg; + elsif ($command =~ /^grep$/) { + # Hack around 'git grep' failing if there are no matches + $ignore_failure = 1; + scm ($localpath, $scm, "grep", @args) + unless $scm eq "darcs"; } - # Use --checked-out if the remote repos are a checked-out tree, - # rather than the master trees. - elsif ($arg eq "--checked-out") { - $checked_out_flag = 1; + elsif ($command =~ /^clean$/) { + scm ($localpath, $scm, "clean", @args) + unless $scm eq "darcs"; } - # -- says we grab the libs tagged 'tag' with - # 'get'. It has no effect on the other commands. - elsif ($arg =~ m/^--/) { - $arg =~ s/^--//; - $tags{$arg} = 1; + elsif ($command =~ /^reset$/) { + scm ($localpath, $scm, "reset", @args) + unless $scm eq "darcs"; + } + elsif ($command =~ /^config$/) { + scm ($localpath, $scm, "config", @args) + unless $scm eq "darcs"; } else { - unshift @_, $arg; - if (grep /^-q$/, @_) { - $verbose = 1; - } - last; + die "Unknown command: $command"; } } +} - if ($#_ eq -1) { + +sub help() +{ # Get the built in help my $help = < + * remote rm + * remote set-url [--push] + * checkout + * grep + * clean + * reset + * config Available package-tags are: END @@ -367,6 +458,59 @@ END my @available_tags = keys %available_tags; print "$help@available_tags\n"; exit 1; +} + +sub main { + if (! -d ".git" || ! -d "compiler") { + die "error: sync-all must be run from the top level of the ghc tree." + } + + $tags{"-"} = 1; + $tags{"dph"} = 1; + + while ($#_ ne -1) { + my $arg = shift; + # We handle -q here as well as lower down as we need to skip over it + # if it comes before the source-control command + if ($arg eq "-q") { + $verbose = 1; + } + elsif ($arg eq "-s") { + $verbose = 0; + } + elsif ($arg eq "-r") { + $defaultrepo = shift; + } + elsif ($arg eq "--ignore-failure") { + $ignore_failure = 1; + } + elsif ($arg eq "--complete" || $arg eq "--partial") { + $get_mode = $arg; + } + # Use --checked-out if the remote repos are a checked-out tree, + # rather than the master trees. + elsif ($arg eq "--checked-out") { + $checked_out_flag = 1; + } + # -- says we grab the libs tagged 'tag' with + # 'get'. It has no effect on the other commands. + elsif ($arg =~ m/^--no-(.*)$/) { + $tags{$1} = 0; + } + elsif ($arg =~ m/^--(.*)$/) { + $tags{$1} = 1; + } + else { + unshift @_, $arg; + if (grep /^-q$/, @_) { + $verbose = 1; + } + last; + } + } + + if ($#_ eq -1) { + help(); } else { # Give the command and rest of the arguments to the main loop diff --git a/utils/Makefile b/utils/Makefile index 881d7d5..e522c32 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -60,7 +60,7 @@ endif WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc -WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock +WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock ifneq "$(NO_INSTALL_HSC2HS)" "YES" WITH_STAGE2 += hsc2hs endif diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 72a5010..d64c224 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -28,7 +28,8 @@ import System.Exit import System.FilePath main :: IO () -main = do args <- getArgs +main = do hSetBuffering stdout LineBuffering + args <- getArgs case args of "hscolour" : distDir : dir : args' -> runHsColour distDir dir args' diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index d038114..6bc9be5 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -44,9 +44,11 @@ endif endif -# depend on ghc-cabal, otherwise we build Cabal twice when building in parallel +# depend on ghc-cabal, otherwise we build Cabal twice when building in parallel. +# (ghc-cabal is an order-only dependency, we don't need to rebuild ghc-pkg +# if ghc-cabal is newer). # The binary package is not warning-clean, so we need a few -fno-warns here. -utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs $(GHC_CABAL_INPLACE) | bootstrapping/. $$(dir $$@)/. +utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \ -no-user-package-conf \ -Wall -fno-warn-unused-imports \ diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index a25537e..b3ed58f 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -10,6 +10,7 @@ import DriverPhases ( isHaskellSrcFilename ) import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) +import Panic ( panic ) import DynFlags ( defaultDynFlags ) import Bag import Exception @@ -100,7 +101,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler defaultDynFlags $ + GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags diff --git a/validate b/validate index 8d6e2c3..b1ae14f 100755 --- a/validate +++ b/validate @@ -73,7 +73,7 @@ if [ $no_clean -eq 0 ]; then INSTDIR=`cygpath -m "$INSTDIR"` fi - /usr/bin/perl -w boot --required-tag=dph + /usr/bin/perl -w boot --validate --required-tag=dph ./configure --prefix="$INSTDIR" $config_args fi