*.BAK
*.orig
*.prof
+*.rej
*.hi
*.hi-boot
*.o.cmd
*.depend*
log
+tags
autom4te.cache
config.log
configure
# -----------------------------------------------------------------------------
+# Ignore any overlapped darcs repos and back up files
+
+*-darcs-backup*
+_darcs/
+
+# -----------------------------------------------------------------------------
# sub-repositories
/ghc-tarballs/
/bindist-list
/bindistprep/
/bindisttest/HelloWorld
-/bindisttest/a/
-/bindisttest/install\ dir/
-/bindisttest/output
+/bindisttest/
/ch01.html
/ch02.html
/compiler/cmm/CmmLex.hs
/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
/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/
/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
/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
/utils/runghc/runhaskell
/utils/runstdtest/runstdtest
/utils/unlit/unlit
+
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.
Shows the targets available in <dir>
- make html
- make pdf
- make ps
-
- Make documentation
-
make install
Installs GHC, libraries and tools under $(prefix)
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
$(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:
$ 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
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
$ 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
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"
$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.
# --------------------
# 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],
[
])# 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
# 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])
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
])])
-# 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.
])# 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
# 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)
])
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])
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.
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;
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 = <FILE>;
+ close FILE;
+
+ if ($string =~ /\r/) {
+ print STDERR <<EOF;
+Found ^M in packages.
+Perhaps you need to run
+ git config --global core.autocrlf false
+and re-check out the tree?
+EOF
+ exit 1;
+ }
+}
+
+sub sanity_check_tree {
+ my $tag;
+ my $dir;
+
+ # Check that we have all boot packages.
+ open PACKAGES, "< packages";
+ while (<PACKAGES>) {
+ 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 (<PACKAGES>) {
- 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 (<PKGS>) {
+ 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 <<EOF;
+
+WARNING: You don't have a mk/build.mk file.
+
+By default a standard GHC build will be done, which uses optimisation
+and builds the profiling libraries. This will take a long time, so may
+not be what you want if you are developing GHC or the libraries, rather
+than simply building it to use it.
+
+For information on creating a mk/build.mk file, please see:
+ http://hackage.haskell.org/trac/ghc/wiki/Building/Using#Buildconfiguration
+
+EOF
+ }
+}
+
+&sanity_check_line_endings();
+&sanity_check_tree();
+&boot_pkgs();
+&autoreconf();
+&checkBuildMk();
+
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-
-use File::Path 'rmtree';
-use File::Basename;
-
-my @library_dirs = ();
-my @tarballs = glob("libraries/tarballs/*");
-
-my $tarball;
-my $package;
-my $stamp;
-
-for $tarball (@tarballs) {
- $package = $tarball;
- $package =~ s#^libraries/tarballs/##;
- $package =~ s/-[0-9.]*(-snapshot)?\.tar\.gz$//;
-
- # 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: $!";
- }
- }
-}
-
-for $package (glob "libraries/*/") {
- $package =~ s/\/$//;
- my $pkgs = "$package/ghc-packages";
- if (-f $pkgs) {
- open PKGS, "< $pkgs"
- or die "Failed to open $pkgs: $!";
- while (<PKGS>) {
- 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: $!";
- }
- }
-}
-
+++ /dev/null
-# 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)
-
\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
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"
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)
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"
\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
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"
--(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
instance NamedThing Name where
getName n = n
-INSTANCE_TYPEABLE0(Name,nameTc,"Name")
-
instance Data Name where
-- don't traverse?
toConstr _ = abstractConstr "Name"
\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
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
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)
{ occNameSpace :: !NameSpace
, occNameFS :: !FastString
}
+ deriving Typeable
\end{code}
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"
ppr (UnhelpfulLoc s) = ftext s
-INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan")
-
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "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
-- 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
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
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"
mkAsmTempLabel,
- mkModuleInitLabel,
- mkPlainModuleInitLabel,
- mkModuleInitTableLabel,
+ mkPlainModuleInitLabel,
mkSplitMarkerLabel,
mkDirty_MUT_VAR_Label,
mkRtsPrimOpLabel,
mkRtsSlowTickyCtrLabel,
- moduleRegdLabel,
- moduleRegTableLabel,
-
- mkSelectorInfoLabel,
+ mkSelectorInfoLabel,
mkSelectorEntryLabel,
mkCmmInfoLabel,
mkDeadStripPreventer,
mkHpcTicksLabel,
- mkHpcModuleNameLabel,
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
| 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
-- | Per-module table of tick locations
| HpcTicksLabel Module
- -- | Per-module name of the module for Hpc
- | HpcModuleNameLabel
-
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique
-- Constructing Code Coverage Labels
mkHpcTicksLabel = HpcTicksLabel
-mkHpcModuleNameLabel = HpcModuleNameLabel
-- Constructing labels used for dynamic linking
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.
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
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
-- | 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
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
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
-externallyVisibleCLabel HpcModuleNameLabel = False
-externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
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
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
pprCLabel :: CLabel -> SDoc
-#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
+ | cGhcWithNativeCodeGen == "YES"
= getPprStyle $ \ sty ->
if asmStyle sty then
ptext asmTempLabelPrefix <> pprUnique 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
pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
= ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
-pprCLbl ModuleRegdLabel
- = ptext (sLit "_module_registered")
-
pprCLbl (ForeignLabel str _ _ _)
= ftext str
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
#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
-------------------------------------------------
-- 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))
-------------------------------------------------
-- 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
-- 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)
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
----------- 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)
--------------- 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...
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
| 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
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
import Constants
import FastString
-import Control.Monad
import Data.Maybe
-- -----------------------------------------------------------------------------
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
-- 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,
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))
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
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)
-----------------------------------------------------------------------------
module CmmOpt (
+ cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
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
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)
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
| 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 }
: '[' 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 ] }
-- 'default' branches
| {- empty -} { Nothing }
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
else :: { ExtCode }
: {- empty -} { nopEC }
| 'else' '{' body '}' { $3 }
-- 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
-- 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
-- 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
-- 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
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
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
- , layout, manifestSP, igraph, areaBuilder
+ , getSpEntryMap, layout, manifestSP, igraph, areaBuilder
, stubSlotsOnDeath ) -- to help crash early during debugging
where
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
-- 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
-- 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
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)
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.
-- 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
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<b> + 4)] = cde;
+ // Stack pointer is moved to young end (bottom) of young<b> 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<b> (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<b>), 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.
-- 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"
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
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]
, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
-- Reexport of needed Cmm stuff
, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..)
+ , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
, Cmm, CmmTop
)
where
-- 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
)
import Control.Monad
import StaticFlags (opt_Fuel)
import UniqSupply
-#ifdef DEBUG
import Panic
-#endif
import Compiler.Hoopl
import Compiler.Hoopl.GHC (getFuel, setFuel)
anyFuelLeft :: OptimizationFuel -> Bool
oneLessFuel :: OptimizationFuel -> OptimizationFuel
+unlimitedFuel :: OptimizationFuel
-#ifdef DEBUG
newtype OptimizationFuel = OptimizationFuel Int
deriving Show
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) }
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))
import Constants
import BasicTypes
import CLabel
+import Util
-- The rest
import Data.List
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
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 ]
)
| 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
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
This will fix the spill before stack check problem but only really as a side\r
effect. A 'real fix' probably requires making the spiller know about sp checks.\r
\r
- - There is some silly stuff happening with the Sp. We end up with code like:\r
- Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8\r
- Seems to be perhaps caused by the issue above but also maybe a optimisation\r
- pass needed?\r
+ EZY: I don't understand this comment. David Terei, can you clarify?\r
\r
- - Proc pass all arguments on the stack, adding more code and slowing down things\r
- a lot. We either need to fix this or even better would be to get rid of\r
- proc points.\r
+ - Proc points pass all arguments on the stack, adding more code and\r
+ slowing down things a lot. We either need to fix this or even better\r
+ would be to get rid of proc points.\r
\r
- CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to\r
Old.Cmm. We should abstract it to work on both representations, it needs only to\r
we could convert codeGen/StgCmm* clients to the Hoopl's semantics?\r
It's all deeply unsatisfactory.\r
\r
- - Improve preformance of Hoopl.\r
+ - Improve performance of Hoopl.\r
\r
A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters\r
(using the same ghc-cmm branch +libraries compiled by the old codegenerator)\r
\r
So we generate a bit better code, but it takes us longer!\r
\r
+ EZY: Also importantly, Hoopl uses dramatically more memory than the\r
+ old code generator.\r
+\r
- Are all blockToNodeList and blockOfNodeList really needed? Maybe we could\r
splice blocks instead?\r
\r
a block catenation function would be probably nicer than blockToNodeList\r
/ blockOfNodeList combo.\r
\r
- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
delete splitEntrySeq from HooplUtils.\r
\r
- manifestSP seems to touch a lot of the graph representation. It is\r
calling convention, and the code for calling foreign calls is generated\r
\r
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline\r
+ EZY (2011-04-16): The mini-inliner has been generalized and ported,\r
+ but the constant folding and other optimizations need to still be\r
+ ported.\r
\r
- AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);\r
we ultimately want to share this with the Cmm branch eliminator.\r
- See "CAFs" below; we want to totally refactor the way SRTs are calculated\r
\r
- Pull out Areas into its own module\r
- Parameterise AreaMap\r
+ Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)\r
Add ByteWidth = Int\r
type SubArea = (Area, ByteOff, ByteWidth) \r
ByteOff should not be defined in SMRep -- that is too high up the hierarchy\r
insert spills/reloads across \r
LastCalls, and \r
Branches to proc-points\r
- Now sink those reloads:\r
- - CmmSpillReload.insertLateReloads\r
+ Now sink those reloads (and other instructions):\r
+ - CmmSpillReload.rewriteAssignments\r
- CmmSpillReload.removeDeadAssignmentsAndReloads\r
\r
* CmmStackLayout.stubSlotsOnDeath\r
never pass variables to join points via arguments.)\r
\r
Furthermore, there is *no way* to pass q to J in a register (other\r
-than a paramter register).\r
+than a parameter register).\r
\r
What we want is to do register allocation across the whole caboodle.\r
Then we could drop all the code that deals with the above awkward\r
-- 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 }
}
--
-----------------------------------------------------------------------------
-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
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"
-
costCentreFrom,
curCCS, curCCSAddr,
emitCostCentreDecl, emitCostCentreStackDecl,
- emitRegisterCC, emitRegisterCCS,
- emitSetCCC, emitCCS,
+ emitSetCCC, emitCCS,
-- Lag/drag/void stuff
ldvEnter, ldvEnterClosure, ldvRecordCreate
(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
import CLabel
import OldCmm
-import OldCmmUtils
import OldPprCmm
import StgSyn
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
-- 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"
{ 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}
| otherwise
= do { mapM_ emitCostCentreDecl local_CCs
; mapM_ emitCostCentreStackDecl singleton_CCSs
- ; mapM_ emitRegisterCC local_CCs
- ; mapM_ emitRegisterCCS singleton_CCSs
- }
+ }
\end{code}
%************************************************************************
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
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
; 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
-- 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 }
-}
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
{- 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
module StgCmmHpc ( initHpc, mkTickBox ) where
-import StgCmmUtils
import StgCmmMonad
-import StgCmmForeign
import MkGraph
import CmmDecl
import CLabel
import Module
import CmmUtils
-import FastString
import HscTypes
-import Data.Char
import StaticFlags
-import BasicTypes
mkTickBox :: Module -> Int -> CmmAGraph
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
-
-
-
-- 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 ()
(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 ()
-- 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)]
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 }
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
\section[Coverage]{@coverage@: the main function}
\begin{code}
-module Coverage (addCoverageTicksToBinds) where
+module Coverage (addCoverageTicksToBinds, hpcInitCode) where
import HsSyn
import Module
import TyCon
import MonadUtils
import Maybes
+import CLabel
+import Util
import Data.Array
import System.Directory ( createDirectoryIfMissing )
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
(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.
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)
(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
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)
(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
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_<module>()`, 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}
; (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) ;
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
-- 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
-- --------------------------
-- 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
-- ---> 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))
-- 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
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]) }
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
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}
-
%************************************************************************
%* *
\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}
-- 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)
% (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
-- 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
import SrcLoc
import Outputable
import FastString
+import TcType
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
\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;
-- 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
-- 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}
%************************************************************************
\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}
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
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
\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
[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)
-- 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
-- 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
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}
%************************************************************************
-- [: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:
--
-- <<[: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
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 =
-- 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
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 =
-- 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
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 =
-- 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)
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'
_ -> 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}
; 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)
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))
; 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
-- 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.
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
| 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)
(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}
Default: False
Manual: True
-Flag ncg
- Description: Build the NCG.
- Default: False
- Manual: True
-
Flag stage1
Description: Is this stage 1?
Default: False
CPP-Options: -DGHCI
Include-Dirs: ../libffi/build/include
- if !flag(ncg)
- CPP-Options: -DOMIT_NATIVE_CODEGEN
-
Build-Depends: bin-package-db
Build-Depends: hoopl
TysPrim
TysWiredIn
CostCentre
+ ProfInit
SCCfinal
RnBinds
RnEnv
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
RegClass
PIC
Platform
- Alpha.Regs
- Alpha.RegInfo
- Alpha.Instr
- Alpha.CodeGen
X86.Regs
X86.RegInfo
X86.Instr
@echo '{-# LANGUAGE CPP #-}' >> $@
@echo 'module Config where' >> $@
@echo >> $@
- @echo 'import Distribution.System' >> $@
- @echo >> $@
@echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@
@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' >> $@
@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]' >> $@
@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' >> $@
@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' >> $@
@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' >> $@
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
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
import Constants
import FastString
import SMRep
+import DynFlags
import Outputable
+import Platform
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
-- 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
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
| 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
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
= 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)
import Type
import DataCon
import TyCon
--- import Type
import Util
--- import DataCon
import Var
import VarSet
import TysPrim
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?")
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"
-- 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)
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
- assembleBCO proto_bco
+ assembleBCO dflags proto_bco
-- -----------------------------------------------------------------------------
-> 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,
-- (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)
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)
--
-- 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 (
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)
}
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]
--
-- 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))
= 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)
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
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)
-- 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
-- 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
= 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
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
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<n> var1 ... varN of DEFAULT -> e
otherwise we return Nothing.
- The idea is that the "case tick<n> ..." is really just an annotation on
+ The idea is that the "case tick<n> ..." 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".
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
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
-- (# 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
-- = 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)
| 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
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)
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
-- -----------------------------------------------------------------------------
-- 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)
-- 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.
-- 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
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.
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)
-- 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)
-- 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)
(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):
-
+
<arg_n>
...
<arg_1>
<placeholder-for-result#> (must be an unboxed type)
The interpreter then calls the marshall code mentioned
- in the CCALL insn, passing it (& <placeholder-for-result#>),
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
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
-- 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
| 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,
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
_ -> panic "mkDummyLiteral"
--- Convert (eg)
+-- Convert (eg)
-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
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
&& 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
[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]
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)
| 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
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
= pushAtom d p (snd e)
pushAtom _ _ expr
- = pprPanic "ByteCodeGen.pushAtom"
+ = pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
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)
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
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"
= 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
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
-- Supporting junk for the compilation schemes
-- Describes case alts
-data Discr
+data Discr
= DiscrI Int
| DiscrW Word
| DiscrF Float
-- 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."))
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)
-- 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
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)
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
in return (newState, uniq)
newId :: Type -> BcM Id
-newId ty = do
+newId ty = do
uniq <- newUnique
return $ mkSysLocal tickFS uniq ty
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
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') }
| 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.)") ]
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) }
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)
% (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.
(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
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
%************************************************************************
%* *
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
import BasicTypes
import DataCon
import SrcLoc
+import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
-- 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
= 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)))
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
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
-- 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.
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]
~~~~~~~~~~~~~~~~~~~~~~~~
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 })
, 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}
%************************************************************************
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}
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
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}
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}
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
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]
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 ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
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)
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
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.
| 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
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,
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
collectSigTysFromPats, collectSigTysFromPat,
hsTyClDeclBinders, hsTyClDeclsBinders,
- hsForeignDeclsBinders, hsGroupBinders
+ hsForeignDeclsBinders, hsGroupBinders,
+
+ -- Collecting implicit binders
+ lStmtsImplicits, hsValBindsImplicits, lPatImplicits
) where
import HsDecls
import BasicTypes
import SrcLoc
import FastString
+import Outputable
import Util
import Bag
+
+import Data.Either
\end{code}
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
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
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 }
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)
-- 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 --------------------------
%************************************************************************
%* *
+ 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
%* *
%************************************************************************
\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
%************************************************************************
-%* *
- 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 = []
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
| 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
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
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.)
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
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}
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)
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
++ 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)
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 _ = []
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
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
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
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 "<naughty>") else empty
+ <+> if b then ptext (sLit "<naughty>") 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 "<compulsory>") <+> parens (ppr e)
- ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") 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 "<stable>") 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
<+> 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
-- 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) &&&
freeNamesIfSynRhs Nothing = emptyNameSet
freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
-freeNamesIfTcFam (Just (tc,tys)) =
+freeNamesIfTcFam (Just (tc,tys)) =
freeNamesIfTc tc &&& fnList freeNamesIfType tys
freeNamesIfTcFam Nothing =
emptyNameSet
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
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
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
freeNamesIfIdBndr = freeNamesIfTvBndr
freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
-freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
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
-- 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
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)
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.
+
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` []
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}
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 <n> 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"
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
+{-# 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
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
{- |
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)
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.
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
(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"
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
-import AsmCodeGen ( nativeCodeGen )
-#endif
+import AsmCodeGen ( nativeCodeGen )
import LlvmCodeGen ( llvmCodeGen )
import UniqSupply ( mkSplitUniqSupply )
import HscTypes
import DynFlags
import Config
+import SysTools
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
-> 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
=
\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}
\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
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
-- 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"
#include "HsVersions.h"
import qualified GHC
--- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
import Exception
import ErrUtils
--- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
| 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
| 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.
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
eqPhase LlvmMangle LlvmMangle = True
eqPhase CmmCpp CmmCpp = True
eqPhase Cmm Cmm = True
+eqPhase MergeStub MergeStub = True
eqPhase StopLn StopLn = True
eqPhase _ _ = False
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
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
-- 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"
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,
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" ]
{-# OPTIONS -fno-cse #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
-----------------------------------------------------------------------------
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
import Data.List ( isSuffixOf )
import Data.Maybe
import System.Environment
+import Data.Char
-- ---------------------------------------------------------------------------
-- Pre-process
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-}
-- ---------------------------------------------------------------------------
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
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
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
= 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,
-- 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)
-- 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
-- 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
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)
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
( _, out_file) <- runPipeline stop_phase' hsc_env
(src, mb_phase) Nothing output
- Nothing{-no ModLocation-}
+ Nothing{-no ModLocation-} Nothing
return out_file
-> 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
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
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
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
-- 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 ++
, 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
)
-- 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
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
-- 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
o_file = ml_obj_file location4 -- The real object file
+ setModLocation location4
-- Figure out if the source has changed, for recompilation avoidance.
--
-- 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
-- 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
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
-- 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)
-- 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.
-- 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
++ 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
-- 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
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
-- 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
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
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
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
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
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
#endif
++ pkg_lib_path_opts
++ main_lib
- ++ rtsEnabledObj
- ++ rtsOptsObj
+ ++ [extraLinkObj]
++ pkg_link_opts
#ifdef darwin_TARGET_OS
++ pkg_framework_path_opts
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
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
-- 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)
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
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)
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",
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
- ++ rtsEnabledObj
+ ++ [extraLinkObj]
++ pkg_link_opts
))
#else
-- 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
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
- ++ rtsEnabledObj
+ ++ [extraLinkObj]
++ pkg_link_opts
))
#endif
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)
-- 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
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"
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
-
-{-# OPTIONS_GHC -w #-}
--- Temporary, until rtsIsProfiled is fixed
-
-- |
-- Dynamic flags
--
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,
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
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
import Platform
-#endif
import Module
import PackageConfig
import PrelNames ( mAIN )
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 )
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
import System.FilePath
import System.IO ( stderr, hPutChar )
| Opt_Pp
| Opt_ForceRecomp
| Opt_DryRun
- | Opt_DoAsmMangling
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
| Opt_KeepHiDiffs
| Opt_KeepHcFiles
| Opt_KeepSFiles
- | Opt_KeepRawSFiles
| Opt_KeepTmpFiles
| Opt_KeepRawTokenStream
| Opt_KeepLlvmFiles
| Opt_KindSignatures
| Opt_ParallelListComp
| Opt_TransformListComp
+ | Opt_MonadComprehensions
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_DoRec
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,
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,
-- 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.
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
| 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
-- object files on the current platform.
defaultObjectTarget :: HscTarget
defaultObjectTarget
+ | cGhcUnregisterised == "YES" = HscC
| cGhcWithNativeCodeGen == "YES" = HscAsm
- | otherwise = HscC
+ | otherwise = HscLlvm
data DynLibLoader
= Deployable
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
+ deriving (Show)
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
-- | 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,
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,
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,
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,
-- | 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,
-- 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
= 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)
{- **********************************************************************
------- 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
, 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
------ Machine dependant (-m<blah>) 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 -------------------------------------------------
, 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 }))
, 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 ----------------------------------------------------
( "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 ),
( "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 ),
( "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 ),
= [ Opt_AutoLinkPackages,
Opt_ReadUserPackageConf,
- Opt_DoAsmMangling,
-
Opt_SharedImplib,
+#if GHC_DEFAULT_NEW_CODEGEN
+ Opt_TryNewCodeGen,
+#endif
+
Opt_GenManifest,
Opt_EmbedManifest,
Opt_PrintBindContents,
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
{- **********************************************************************
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)
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)
-- (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
-- 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
-- -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
})
-- 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
-- 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
-- -----------------------------------------------------------------------------
-- 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)
+ ]
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
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
_ <- 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 =
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
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
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
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
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
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
-- 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)
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
-- (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
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
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)
-- 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)
:: 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
| 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
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)
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
| 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
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
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
-- | 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
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
}
-- %************************************************************************
--- -----------------------------------------------------------------------------\r
---\r
--- (c) The University of Glasgow, 2005\r
---\r
--- This module deals with --make\r
--- -----------------------------------------------------------------------------\r
-\r
-module GhcMake( \r
- depanal, \r
- load, LoadHowMuch(..),\r
-\r
- topSortModuleGraph, \r
-\r
- noModError, cyclicModuleErr\r
- ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-#ifdef GHCI\r
-import qualified Linker ( unload )\r
-#endif\r
-\r
-import DriverPipeline\r
-import DriverPhases\r
-import GhcMonad\r
-import Module\r
-import HscTypes\r
-import ErrUtils\r
-import DynFlags\r
-import HsSyn hiding ((<.>))\r
-import Finder\r
-import HeaderInfo\r
-import TcIface ( typecheckIface )\r
-import TcRnMonad ( initIfaceCheck )\r
-import RdrName ( RdrName )\r
-\r
-import Exception ( evaluate, tryIO )\r
-import Panic\r
-import SysTools\r
-import BasicTypes\r
-import SrcLoc\r
-import Util\r
-import Digraph\r
-import Bag ( listToBag )\r
-import Maybes ( expectJust, mapCatMaybes )\r
-import StringBuffer\r
-import FastString\r
-import Outputable\r
-import UniqFM\r
-\r
-import qualified Data.Map as Map\r
-import qualified FiniteMap as Map( insertListWith)\r
-\r
-import System.Directory ( doesFileExist, getModificationTime )\r
-import System.IO ( fixIO )\r
-import System.IO.Error ( isDoesNotExistError )\r
-import System.Time ( ClockTime )\r
-import System.FilePath\r
-import Control.Monad\r
-import Data.Maybe\r
-import Data.List\r
-import qualified Data.List as List\r
-\r
--- -----------------------------------------------------------------------------\r
--- Loading the program\r
-\r
--- | Perform a dependency analysis starting from the current targets\r
--- and update the session with the new module graph.\r
---\r
--- Dependency analysis entails parsing the @import@ directives and may\r
--- therefore require running certain preprocessors.\r
---\r
--- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.\r
--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the\r
--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to\r
--- changes to the 'DynFlags' to take effect you need to call this function\r
--- again.\r
---\r
-depanal :: GhcMonad m =>\r
- [ModuleName] -- ^ excluded modules\r
- -> Bool -- ^ allow duplicate roots\r
- -> m ModuleGraph\r
-depanal excluded_mods allow_dup_roots = do\r
- hsc_env <- getSession\r
- let\r
- dflags = hsc_dflags hsc_env\r
- targets = hsc_targets hsc_env\r
- old_graph = hsc_mod_graph hsc_env\r
- \r
- liftIO $ showPass dflags "Chasing dependencies"\r
- liftIO $ debugTraceMsg dflags 2 (hcat [\r
- text "Chasing modules from: ",\r
- hcat (punctuate comma (map pprTarget targets))])\r
-\r
- mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots\r
- modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }\r
- return mod_graph\r
-\r
--- | Describes which modules of the module graph need to be loaded.\r
-data LoadHowMuch\r
- = LoadAllTargets\r
- -- ^ Load all targets and its dependencies.\r
- | LoadUpTo ModuleName\r
- -- ^ Load only the given module and its dependencies.\r
- | LoadDependenciesOf ModuleName\r
- -- ^ Load only the dependencies of the given module, but not the module\r
- -- itself.\r
-\r
--- | Try to load the program. See 'LoadHowMuch' for the different modes.\r
---\r
--- This function implements the core of GHC's @--make@ mode. It preprocesses,\r
--- compiles and loads the specified modules, avoiding re-compilation wherever\r
--- possible. Depending on the target (see 'DynFlags.hscTarget') compilating\r
--- and loading may result in files being created on disk.\r
---\r
--- Calls the 'reportModuleCompilationResult' callback after each compiling\r
--- each module, whether successful or not.\r
---\r
--- Throw a 'SourceError' if errors are encountered before the actual\r
--- compilation starts (e.g., during dependency analysis). All other errors\r
--- are reported using the callback.\r
---\r
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag\r
-load how_much = do\r
- mod_graph <- depanal [] False\r
- load2 how_much mod_graph\r
-\r
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]\r
- -> m SuccessFlag\r
-load2 how_much mod_graph = do\r
- guessOutputFile\r
- hsc_env <- getSession\r
-\r
- let hpt1 = hsc_HPT hsc_env\r
- let dflags = hsc_dflags hsc_env\r
-\r
- -- The "bad" boot modules are the ones for which we have\r
- -- B.hs-boot in the module graph, but no B.hs\r
- -- The downsweep should have ensured this does not happen\r
- -- (see msDeps)\r
- let all_home_mods = [ms_mod_name s \r
- | s <- mod_graph, not (isBootSummary s)]\r
- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,\r
- not (ms_mod_name s `elem` all_home_mods)]\r
- ASSERT( null bad_boot_mods ) return ()\r
-\r
- -- check that the module given in HowMuch actually exists, otherwise\r
- -- topSortModuleGraph will bomb later.\r
- let checkHowMuch (LoadUpTo m) = checkMod m\r
- checkHowMuch (LoadDependenciesOf m) = checkMod m\r
- checkHowMuch _ = id\r
-\r
- checkMod m and_then\r
- | m `elem` all_home_mods = and_then\r
- | otherwise = do \r
- liftIO $ errorMsg dflags (text "no such module:" <+>\r
- quotes (ppr m))\r
- return Failed\r
-\r
- checkHowMuch how_much $ do\r
-\r
- -- mg2_with_srcimps drops the hi-boot nodes, returning a \r
- -- graph with cycles. Among other things, it is used for\r
- -- backing out partially complete cycles following a failed\r
- -- upsweep, and for removing from hpt all the modules\r
- -- not in strict downwards closure, during calls to compile.\r
- let mg2_with_srcimps :: [SCC ModSummary]\r
- mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing\r
-\r
- -- If we can determine that any of the {-# SOURCE #-} imports\r
- -- are definitely unnecessary, then emit a warning.\r
- warnUnnecessarySourceImports mg2_with_srcimps\r
-\r
- let\r
- -- check the stability property for each module.\r
- stable_mods@(stable_obj,stable_bco)\r
- = checkStability hpt1 mg2_with_srcimps all_home_mods\r
-\r
- -- prune bits of the HPT which are definitely redundant now,\r
- -- to save space.\r
- pruned_hpt = pruneHomePackageTable hpt1 \r
- (flattenSCCs mg2_with_srcimps)\r
- stable_mods\r
-\r
- _ <- liftIO $ evaluate pruned_hpt\r
-\r
- -- before we unload anything, make sure we don't leave an old\r
- -- interactive context around pointing to dead bindings. Also,\r
- -- write the pruned HPT to allow the old HPT to be GC'd.\r
- modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = pruned_hpt }\r
-\r
- liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$\r
- text "Stable BCO:" <+> ppr stable_bco)\r
-\r
- -- Unload any modules which are going to be re-linked this time around.\r
- let stable_linkables = [ linkable\r
- | m <- stable_obj++stable_bco,\r
- Just hmi <- [lookupUFM pruned_hpt m],\r
- Just linkable <- [hm_linkable hmi] ]\r
- liftIO $ unload hsc_env stable_linkables\r
-\r
- -- We could at this point detect cycles which aren't broken by\r
- -- a source-import, and complain immediately, but it seems better\r
- -- to let upsweep_mods do this, so at least some useful work gets\r
- -- done before the upsweep is abandoned.\r
- --hPutStrLn stderr "after tsort:\n"\r
- --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))\r
-\r
- -- Now do the upsweep, calling compile for each module in\r
- -- turn. Final result is version 3 of everything.\r
-\r
- -- Topologically sort the module graph, this time including hi-boot\r
- -- nodes, and possibly just including the portion of the graph\r
- -- reachable from the module specified in the 2nd argument to load.\r
- -- This graph should be cycle-free.\r
- -- If we're restricting the upsweep to a portion of the graph, we\r
- -- also want to retain everything that is still stable.\r
- let full_mg :: [SCC ModSummary]\r
- full_mg = topSortModuleGraph False mod_graph Nothing\r
-\r
- maybe_top_mod = case how_much of\r
- LoadUpTo m -> Just m\r
- LoadDependenciesOf m -> Just m\r
- _ -> Nothing\r
-\r
- partial_mg0 :: [SCC ModSummary]\r
- partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod\r
-\r
- -- LoadDependenciesOf m: we want the upsweep to stop just\r
- -- short of the specified module (unless the specified module\r
- -- is stable).\r
- partial_mg\r
- | LoadDependenciesOf _mod <- how_much\r
- = ASSERT( case last partial_mg0 of \r
- AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )\r
- List.init partial_mg0\r
- | otherwise\r
- = partial_mg0\r
- \r
- stable_mg = \r
- [ AcyclicSCC ms\r
- | AcyclicSCC ms <- full_mg,\r
- ms_mod_name ms `elem` stable_obj++stable_bco,\r
- ms_mod_name ms `notElem` [ ms_mod_name ms' | \r
- AcyclicSCC ms' <- partial_mg ] ]\r
-\r
- mg = stable_mg ++ partial_mg\r
-\r
- -- clean up between compilations\r
- let cleanup = cleanTempFilesExcept dflags\r
- (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))\r
-\r
- liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")\r
- 2 (ppr mg))\r
-\r
- setSession hsc_env{ hsc_HPT = emptyHomePackageTable }\r
- (upsweep_ok, modsUpswept)\r
- <- upsweep pruned_hpt stable_mods cleanup mg\r
-\r
- -- Make modsDone be the summaries for each home module now\r
- -- available; this should equal the domain of hpt3.\r
- -- Get in in a roughly top .. bottom order (hence reverse).\r
-\r
- let modsDone = reverse modsUpswept\r
-\r
- -- Try and do linking in some form, depending on whether the\r
- -- upsweep was completely or only partially successful.\r
-\r
- if succeeded upsweep_ok\r
-\r
- then \r
- -- Easy; just relink it all.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)\r
-\r
- -- Issue a warning for the confusing case where the user\r
- -- said '-o foo' but we're not going to do any linking.\r
- -- We attempt linking if either (a) one of the modules is\r
- -- called Main, or (b) the user said -no-hs-main, indicating\r
- -- that main() is going to come from somewhere else.\r
- --\r
- let ofile = outputFile dflags\r
- let no_hs_main = dopt Opt_NoHsMain dflags\r
- let \r
- main_mod = mainModIs dflags\r
- a_root_is_Main = any ((==main_mod).ms_mod) mod_graph\r
- do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib\r
-\r
- when (ghcLink dflags == LinkBinary \r
- && isJust ofile && not do_linking) $\r
- liftIO $ debugTraceMsg dflags 1 $\r
- text ("Warning: output was redirected with -o, " ++\r
- "but no output will be generated\n" ++\r
- "because there is no " ++ \r
- moduleNameString (moduleName main_mod) ++ " module.")\r
-\r
- -- link everything together\r
- hsc_env1 <- getSession\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)\r
-\r
- loadFinish Succeeded linkresult\r
-\r
- else \r
- -- Tricky. We need to back out the effects of compiling any\r
- -- half-done cycles, both so as to clean up the top level envs\r
- -- and to avoid telling the interactive linker to link them.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")\r
-\r
- let modsDone_names\r
- = map ms_mod modsDone\r
- let mods_to_zap_names \r
- = findPartiallyCompletedCycles modsDone_names \r
- mg2_with_srcimps\r
- let mods_to_keep\r
- = filter ((`notElem` mods_to_zap_names).ms_mod) \r
- modsDone\r
-\r
- hsc_env1 <- getSession\r
- let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) \r
- (hsc_HPT hsc_env1)\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)\r
-\r
- -- there should be no Nothings where linkables should be, now\r
- ASSERT(all (isJust.hm_linkable) \r
- (eltsUFM (hsc_HPT hsc_env))) do\r
- \r
- -- Link everything together\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4\r
-\r
- modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }\r
- loadFinish Failed linkresult\r
-\r
--- Finish up after a load.\r
-\r
--- If the link failed, unload everything and return.\r
-loadFinish :: GhcMonad m =>\r
- SuccessFlag -> SuccessFlag\r
- -> m SuccessFlag\r
-loadFinish _all_ok Failed\r
- = do hsc_env <- getSession\r
- liftIO $ unload hsc_env []\r
- modifySession discardProg\r
- return Failed\r
-\r
--- Empty the interactive context and set the module context to the topmost\r
--- newly loaded module, or the Prelude if none were loaded.\r
-loadFinish all_ok Succeeded\r
- = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }\r
- return all_ok\r
-\r
-\r
--- Forget the current program, but retain the persistent info in HscEnv\r
-discardProg :: HscEnv -> HscEnv\r
-discardProg hsc_env\r
- = hsc_env { hsc_mod_graph = emptyMG, \r
- hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = emptyHomePackageTable }\r
-\r
--- used to fish out the preprocess output files for the purposes of\r
--- cleaning up. The preprocessed file *might* be the same as the\r
--- source file, but that doesn't do any harm.\r
-ppFilesFromSummaries :: [ModSummary] -> [FilePath]\r
-ppFilesFromSummaries summaries = map ms_hspp_file summaries\r
-\r
--- | If there is no -o option, guess the name of target executable\r
--- by using top-level source file name as a base.\r
-guessOutputFile :: GhcMonad m => m ()\r
-guessOutputFile = modifySession $ \env ->\r
- let dflags = hsc_dflags env\r
- mod_graph = hsc_mod_graph env\r
- mainModuleSrcPath :: Maybe String\r
- mainModuleSrcPath = do\r
- let isMain = (== mainModIs dflags) . ms_mod\r
- [ms] <- return (filter isMain mod_graph)\r
- ml_hs_file (ms_location ms)\r
- name = fmap dropExtension mainModuleSrcPath\r
-\r
-#if defined(mingw32_HOST_OS)\r
- -- we must add the .exe extention unconditionally here, otherwise\r
- -- when name has an extension of its own, the .exe extension will\r
- -- not be added by DriverPipeline.exeFileName. See #2248\r
- name_exe = fmap (<.> "exe") name\r
-#else\r
- name_exe = name\r
-#endif\r
- in\r
- case outputFile dflags of\r
- Just _ -> env\r
- Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | Prune the HomePackageTable\r
---\r
--- Before doing an upsweep, we can throw away:\r
---\r
--- - For non-stable modules:\r
--- - all ModDetails, all linked code\r
--- - all unlinked code that is out of date with respect to\r
--- the source file\r
---\r
--- This is VERY IMPORTANT otherwise we'll end up requiring 2x the\r
--- space at the end of the upsweep, because the topmost ModDetails of the\r
--- old HPT holds on to the entire type environment from the previous\r
--- compilation.\r
-\r
-pruneHomePackageTable\r
- :: HomePackageTable\r
- -> [ModSummary]\r
- -> ([ModuleName],[ModuleName])\r
- -> HomePackageTable\r
-\r
-pruneHomePackageTable hpt summ (stable_obj, stable_bco)\r
- = mapUFM prune hpt\r
- where prune hmi\r
- | is_stable modl = hmi'\r
- | otherwise = hmi'{ hm_details = emptyModDetails }\r
- where\r
- modl = moduleName (mi_module (hm_iface hmi))\r
- hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms\r
- = hmi{ hm_linkable = Nothing }\r
- | otherwise\r
- = hmi\r
- where ms = expectJust "prune" (lookupUFM ms_map modl)\r
-\r
- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]\r
-\r
- is_stable m = m `elem` stable_obj || m `elem` stable_bco\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- Return (names of) all those in modsDone who are part of a cycle\r
--- as defined by theGraph.\r
-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]\r
-findPartiallyCompletedCycles modsDone theGraph\r
- = chew theGraph\r
- where\r
- chew [] = []\r
- chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.\r
- chew ((CyclicSCC vs):rest)\r
- = let names_in_this_cycle = nub (map ms_mod vs)\r
- mods_in_this_cycle \r
- = nub ([done | done <- modsDone, \r
- done `elem` names_in_this_cycle])\r
- chewed_rest = chew rest\r
- in \r
- if notNull mods_in_this_cycle\r
- && length mods_in_this_cycle < length names_in_this_cycle\r
- then mods_in_this_cycle ++ chewed_rest\r
- else chewed_rest\r
-\r
-\r
--- ---------------------------------------------------------------------------\r
--- Unloading\r
-\r
-unload :: HscEnv -> [Linkable] -> IO ()\r
-unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'\r
- = case ghcLink (hsc_dflags hsc_env) of\r
-#ifdef GHCI\r
- LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables\r
-#else\r
- LinkInMemory -> panic "unload: no interpreter"\r
- -- urgh. avoid warnings:\r
- hsc_env stable_linkables\r
-#endif\r
- _other -> return ()\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
-{- |\r
-\r
- Stability tells us which modules definitely do not need to be recompiled.\r
- There are two main reasons for having stability:\r
- \r
- - avoid doing a complete upsweep of the module graph in GHCi when\r
- modules near the bottom of the tree have not changed.\r
-\r
- - to tell GHCi when it can load object code: we can only load object code\r
- for a module when we also load object code fo all of the imports of the\r
- module. So we need to know that we will definitely not be recompiling\r
- any of these modules, and we can use the object code.\r
-\r
- The stability check is as follows. Both stableObject and\r
- stableBCO are used during the upsweep phase later.\r
-\r
-@\r
- stable m = stableObject m || stableBCO m\r
-\r
- stableObject m = \r
- all stableObject (imports m)\r
- && old linkable does not exist, or is == on-disk .o\r
- && date(on-disk .o) > date(.hs)\r
-\r
- stableBCO m =\r
- all stable (imports m)\r
- && date(BCO) > date(.hs)\r
-@\r
-\r
- These properties embody the following ideas:\r
-\r
- - if a module is stable, then:\r
-\r
- - if it has been compiled in a previous pass (present in HPT)\r
- then it does not need to be compiled or re-linked.\r
-\r
- - if it has not been compiled in a previous pass,\r
- then we only need to read its .hi file from disk and\r
- link it to produce a 'ModDetails'.\r
-\r
- - if a modules is not stable, we will definitely be at least\r
- re-linking, and possibly re-compiling it during the 'upsweep'.\r
- All non-stable modules can (and should) therefore be unlinked\r
- before the 'upsweep'.\r
-\r
- - Note that objects are only considered stable if they only depend\r
- on other objects. We can't link object code against byte code.\r
--}\r
-\r
-checkStability\r
- :: HomePackageTable -- HPT from last compilation\r
- -> [SCC ModSummary] -- current module graph (cyclic)\r
- -> [ModuleName] -- all home modules\r
- -> ([ModuleName], -- stableObject\r
- [ModuleName]) -- stableBCO\r
-\r
-checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs\r
- where\r
- checkSCC (stable_obj, stable_bco) scc0\r
- | stableObjects = (scc_mods ++ stable_obj, stable_bco)\r
- | stableBCOs = (stable_obj, scc_mods ++ stable_bco)\r
- | otherwise = (stable_obj, stable_bco)\r
- where\r
- scc = flattenSCC scc0\r
- scc_mods = map ms_mod_name scc\r
- home_module m = m `elem` all_home_mods && m `notElem` scc_mods\r
-\r
- scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))\r
- -- all imports outside the current SCC, but in the home pkg\r
- \r
- stable_obj_imps = map (`elem` stable_obj) scc_allimps\r
- stable_bco_imps = map (`elem` stable_bco) scc_allimps\r
-\r
- stableObjects = \r
- and stable_obj_imps\r
- && all object_ok scc\r
-\r
- stableBCOs = \r
- and (zipWith (||) stable_obj_imps stable_bco_imps)\r
- && all bco_ok scc\r
-\r
- object_ok ms\r
- | Just t <- ms_obj_date ms = t >= ms_hs_date ms \r
- && same_as_prev t\r
- | otherwise = False\r
- where\r
- same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi\r
- -> isObjectLinkable l && t == linkableTime l\r
- _other -> True\r
- -- why '>=' rather than '>' above? If the filesystem stores\r
- -- times to the nearset second, we may occasionally find that\r
- -- the object & source have the same modification time, \r
- -- especially if the source was automatically generated\r
- -- and compiled. Using >= is slightly unsafe, but it matches\r
- -- make's behaviour.\r
-\r
- bco_ok ms\r
- = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi ->\r
- not (isObjectLinkable l) && \r
- linkableTime l >= ms_hs_date ms\r
- _other -> False\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | The upsweep\r
---\r
--- This is where we compile each module in the module graph, in a pass\r
--- from the bottom to the top of the graph.\r
---\r
--- There better had not be any cyclic groups here -- we check for them.\r
-\r
-upsweep\r
- :: GhcMonad m\r
- => HomePackageTable -- ^ HPT from last time round (pruned)\r
- -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)\r
- -> IO () -- ^ How to clean up unwanted tmp files\r
- -> [SCC ModSummary] -- ^ Mods to do (the worklist)\r
- -> m (SuccessFlag,\r
- [ModSummary])\r
- -- ^ Returns:\r
- --\r
- -- 1. A flag whether the complete upsweep was successful.\r
- -- 2. The 'HscEnv' in the monad has an updated HPT\r
- -- 3. A list of modules which succeeded loading.\r
-\r
-upsweep old_hpt stable_mods cleanup sccs = do\r
- (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)\r
- return (res, reverse done)\r
- where\r
-\r
- upsweep' _old_hpt done\r
- [] _ _\r
- = return (Succeeded, done)\r
-\r
- upsweep' _old_hpt done\r
- (CyclicSCC ms:_) _ _\r
- = do dflags <- getSessionDynFlags\r
- liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)\r
- return (Failed, done)\r
-\r
- upsweep' old_hpt done\r
- (AcyclicSCC mod:mods) mod_index nmods\r
- = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ \r
- -- show (map (moduleUserString.moduleName.mi_module.hm_iface) \r
- -- (moduleEnvElts (hsc_HPT hsc_env)))\r
- let logger _mod = defaultWarnErrLogger\r
-\r
- hsc_env <- getSession\r
- mb_mod_info\r
- <- handleSourceError\r
- (\err -> do logger mod (Just err); return Nothing) $ do\r
- mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods\r
- mod mod_index nmods\r
- logger mod Nothing -- log warnings\r
- return (Just mod_info)\r
-\r
- liftIO cleanup -- Remove unwanted tmp files between compilations\r
-\r
- case mb_mod_info of\r
- Nothing -> return (Failed, done)\r
- Just mod_info -> do\r
- let this_mod = ms_mod_name mod\r
-\r
- -- Add new info to hsc_env\r
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info\r
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }\r
-\r
- -- Space-saving: delete the old HPT entry\r
- -- for mod BUT if mod is a hs-boot\r
- -- node, don't delete it. For the\r
- -- interface, the HPT entry is probaby for the\r
- -- main Haskell source file. Deleting it\r
- -- would force the real module to be recompiled\r
- -- every time.\r
- old_hpt1 | isBootSummary mod = old_hpt\r
- | otherwise = delFromUFM old_hpt this_mod\r
-\r
- done' = mod:done\r
-\r
- -- fixup our HomePackageTable after we've finished compiling\r
- -- a mutually-recursive loop. See reTypecheckLoop, below.\r
- hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'\r
- setSession hsc_env2\r
-\r
- upsweep' old_hpt1 done' mods (mod_index+1) nmods\r
-\r
--- | Compile a single module. Always produce a Linkable for it if\r
--- successful. If no compilation happened, return the old Linkable.\r
-upsweep_mod :: HscEnv\r
- -> HomePackageTable\r
- -> ([ModuleName],[ModuleName])\r
- -> ModSummary\r
- -> Int -- index of module\r
- -> Int -- total number of modules\r
- -> IO HomeModInfo\r
-\r
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods\r
- = let \r
- this_mod_name = ms_mod_name summary\r
- this_mod = ms_mod summary\r
- mb_obj_date = ms_obj_date summary\r
- obj_fn = ml_obj_file (ms_location summary)\r
- hs_date = ms_hs_date summary\r
-\r
- is_stable_obj = this_mod_name `elem` stable_obj\r
- is_stable_bco = this_mod_name `elem` stable_bco\r
-\r
- old_hmi = lookupUFM old_hpt this_mod_name\r
-\r
- -- We're using the dflags for this module now, obtained by\r
- -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.\r
- dflags = ms_hspp_opts summary\r
- prevailing_target = hscTarget (hsc_dflags hsc_env)\r
- local_target = hscTarget dflags\r
-\r
- -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that\r
- -- we don't do anything dodgy: these should only work to change\r
- -- from -fvia-C to -fasm and vice-versa, otherwise we could \r
- -- end up trying to link object code to byte code.\r
- target = if prevailing_target /= local_target\r
- && (not (isObjectTarget prevailing_target)\r
- || not (isObjectTarget local_target))\r
- then prevailing_target\r
- else local_target \r
-\r
- -- store the corrected hscTarget into the summary\r
- summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }\r
-\r
- -- The old interface is ok if\r
- -- a) we're compiling a source file, and the old HPT\r
- -- entry is for a source file\r
- -- b) we're compiling a hs-boot file\r
- -- Case (b) allows an hs-boot file to get the interface of its\r
- -- real source file on the second iteration of the compilation\r
- -- manager, but that does no harm. Otherwise the hs-boot file\r
- -- will always be recompiled\r
- \r
- mb_old_iface \r
- = case old_hmi of\r
- Nothing -> Nothing\r
- Just hm_info | isBootSummary summary -> Just iface\r
- | not (mi_boot iface) -> Just iface\r
- | otherwise -> Nothing\r
- where \r
- iface = hm_iface hm_info\r
-\r
- compile_it :: Maybe Linkable -> IO HomeModInfo\r
- compile_it mb_linkable = \r
- compile hsc_env summary' mod_index nmods \r
- mb_old_iface mb_linkable\r
-\r
- compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo\r
- compile_it_discard_iface mb_linkable =\r
- compile hsc_env summary' mod_index nmods\r
- Nothing mb_linkable\r
-\r
- -- With the HscNothing target we create empty linkables to avoid\r
- -- recompilation. We have to detect these to recompile anyway if\r
- -- the target changed since the last compile.\r
- is_fake_linkable\r
- | Just hmi <- old_hmi, Just l <- hm_linkable hmi =\r
- null (linkableUnlinked l)\r
- | otherwise =\r
- -- we have no linkable, so it cannot be fake\r
- False\r
-\r
- implies False _ = True\r
- implies True x = x\r
-\r
- in\r
- case () of\r
- _\r
- -- Regardless of whether we're generating object code or\r
- -- byte code, we can always use an existing object file\r
- -- if it is *stable* (see checkStability).\r
- | is_stable_obj, Just hmi <- old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable obj mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- object is stable, and we have an entry in the\r
- -- old HPT: nothing to do\r
-\r
- | is_stable_obj, isNothing old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling stable on-disk mod:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn\r
- (expectJust "upsweep1" mb_obj_date)\r
- compile_it (Just linkable)\r
- -- object is stable, but we need to load the interface\r
- -- off disk to make a HMI.\r
-\r
- | not (isObjectTarget target), is_stable_bco,\r
- (target /= HscNothing) `implies` not is_fake_linkable ->\r
- ASSERT(isJust old_hmi) -- must be in the old_hpt\r
- let Just hmi = old_hmi in do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable BCO mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- BCO is stable: nothing to do\r
-\r
- | not (isObjectTarget target),\r
- Just hmi <- old_hmi,\r
- Just l <- hm_linkable hmi,\r
- not (isObjectLinkable l),\r
- (target /= HscNothing) `implies` not is_fake_linkable,\r
- linkableTime l >= ms_hs_date summary -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- -- we have an old BCO that is up to date with respect\r
- -- to the source: do a recompilation check as normal.\r
-\r
- -- When generating object code, if there's an up-to-date\r
- -- object file on the disk, then we can use it.\r
- -- However, if the object file is new (compared to any\r
- -- linkable we had from a previous compilation), then we\r
- -- must discard any in-memory interface, because this\r
- -- means the user has compiled the source file\r
- -- separately and generated a new interface, that we must\r
- -- read from the disk.\r
- --\r
- | isObjectTarget target,\r
- Just obj_date <- mb_obj_date,\r
- obj_date >= hs_date -> do\r
- case old_hmi of\r
- Just hmi\r
- | Just l <- hm_linkable hmi,\r
- isObjectLinkable l && linkableTime l == obj_date -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date\r
- compile_it_discard_iface (Just linkable)\r
-\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod:" <+> ppr this_mod_name)\r
- compile_it Nothing\r
-\r
-\r
-\r
--- Filter modules in the HPT\r
-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable\r
-retainInTopLevelEnvs keep_these hpt\r
- = listToUFM [ (mod, expectJust "retain" mb_mod_info)\r
- | mod <- keep_these\r
- , let mb_mod_info = lookupUFM hpt mod\r
- , isJust mb_mod_info ]\r
-\r
--- ---------------------------------------------------------------------------\r
--- Typecheck module loops\r
-\r
-{-\r
-See bug #930. This code fixes a long-standing bug in --make. The\r
-problem is that when compiling the modules *inside* a loop, a data\r
-type that is only defined at the top of the loop looks opaque; but\r
-after the loop is done, the structure of the data type becomes\r
-apparent.\r
-\r
-The difficulty is then that two different bits of code have\r
-different notions of what the data type looks like.\r
-\r
-The idea is that after we compile a module which also has an .hs-boot\r
-file, we re-generate the ModDetails for each of the modules that\r
-depends on the .hs-boot file, so that everyone points to the proper\r
-TyCons, Ids etc. defined by the real module, not the boot module.\r
-Fortunately re-generating a ModDetails from a ModIface is easy: the\r
-function TcIface.typecheckIface does exactly that.\r
-\r
-Picking the modules to re-typecheck is slightly tricky. Starting from\r
-the module graph consisting of the modules that have already been\r
-compiled, we reverse the edges (so they point from the imported module\r
-to the importing module), and depth-first-search from the .hs-boot\r
-node. This gives us all the modules that depend transitively on the\r
-.hs-boot module, and those are exactly the modules that we need to\r
-re-typecheck.\r
-\r
-Following this fix, GHC can compile itself with --make -O2.\r
--}\r
-\r
-reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv\r
-reTypecheckLoop hsc_env ms graph\r
- | not (isBootSummary ms) && \r
- any (\m -> ms_mod m == this_mod && isBootSummary m) graph\r
- = do\r
- let mss = reachableBackwards (ms_mod_name ms) graph\r
- non_boot = filter (not.isBootSummary) mss\r
- debugTraceMsg (hsc_dflags hsc_env) 2 $\r
- text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)\r
- typecheckLoop hsc_env (map ms_mod_name non_boot)\r
- | otherwise\r
- = return hsc_env\r
- where\r
- this_mod = ms_mod ms\r
-\r
-typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv\r
-typecheckLoop hsc_env mods = do\r
- new_hpt <-\r
- fixIO $ \new_hpt -> do\r
- let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }\r
- mds <- initIfaceCheck new_hsc_env $ \r
- mapM (typecheckIface . hm_iface) hmis\r
- let new_hpt = addListToUFM old_hpt \r
- (zip mods [ hmi{ hm_details = details }\r
- | (hmi,details) <- zip hmis mds ])\r
- return new_hpt\r
- return hsc_env{ hsc_HPT = new_hpt }\r
- where\r
- old_hpt = hsc_HPT hsc_env\r
- hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods\r
-\r
-reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]\r
-reachableBackwards mod summaries\r
- = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]\r
- where -- the rest just sets up the graph:\r
- (graph, lookup_node) = moduleGraphNodes False summaries\r
- root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)\r
-\r
--- ---------------------------------------------------------------------------\r
--- Topological sort of the module graph\r
-\r
-type SummaryNode = (ModSummary, Int, [Int])\r
-\r
-topSortModuleGraph\r
- :: Bool\r
- -- ^ Drop hi-boot nodes? (see below)\r
- -> [ModSummary]\r
- -> Maybe ModuleName\r
- -- ^ Root module name. If @Nothing@, use the full graph.\r
- -> [SCC ModSummary]\r
--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes\r
--- The resulting list of strongly-connected-components is in topologically\r
--- sorted order, starting with the module(s) at the bottom of the\r
--- dependency graph (ie compile them first) and ending with the ones at\r
--- the top.\r
---\r
--- Drop hi-boot nodes (first boolean arg)? \r
---\r
--- - @False@: treat the hi-boot summaries as nodes of the graph,\r
--- so the graph must be acyclic\r
---\r
--- - @True@: eliminate the hi-boot nodes, and instead pretend\r
--- the a source-import of Foo is an import of Foo\r
--- The resulting graph has no hi-boot nodes, but can be cyclic\r
-\r
-topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod\r
- = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph\r
- where\r
- (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries\r
- \r
- initial_graph = case mb_root_mod of\r
- Nothing -> graph\r
- Just root_mod ->\r
- -- restrict the graph to just those modules reachable from\r
- -- the specified module. We do this by building a graph with\r
- -- the full set of nodes, and determining the reachable set from\r
- -- the specified node.\r
- let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node\r
- | otherwise = ghcError (ProgramError "module does not exist")\r
- in graphFromEdgedVertices (seq root (reachableG graph root))\r
-\r
-summaryNodeKey :: SummaryNode -> Int\r
-summaryNodeKey (_, k, _) = k\r
-\r
-summaryNodeSummary :: SummaryNode -> ModSummary\r
-summaryNodeSummary (s, _, _) = s\r
-\r
-moduleGraphNodes :: Bool -> [ModSummary]\r
- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)\r
-moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)\r
- where\r
- numbered_summaries = zip summaries [1..]\r
-\r
- lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode\r
- lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map\r
-\r
- lookup_key :: HscSource -> ModuleName -> Maybe Int\r
- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)\r
-\r
- node_map :: NodeMap SummaryNode\r
- node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)\r
- | node@(s, _, _) <- nodes ]\r
-\r
- -- We use integers as the keys for the SCC algorithm\r
- nodes :: [SummaryNode]\r
- nodes = [ (s, key, out_keys)\r
- | (s, key) <- numbered_summaries\r
- -- Drop the hi-boot ones if told to do so\r
- , not (isBootSummary s && drop_hs_boot_nodes)\r
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++\r
- out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++\r
- (-- see [boot-edges] below\r
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile \r
- then [] \r
- else case lookup_key HsBootFile (ms_mod_name s) of\r
- Nothing -> []\r
- Just k -> [k]) ]\r
-\r
- -- [boot-edges] if this is a .hs and there is an equivalent\r
- -- .hs-boot, add a link from the former to the latter. This\r
- -- has the effect of detecting bogus cases where the .hs-boot\r
- -- depends on the .hs, by introducing a cycle. Additionally,\r
- -- it ensures that we will always process the .hs-boot before\r
- -- the .hs, and so the HomePackageTable will always have the\r
- -- most up to date information.\r
-\r
- -- Drop hs-boot nodes by using HsSrcFile as the key\r
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile\r
- | otherwise = HsBootFile\r
-\r
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]\r
- out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms\r
- -- If we want keep_hi_boot_nodes, then we do lookup_key with\r
- -- the IsBootInterface parameter True; else False\r
-\r
-\r
-type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are \r
-type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs\r
-\r
-msKey :: ModSummary -> NodeKey\r
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)\r
-\r
-mkNodeMap :: [ModSummary] -> NodeMap ModSummary\r
-mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]\r
- \r
-nodeMapElts :: NodeMap a -> [a]\r
-nodeMapElts = Map.elems\r
-\r
--- | If there are {-# SOURCE #-} imports between strongly connected\r
--- components in the topological sort, then those imports can\r
--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE\r
--- were necessary, then the edge would be part of a cycle.\r
-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()\r
-warnUnnecessarySourceImports sccs = do\r
- logWarnings (listToBag (concatMap (check.flattenSCC) sccs))\r
- where check ms =\r
- let mods_in_this_cycle = map ms_mod_name ms in\r
- [ warn i | m <- ms, i <- ms_home_srcimps m,\r
- unLoc i `notElem` mods_in_this_cycle ]\r
-\r
- warn :: Located ModuleName -> WarnMsg\r
- warn (L loc mod) = \r
- mkPlainErrMsg loc\r
- (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")\r
- <+> quotes (ppr mod))\r
-\r
------------------------------------------------------------------------------\r
--- Downsweep (dependency analysis)\r
-\r
--- Chase downwards from the specified root set, returning summaries\r
--- for all home modules encountered. Only follow source-import\r
--- links.\r
-\r
--- We pass in the previous collection of summaries, which is used as a\r
--- cache to avoid recalculating a module summary if the source is\r
--- unchanged.\r
---\r
--- The returned list of [ModSummary] nodes has one node for each home-package\r
--- module, plus one for any hs-boot files. The imports of these nodes \r
--- are all there, including the imports of non-home-package modules.\r
-\r
-downsweep :: HscEnv\r
- -> [ModSummary] -- Old summaries\r
- -> [ModuleName] -- Ignore dependencies on these; treat\r
- -- them as if they were package modules\r
- -> Bool -- True <=> allow multiple targets to have \r
- -- the same module name; this is \r
- -- very useful for ghc -M\r
- -> IO [ModSummary]\r
- -- The elts of [ModSummary] all have distinct\r
- -- (Modules, IsBoot) identifiers, unless the Bool is true\r
- -- in which case there can be repeats\r
-downsweep hsc_env old_summaries excl_mods allow_dup_roots\r
- = do\r
- rootSummaries <- mapM getRootSummary roots\r
- let root_map = mkRootMap rootSummaries\r
- checkDuplicates root_map\r
- summs <- loop (concatMap msDeps rootSummaries) root_map\r
- return summs\r
- where\r
- roots = hsc_targets hsc_env\r
-\r
- old_summary_map :: NodeMap ModSummary\r
- old_summary_map = mkNodeMap old_summaries\r
-\r
- getRootSummary :: Target -> IO ModSummary\r
- getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)\r
- = do exists <- liftIO $ doesFileExist file\r
- if exists \r
- then summariseFile hsc_env old_summaries file mb_phase \r
- obj_allowed maybe_buf\r
- else throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "can't find file:" <+> text file\r
- getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)\r
- = do maybe_summary <- summariseModule hsc_env old_summary_map False \r
- (L rootLoc modl) obj_allowed \r
- maybe_buf excl_mods\r
- case maybe_summary of\r
- Nothing -> packageModErr modl\r
- Just s -> return s\r
-\r
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")\r
-\r
- -- In a root module, the filename is allowed to diverge from the module\r
- -- name, so we have to check that there aren't multiple root files\r
- -- defining the same module (otherwise the duplicates will be silently\r
- -- ignored, leading to confusing behaviour).\r
- checkDuplicates :: NodeMap [ModSummary] -> IO ()\r
- checkDuplicates root_map \r
- | allow_dup_roots = return ()\r
- | null dup_roots = return ()\r
- | otherwise = liftIO $ multiRootsErr (head dup_roots)\r
- where\r
- dup_roots :: [[ModSummary]] -- Each at least of length 2\r
- dup_roots = filterOut isSingleton (nodeMapElts root_map)\r
-\r
- loop :: [(Located ModuleName,IsBootInterface)]\r
- -- Work list: process these modules\r
- -> NodeMap [ModSummary]\r
- -- Visited set; the range is a list because\r
- -- the roots can have the same module names\r
- -- if allow_dup_roots is True\r
- -> IO [ModSummary]\r
- -- The result includes the worklist, except\r
- -- for those mentioned in the visited set\r
- loop [] done = return (concat (nodeMapElts done))\r
- loop ((wanted_mod, is_boot) : ss) done \r
- | Just summs <- Map.lookup key done\r
- = if isSingleton summs then\r
- loop ss done\r
- else\r
- do { multiRootsErr summs; return [] }\r
- | otherwise\r
- = do mb_s <- summariseModule hsc_env old_summary_map \r
- is_boot wanted_mod True\r
- Nothing excl_mods\r
- case mb_s of\r
- Nothing -> loop ss done\r
- Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)\r
- where\r
- key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)\r
-\r
--- XXX Does the (++) here need to be flipped?\r
-mkRootMap :: [ModSummary] -> NodeMap [ModSummary]\r
-mkRootMap summaries = Map.insertListWith (flip (++))\r
- [ (msKey s, [s]) | s <- summaries ]\r
- Map.empty\r
-\r
-msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]\r
--- (msDeps s) returns the dependencies of the ModSummary s.\r
--- A wrinkle is that for a {-# SOURCE #-} import we return\r
--- *both* the hs-boot file\r
--- *and* the source file\r
--- as "dependencies". That ensures that the list of all relevant\r
--- modules always contains B.hs if it contains B.hs-boot.\r
--- Remember, this pass isn't doing the topological sort. It's\r
--- just gathering the list of all relevant ModSummaries\r
-msDeps s = \r
- concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] \r
- ++ [ (m,False) | m <- ms_home_imps s ] \r
-\r
-home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]\r
-home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]\r
- where isLocal Nothing = True\r
- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special\r
- isLocal _ = False\r
-\r
-ms_home_allimps :: ModSummary -> [ModuleName]\r
-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)\r
-\r
-ms_home_srcimps :: ModSummary -> [Located ModuleName]\r
-ms_home_srcimps = home_imps . ms_srcimps\r
-\r
-ms_home_imps :: ModSummary -> [Located ModuleName]\r
-ms_home_imps = home_imps . ms_imps\r
-\r
------------------------------------------------------------------------------\r
--- Summarising modules\r
-\r
--- We have two types of summarisation:\r
---\r
--- * Summarise a file. This is used for the root module(s) passed to\r
--- cmLoadModules. The file is read, and used to determine the root\r
--- module name. The module name may differ from the filename.\r
---\r
--- * Summarise a module. We are given a module name, and must provide\r
--- a summary. The finder is used to locate the file in which the module\r
--- resides.\r
-\r
-summariseFile\r
- :: HscEnv\r
- -> [ModSummary] -- old summaries\r
- -> FilePath -- source file name\r
- -> Maybe Phase -- start phase\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO ModSummary\r
-\r
-summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf\r
- -- we can use a cached summary if one is available and the\r
- -- source file hasn't changed, But we have to look up the summary\r
- -- by source file, rather than module name as we do in summarise.\r
- | Just old_summary <- findSummaryBySourceFile old_summaries file\r
- = do\r
- let location = ms_location old_summary\r
-\r
- -- return the cached summary if the source didn't change\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- The file exists; we checked in getRootSummary above.\r
- -- If it gets removed subsequently, then this \r
- -- getModificationTime may fail, but that's the right\r
- -- behaviour.\r
-\r
- if ms_hs_date old_summary == src_timestamp \r
- then do -- update the object-file timestamp\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ getObjTimestamp location False\r
- else return Nothing\r
- return old_summary{ ms_obj_date = obj_timestamp }\r
- else\r
- new_summary\r
-\r
- | otherwise\r
- = new_summary\r
- where\r
- new_summary = do\r
- let dflags = hsc_dflags hsc_env\r
-\r
- (dflags', hspp_fn, buf)\r
- <- preprocessFile hsc_env file mb_phase maybe_buf\r
-\r
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file\r
-\r
- -- Make a ModLocation for this file\r
- location <- liftIO $ mkHomeModLocation dflags mod_name file\r
-\r
- -- Tell the Finder cache where it is, so that subsequent calls\r
- -- to findModule will find it, even if it's not on any search path\r
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location\r
-\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- getMofificationTime may fail\r
-\r
- -- when the user asks to load a source file by name, we only\r
- -- use an object file if -fobject-code is on. See #1205.\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ modificationTimeIfExists (ml_obj_file location)\r
- else return Nothing\r
-\r
- return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps, ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp })\r
-\r
-findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary\r
-findSummaryBySourceFile summaries file\r
- = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],\r
- expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of\r
- [] -> Nothing\r
- (x:_) -> Just x\r
-\r
--- Summarise a module, and pick up source and timestamp.\r
-summariseModule\r
- :: HscEnv\r
- -> NodeMap ModSummary -- Map of old summaries\r
- -> IsBootInterface -- True <=> a {-# SOURCE #-} import\r
- -> Located ModuleName -- Imported module to be summarised\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer, ClockTime)\r
- -> [ModuleName] -- Modules to exclude\r
- -> IO (Maybe ModSummary) -- Its new summary\r
-\r
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) \r
- obj_allowed maybe_buf excl_mods\r
- | wanted_mod `elem` excl_mods\r
- = return Nothing\r
-\r
- | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map\r
- = do -- Find its new timestamp; all the \r
- -- ModSummaries in the old map have valid ml_hs_files\r
- let location = ms_location old_summary\r
- src_fn = expectJust "summariseModule" (ml_hs_file location)\r
-\r
- -- check the modification time on the source file, and\r
- -- return the cached summary if it hasn't changed. If the\r
- -- file has disappeared, we need to call the Finder again.\r
- case maybe_buf of\r
- Just (_,t) -> check_timestamp old_summary location src_fn t\r
- Nothing -> do\r
- m <- tryIO (getModificationTime src_fn)\r
- case m of\r
- Right t -> check_timestamp old_summary location src_fn t\r
- Left e | isDoesNotExistError e -> find_it\r
- | otherwise -> ioError e\r
-\r
- | otherwise = find_it\r
- where\r
- dflags = hsc_dflags hsc_env\r
-\r
- hsc_src = if is_boot then HsBootFile else HsSrcFile\r
-\r
- check_timestamp old_summary location src_fn src_timestamp\r
- | ms_hs_date old_summary == src_timestamp = do\r
- -- update the object-file timestamp\r
- obj_timestamp <- \r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
- return (Just old_summary{ ms_obj_date = obj_timestamp })\r
- | otherwise = \r
- -- source changed: re-summarise.\r
- new_summary location (ms_mod old_summary) src_fn src_timestamp\r
-\r
- find_it = do\r
- -- Don't use the Finder's cache this time. If the module was\r
- -- previously a package module, it may have now appeared on the\r
- -- search path, so we want to consider it to be a home module. If\r
- -- the module was previously a home module, it may have moved.\r
- uncacheModule hsc_env wanted_mod\r
- found <- findImportedModule hsc_env wanted_mod Nothing\r
- case found of\r
- Found location mod \r
- | isJust (ml_hs_file location) ->\r
- -- Home package\r
- just_found location mod\r
- | otherwise -> \r
- -- Drop external-pkg\r
- ASSERT(modulePackageId mod /= thisPackage dflags)\r
- return Nothing\r
- \r
- err -> noModError dflags loc wanted_mod err\r
- -- Not found\r
-\r
- just_found location mod = do\r
- -- Adjust location to point to the hs-boot source file, \r
- -- hi file, object file, when is_boot says so\r
- let location' | is_boot = addBootSuffixLocn location\r
- | otherwise = location\r
- src_fn = expectJust "summarise2" (ml_hs_file location')\r
-\r
- -- Check that it exists\r
- -- It might have been deleted since the Finder last found it\r
- maybe_t <- modificationTimeIfExists src_fn\r
- case maybe_t of\r
- Nothing -> noHsFileErr loc src_fn\r
- Just t -> new_summary location' mod src_fn t\r
-\r
-\r
- new_summary location mod src_fn src_timestamp\r
- = do\r
- -- Preprocess the source file and get its imports\r
- -- The dflags' contains the OPTIONS pragmas\r
- (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf\r
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn\r
-\r
- when (mod_name /= wanted_mod) $\r
- throwOneError $ mkPlainErrMsg mod_loc $ \r
- text "File name does not match module name:" \r
- $$ text "Saw:" <+> quotes (ppr mod_name)\r
- $$ text "Expected:" <+> quotes (ppr wanted_mod)\r
-\r
- -- Find the object timestamp, and return the summary\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
-\r
- return (Just (ModSummary { ms_mod = mod,\r
- ms_hsc_src = hsc_src,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps,\r
- ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp }))\r
-\r
-\r
-getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)\r
-getObjTimestamp location is_boot\r
- = if is_boot then return Nothing\r
- else modificationTimeIfExists (ml_obj_file location)\r
-\r
-\r
-preprocessFile :: HscEnv\r
- -> FilePath\r
- -> Maybe Phase -- ^ Starting phase\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO (DynFlags, FilePath, StringBuffer)\r
-preprocessFile hsc_env src_fn mb_phase Nothing\r
- = do\r
- (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)\r
- buf <- hGetStringBuffer hspp_fn\r
- return (dflags', hspp_fn, buf)\r
-\r
-preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))\r
- = do\r
- let dflags = hsc_dflags hsc_env\r
- -- case we bypass the preprocessing stage?\r
- let \r
- local_opts = getOptions dflags buf src_fn\r
- --\r
- (dflags', leftovers, warns)\r
- <- parseDynamicNoPackageFlags dflags local_opts\r
- checkProcessArgsResult leftovers\r
- handleFlagWarnings dflags' warns\r
-\r
- let\r
- needs_preprocessing\r
- | Just (Unlit _) <- mb_phase = True\r
- | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True\r
- -- note: local_opts is only required if there's no Unlit phase\r
- | xopt Opt_Cpp dflags' = True\r
- | dopt Opt_Pp dflags' = True\r
- | otherwise = False\r
-\r
- when needs_preprocessing $\r
- ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")\r
-\r
- return (dflags', src_fn, buf)\r
-\r
-\r
------------------------------------------------------------------------------\r
--- Error messages\r
------------------------------------------------------------------------------\r
-\r
-noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab\r
--- ToDo: we don't have a proper line number for this error\r
-noModError dflags loc wanted_mod err\r
- = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err\r
- \r
-noHsFileErr :: SrcSpan -> String -> IO a\r
-noHsFileErr loc path\r
- = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path\r
- \r
-packageModErr :: ModuleName -> IO a\r
-packageModErr mod\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> text "is a package module"\r
-\r
-multiRootsErr :: [ModSummary] -> IO ()\r
-multiRootsErr [] = panic "multiRootsErr"\r
-multiRootsErr summs@(summ1:_)\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> \r
- text "is defined in multiple files:" <+>\r
- sep (map text files)\r
- where\r
- mod = ms_mod summ1\r
- files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs\r
-\r
-cyclicModuleErr :: [ModSummary] -> SDoc\r
-cyclicModuleErr ms\r
- = hang (ptext (sLit "Module imports form a cycle for modules:"))\r
- 2 (vcat (map show_one ms))\r
- where\r
- mods_in_cycle = map ms_mod_name ms\r
- imp_modname = unLoc . ideclName . unLoc\r
- just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)\r
-\r
- show_one ms = \r
- vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>\r
- maybe empty (parens . text) (ml_hs_file (ms_location ms)),\r
- nest 2 $ ptext (sLit "imports:") <+> vcat [\r
- pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),\r
- pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]\r
- ]\r
- show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)\r
- pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)\r
+-- -----------------------------------------------------------------------------
+--
+-- (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 "<command line>")
+
+ -- 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)
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
- Session(..), withSession, modifySession, withTempSession,
+ Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings, printException, printExceptionAndWarnings,
- WarnErrLogger, defaultWarnErrLogger
+ WarnErrLogger, defaultWarnErrLogger
) where
import MonadUtils
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 )
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
, 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
, 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
, 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
, 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"
-- | 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
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
<- {-# 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 ---
-------------------- 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)
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
-- * Information about modules
ModDetails(..), emptyModDetails,
- ModGuts(..), CgGuts(..), ForeignStubs(..),
+ ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods,
ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
-- * 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,
Warnings(..), WarningTxt(..), plusWarns,
-- * Linker stuff
- Linkable(..), isObjectLinkable,
+ Linkable(..), isObjectLinkable, linkableObjs,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-- And get its dfuns
, thing <- things ]
+
+hptObjs :: HomePackageTable -> [FilePath]
+hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
\end{code}
%************************************************************************
-- | 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
-- 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
--
-- 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}
-- 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)
#include "HsVersions.h"
import PackageConfig
-import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) )
+import DynFlags
import StaticFlags
import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
unregFlags = map (mkGeneralLocated "in unregFlags")
[ "-optc-DNO_REGS"
, "-optc-DUSE_MINIINTERPRETER"
- , "-fno-asm-mangling"
, "-funregisterised" ]
-----------------------------------------------------------------------------
= 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.
-- 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
= 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
-----------------------------------------------------------------------------
\begin{code}
+{-# OPTIONS -fno-warn-unused-do-bind #-}
module SysTools (
-- Initialisation
initSysTools,
-- 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,
import Panic
import Util
import DynFlags
+import StaticFlags
import Exception
import Data.IORef
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
\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"
-- 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
(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"
-- 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}
= (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
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}
%************************************************************************
$ 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.
-- 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 ->
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,
<+> 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 },
+++ /dev/null
-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 */
-
-
--}
-
-
-
-
-
+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
-
-
--}
+++ /dev/null
-
-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
- ]
-
--}
-
-
-
+++ /dev/null
-
------------------------------------------------------------------------------
---
--- (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]
-
--}
-
-
-
-
+++ /dev/null
--- -----------------------------------------------------------------------------
---
--- (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
-
--}
#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
import BlockId
import CgUtils ( fixStgRegisters )
import OldCmm
-import CmmOpt ( cmmMiniInline, cmmMachOpFold )
+import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
import OldPprCmm
import CLabel
import Data.Maybe
import Control.Monad
import System.IO
-import Distribution.System
{-
The native-code generator has machine-independent and
, 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
#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
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...)
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] #))
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
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,
-- 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")))
module PPC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
genJump tree
= do
(target,code) <- getSomeReg tree
- return (code `snocOL` MTCTR target `snocOL` BCTR [])
+ return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
-- -----------------------------------------------------------------------------
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
(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
| 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]
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])
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)
= case insn of
BCC _ id -> [id]
BCCFAR _ id -> [id]
- BCTR targets -> targets
+ BCTR targets _ -> [id | Just id <- targets]
_ -> []
= 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
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
pprReg :: Reg -> Doc
pprReg r
char '\t',
pprReg reg
]
-pprInstr (BCTR _) = hcat [
+pprInstr (BCTR _ _) = hcat [
char '\t',
ptext (sLit "bctr")
]
-- 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]
_ -> 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
(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.
-- 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),
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
--- | Mark all these regal regs as allocated,
+-- | Mark all these real regs as allocated,
-- and kick out their vreg assignments.
--
clobberRegs :: [RealReg] -> RegM ()
-- -----------------------------------------------------------------------------
-- 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).
-- 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
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.
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
-- 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
-- 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
-- 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')
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
module SPARC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
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..
-- 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
import Reg
import Size
+import CLabel
import BlockId
import OldCmm
import FastString
-- 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
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)
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
= case insn of
BI _ _ id -> [id]
BF _ _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ -> [id | Just id <- ids]
_ -> []
= 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
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem
-- | 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
]
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 ]
module X86.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
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 _ _)
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
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
-- 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
(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
| 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.
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]
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)
x86_jumpDestsOfInstr insn
= case insn of
JXX _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ _ -> [id | Just id <- ids]
_ -> []
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
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,
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
import OldCmm
import CLabel
-import Config
import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
import Outputable (panic, Outputable)
import Data.Word
-import Distribution.System
#if i386_TARGET_ARCH && darwin_TARGET_OS
import Data.Bits
<+> 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) =
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
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)
-- 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!"
{-
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,
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc 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
| '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 }
| 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) }
-- 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
}
(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.
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,
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
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.
_ -> 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
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName,
+ fmapName,
-- MonadRec stuff
mfixName,
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
+
+ -- Monad comprehensions
+ , guardMName
+ , liftMName
+ , groupMName
+ , mzipName
]
genericTyConNames :: [Name]
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")
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")
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
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
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
failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
+fmapClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
-- Recursive do notation
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
-----------------------------------------------------
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
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"
------------------------------------------------------------------------
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,
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- (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)
(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)
-- 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:
-- {-# 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
-- 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}
%************************************************************************
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields,
- lookupSyntaxName, lookupSyntaxTable,
+ lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
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
import LoadIface ( loadInterfaceForName )
import UniqSet
import Data.List
-import Util ( isSingleton )
+import Util ( isSingleton, snocView )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
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) ->
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) ->
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
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
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
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}
\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) }
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"
\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),
-- 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.)
{ 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
; 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
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]
-- ...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
-- 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
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))
-- 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) ->
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"
%************************************************************************
\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 ()
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}
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) $
| 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
, 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,
\begin{code}
module TcArrows ( tcProc ) where
-import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
import HsSyn
import TcMatches
import TcPat
import TcUnify
import TcRnMonad
+import TcEnv
import Coercion
+import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
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
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
; 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) }
-----------------------------------------------------------------
%************************************************************************
%* *
+ 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
%* *
%************************************************************************
import TcPat
import TcMType
import TcType
-import RnBinds( misplacedSigErr )
import Coercion
import TysPrim
import Id
import Outputable
import FastString
-import Data.List( partition )
import Control.Monad
#include "HsVersions.h"
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
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
, 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
-- 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
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
import TcSMonad
import TcType
import TypeRep
+import Type( isTyVarTy )
import Inst
import InstEnv
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
, 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]
-- 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
-- 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
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 )
import Coercion
import Var
import VarSet
+import VarEnv
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import Util
import ListSetOps
import Maybes
+import ErrUtils
import Outputable
import FastString
import Control.Monad
-- 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
-- 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
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
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"
-- 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}
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}
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
\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
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}
%************************************************************************
-%* *
+%* *
\subsection{Miscellaneous}
-%* *
+%* *
%************************************************************************
\begin{code}
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 ()
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}
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
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
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
\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])
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}
-
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
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
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
------------------------------------------------------------------------
-- 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)
-- 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}
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 ->
; 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
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
; 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)
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}
| 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
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars, tcInstSigTyVars,
- tcInstType, instMetaTyVar,
+ tcInstTyVars, tcInstSigTyVars,
+ tcInstType,
tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType,
tcSkolDFunType, tcSuperSkolTyVars,
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}
; 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
-- 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)
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
-- 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}
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
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"
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
\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
-> 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
= 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 <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
+--
+-- We type the functions as follows:
+-- f <optional by> :: 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 = ...
-- 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
; 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]
; 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
; 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
(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
; 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 _ _
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}
-
%************************************************************************
%* *
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
-> 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
-- coi : T tys ~ pat_ty
\end{code}
-Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
-}
\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 ()
--------------------
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
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::()
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
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,
-- 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}
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 })
(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,
-- 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)
-- 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}
| 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
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")
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}
\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
-- 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 }
#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
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
-- 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)
-> 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}
\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.
; 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)
-- 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
-- variables; hence *no untouchables*
; (lhs_results, lhs_binds)
- <- runTcS SimplRuleLhs untch $
+ <- runTcS (SimplRuleLhs name) untch $
solveWanteds emptyInert zonked_lhs
; traceTc "simplifyRule" $
-- 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 $
-- 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"
\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)
-- 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 )
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> True
- _ -> False
+ MetaTv SigTv _ -> True
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
matchExpectedListTy, matchExpectedPArrTy,
matchExpectedTyConApp, matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunKind,
- wrapFunResCoercion
+ wrapFunResCoercion, failWithMisMatch
) where
#include "HsVersions.h"
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
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 "<pred>")) <> (ppr pred)
ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
else ptext (sLit "<nt>"))
| 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}
| 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
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))++")"
-- 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)
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
setColor u color
= graphMapModify
- $ adjustUFM
+ $ adjustUFM_C
(\n -> n { nodeColor = Just color })
u
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)
-- * Error handling and debugging utilities
pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
- pprTrace, warnPprTrace,
+ pprTrace, pprDefiniteTrace, warnPprTrace,
trace, pgmError, panic, sorry, panicFastInt, assertPanic
) where
| 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'
-- about what instruction set extensions an architecture might support.
--
data Arch
- = ArchAlpha
- | ArchX86
+ = ArchX86
| ArchX86_64
| ArchPPC
| ArchPPC_64
-- | 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
addListToUFM,addListToUFM_C,
addToUFM_Directly,
addListToUFM_Directly,
+ adjustUFM,
+ adjustUFM_Directly,
delFromUFM,
delFromUFM_Directly,
delListFromUFM,
intersectUFM,
intersectUFM_C,
foldUFM, foldUFM_Directly,
- mapUFM,
+ mapUFM, mapUFM_Directly,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly,
sizeUFM,
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}
-> 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
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
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)
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)
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}
%************************************************************************
-- * Floating point
readRational,
+ -- * read helpers
+ maybeReadFuzzy,
+
-- * IO-ish utilities
createDirectoryHierarchy,
doesDirNameExist,
Direction(..), reslash,
-- * Utils for defining Data instances
- abstractConstr, abstractDataType, mkNoRepType
+ abstractConstr, abstractDataType, mkNoRepType,
+
+ -- * Utils for printing C code
+ charToC
) where
#include "HsVersions.h"
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
-----------------------------------------------------------------------------
+-- 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 ()
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}
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
;;
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)
# 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"
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
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])
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
FP_DOCBOOK_XSL
FP_PROG_DBLATEX
-FP_PROG_HSTAGS
-
dnl ** check for ghc-pkg command
FP_PROG_GHC_PKG
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)
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
+++ /dev/null
-#!/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
-# <local-path> <remote-path> <vcs>
-#
-# 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/<local-path>
-# otherwise darcs-all works on repos of form
-# $repo_base/<remote-path>
-# 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 <local-path> and <remote-path> 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 = <IN>;
- 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 <<EOF;
-============================
-ATTENTION!
-
-You have an old bytestring repository in your GHC tree!
-
-Please remove it (e.g. "rm -r libraries/bytestring"), and the new
-version of bytestring will be used from a tarball instead.
-============================
-EOF
- }
- }
-
- message "== Checking for bytestring tarball";
- if (-d "libraries/bytestring" && not -d "libraries/bytestring/_darcs") {
- print <<EOF;
-============================
-ATTENTION!
-
-You have an old bytestring in your GHC tree!
-
-Please remove it (e.g. "rm -r libraries/bytestring"), and then run
-"./darcs-all get" to get the darcs repository.
-============================
-EOF
- }
-
- message "== Checking for unpulled tarball patches";
- if ((system "darcs annotate --match 'hash 20090930200358-3fd76-cab3bf4a0a9e3902eb6dd41f71712ad3a6a9bcd1' > /dev/null 2> /dev/null") == 0) {
- print <<EOF;
-============================
-ATTENTION!
-
-You have the unpulled tarball patches in your GHC tree!
-
-Please remove them:
- darcs unpull -p "Use mingw tarballs to get mingw on Windows"
-and say yes to each patch.
-============================
-EOF
- }
-
- $? = $ec;
-}
-
-main(@ARGV);
-
$(MAKE) -C gmp install DOING_BIN_DIST=YES
$(MAKE) -C docs install-docs DOING_BIN_DIST=YES
$(MAKE) -C libraries/Cabal/doc install-docs DOING_BIN_DIST=YES
- $(INSTALL_DATA) $(INSTALL_OPTS) extra-gcc-opts $(libdir)
+ $(INSTALL_DATA) $(INSTALL_OPTS) settings $(libdir)
install :: postinstall denounce
WhatGccIsCalled="$CC"
AC_SUBST(WhatGccIsCalled)
-FP_HAVE_GCC
+FP_GCC_VERSION
AC_PROG_CPP
#
FP_PROG_AR_NEEDS_RANLIB
#
-AC_CONFIG_FILES(extra-gcc-opts mk/config.mk mk/install.mk)
+AC_CONFIG_FILES(settings mk/config.mk mk/install.mk)
AC_OUTPUT
# We get caught by
style.</para>
</listitem>
</varlistentry>
+ </variablelist>
+ </sect2>
+
+ <sect2 id="formatting dumps">
+ <title>Formatting dumps</title>
+
+ <indexterm><primary>formatting dumps</primary></indexterm>
+
+ <variablelist>
+ <varlistentry>
+ <term>
+ <option>-dppr-user-length</option>
+ <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dppr-colsNNN</option>
+ <indexterm><primary><option>-dppr-colsNNN</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Set the width of debugging output. Use this if your code is wrapping too much.
+ For example: <option>-dppr-cols200</option>.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dppr-case-as-let</option>
+ <indexterm><primary><option>-dppr-case-as-let</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Print single alternative case expressions as though they were strict
+ let expressions. This is helpful when your code does a lot of unboxing.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dno-debug-output</option>
+ <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Suppress any unsolicited debugging output. When GHC
+ has been built with the <literal>DEBUG</literal> 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.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ </sect2>
+
+ <sect2 id="supression">
+ <title>Suppressing unwanted information</title>
+
+ <indexterm><primary>suppression</primary></indexterm>
+
+ 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.
+
+ <variablelist>
+ <varlistentry>
+ <term>
+ <option>-dsuppress-all</option>
+ <indexterm><primary><option>-dsuppress-all</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>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.</para>
+ </listitem>
+ </varlistentry>
<varlistentry>
<term>
<indexterm><primary><option>-dsuppress-uniques</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of uniques in debugging output. This may make
+ <para>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 <command>diff</command>. Once <command>diff</command>
<varlistentry>
<term>
- <option>-dsuppress-coercions</option>
- <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+ <option>-dsuppress-idinfo</option>
+ <indexterm><primary><option>-dsuppress-idinfo</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of coercions in Core dumps to make them
-shorter.</para>
+ <para>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</para>
</listitem>
</varlistentry>
<indexterm><primary><option>-dsuppress-module-prefixes</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</para>
+ <para>Suppress the printing of module qualification prefixes.
+ This is the <constant>Data.List</constant> in <constant>Data.List.length</constant>.</para>
</listitem>
</varlistentry>
<varlistentry>
<term>
- <option>-dppr-user-length</option>
- <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+ <option>-dsuppress-type-signatures</option>
+ <indexterm><primary><option>-dsuppress-type-signatures</option></primary></indexterm>
</term>
<listitem>
- <para>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.</para>
+ <para>Suppress the printing of type signatures.</para>
</listitem>
</varlistentry>
<varlistentry>
- <term>
- <option>-dno-debug-output</option>
- <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+ <term>
+ <option>-dsuppress-type-applications</option>
+ <indexterm><primary><option>-dsuppress-type-applications</option></primary></indexterm>
</term>
- <listitem>
- <para>Suppress any unsolicited debugging output. When GHC
- has been built with the <literal>DEBUG</literal> 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.</para>
- </listitem>
+ <listitem>
+ <para>Suppress the printing of type applications.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dsuppress-coercions</option>
+ <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Suppress the printing of type coercions.</para>
+ </listitem>
</varlistentry>
</variablelist>
</sect2>
#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));
(i.e. those arguments between
<literal>+RTS...-RTS</literal>).</para>
- <para>Next, we call
- <function>hs_add_root</function><indexterm><primary><function>hs_add_root</function></primary>
- </indexterm>, a GHC-specific interface which is required to
- initialise the Haskell modules in the program. The argument
- to <function>hs_add_root</function> 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
- <literal>Main</literal>, 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
- <function>hs_add_root</function> multiple times, one for each
- root. The name of the initialization function for module
- <replaceable>M</replaceable> is
- <literal>__stginit_<replaceable>M</replaceable></literal>, 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:</para>
-
<informaltable>
<tgroup cols="2" align="left" colsep="1" rowsep="1">
<thead>
// 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;
</programlisting>
<para>The initialisation routine, <literal>mylib_init</literal>, calls
- <literal>hs_init()</literal> and <literal>hs_add_root()</literal> as
+ <literal>hs_init()</literal> as
normal to initialise the Haskell runtime, and the corresponding
deinitialisation function <literal>mylib_end()</literal> calls
<literal>hs_exit()</literal> to shut down the runtime.</para>
invoke <literal>foreign export</literal>ed functions from
multiple OS threads concurrently. The runtime system must
be initialised as usual by
- calling <literal>hs_init()</literal>
- and <literal>hs_add_root</literal>, and these calls must
+ calling <literal>hs_init()</literal>, and this call must
complete before invoking any <literal>foreign
export</literal>ed functions.</para>
</sect3>
<entry>-</entry>
</row>
<row>
- <entry><option>-keep-raw-s-file</option> or
- <option>-keep-raw-s-files</option></entry>
- <entry>retain intermediate <literal>.raw_s</literal> files</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-keep-tmp-files</option></entry>
<entry>retain all intermediate temporary files</entry>
<entry>dynamic</entry>
<row>
<entry><option>-package-name</option> <replaceable>P</replaceable></entry>
<entry>Compile to be part of package <replaceable>P</replaceable></entry>
- <entry>dynamic</entry>
+ <entry>static</entry>
<entry>-</entry>
</row>
<row>
<entry>dynamic</entry>
<entry><option>-XNoTransformListComp</option></entry>
</row>
+ <row>
+ <entry><option>-XMonadComprehensions</option></entry>
+ <entry>Enable <link linkend="monad-comprehensions">monad comprehensions</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoMonadComprehensions</option></entry>
+ </row>
<row>
<entry><option>-XUnliftedFFITypes</option></entry>
<entry>Enable unlifted FFI types.</entry>
</row>
<row>
+ <entry><option>-fwarn-missing-local-sigs</option></entry>
+ <entry>warn about polymorphic local bindings without signatures</entry>
+ <entry>dynamic</entry>
+ <entry><option>-fno-warn-missing-local-sigs</option></entry>
+ </row>
+
+ <row>
<entry><option>-fwarn-name-shadowing</option></entry>
<entry>warn when names are shadowed</entry>
<entry>dynamic</entry>
</row>
</row>
<row>
- <entry><option>-pgmm</option> <replaceable>cmd</replaceable></entry>
- <entry>Use <replaceable>cmd</replaceable> as the mangler</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-pgms</option> <replaceable>cmd</replaceable></entry>
<entry>Use <replaceable>cmd</replaceable> as the splitter</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
+ <entry><option>-dppr-noprags</option></entry>
+ <entry>Don't output pragma info in dumps</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-user-length</option></entry>
+ <entry>Set the depth for printing expressions in error msgs</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-colsNNN</option></entry>
+ <entry>Set the width of debugging output. For example <option>-dppr-cols200</option></entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-case-as-let</option></entry>
+ <entry>Print single alternative case expressions as strict lets.</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dsuppress-all</option></entry>
+ <entry>In core dumps, suppress everything that is suppressable.</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
<entry><option>-dsuppress-uniques</option></entry>
- <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>.</entry>
+ <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>)</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dsuppress-coercions</option></entry>
- <entry>Suppress the printing of coercions in Core dumps to make them shorter.</entry>
+ <entry><option>-dsuppress-idinfo</option></entry>
+ <entry>Suppress extended information about identifiers where they are bound</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-module-prefixes</option></entry>
- <entry>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</entry>
+ <entry>Suppress the printing of module qualification prefixes</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dppr-noprags</option></entry>
- <entry>Don't output pragma info in dumps</entry>
+ <entry><option>-dsuppress-type-signatures</option></entry>
+ <entry>Suppress type signatures</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dppr-user-length</option></entry>
- <entry>Set the depth for printing expressions in error msgs</entry>
+ <entry><option>-dsuppress-type-applications</option></entry>
+ <entry>Suppress type applications</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dsuppress-coercions</option></entry>
+ <entry>Suppress the printing of coercions in Core dumps to make them shorter</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<entry>-</entry>
</row>
<row>
- <entry><option>-fno-asm-mangling</option></entry>
- <entry>Turn off assembly mangling (use <option>-unreg</option> instead)</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-fno-ghci-sandbox</option></entry>
<entry>Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread.</entry>
<entry>dynamic</entry>
</para>
</sect2>
+ <!-- ===================== MONAD COMPREHENSIONS ===================== -->
+
+<sect2 id="monad-comprehensions">
+ <title>Monad comprehensions</title>
+ <indexterm><primary>monad comprehensions</primary></indexterm>
+
+ <para>
+ Monad comprehesions generalise the list comprehension notation,
+ including parallel comprehensions
+ (<xref linkend="parallel-list-comprehensions"/>) and
+ transform comprenensions (<xref linkend="generalised-list-comprehensions"/>)
+ to work for any monad.
+ </para>
+
+ <para>Monad comprehensions support:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>
+ Bindings:
+ </para>
+
+<programlisting>
+[ x + y | x <- Just 1, y <- Just 2 ]
+</programlisting>
+
+ <para>
+ Bindings are translated with the <literal>(>>=)</literal> and
+ <literal>return</literal> functions to the usual do-notation:
+ </para>
+
+<programlisting>
+do x <- Just 1
+ y <- Just 2
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Guards:
+ </para>
+
+<programlisting>
+[ x | x <- [1..10], x <= 5 ]
+</programlisting>
+
+ <para>
+ Guards are translated with the <literal>guard</literal> function,
+ which requires a <literal>MonadPlus</literal> instance:
+ </para>
+
+<programlisting>
+do x <- [1..10]
+ guard (x <= 5)
+ return x
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Transform statements (as with <literal>-XTransformListComp</literal>):
+ </para>
+
+<programlisting>
+[ x+y | x <- [1..10], y <- [1..x], then take 2 ]
+</programlisting>
+
+ <para>
+ This translates to:
+ </para>
+
+<programlisting>
+do (x,y) <- take 2 (do x <- [1..10]
+ y <- [1..x]
+ return (x,y))
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Group statements (as with <literal>-XTransformListComp</literal>):
+ </para>
+
+<programlisting>
+[ 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 ]
+</programlisting>
+
+ <para>
+ The basic <literal>then group by e</literal> statement is
+ translated using the <literal>mgroupWith</literal> function, which
+ requires a <literal>MonadGroup</literal> instance, defined in
+ <ulink url="&libraryBaseLocation;/Control-Monad-Group.html"><literal>Control.Monad.Group</literal></ulink>:
+ </para>
+
+<programlisting>
+do x <- mgroupWith (do x <- [1,1,2,2,3]
+ return x)
+ return x
+</programlisting>
+
+ <para>
+ Note that the type of <literal>x</literal> is changed by the
+ grouping statement.
+ </para>
+
+ <para>
+ The grouping function can also be defined with the
+ <literal>using</literal> keyword.
+ </para>
+
+ </listitem>
+ <listitem>
+ <para>
+ Parallel statements (as with <literal>-XParallelListComp</literal>):
+ </para>
+
+<programlisting>
+[ (x+y) | x <- [1..10]
+ | y <- [11..20]
+ ]
+</programlisting>
+
+ <para>
+ Parallel statements are translated using the
+ <literal>mzip</literal> function, which requires a
+ <literal>MonadZip</literal> instance defined in
+ <ulink url="&libraryBaseLocation;/Control-Monad-Zip.html"><literal>Control.Monad.Zip</literal></ulink>:
+ </para>
+
+<programlisting>
+do (x,y) <- mzip (do x <- [1..10]
+ return x)
+ (do y <- [11..20]
+ return y)
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ </itemizedlist>
+
+ <para>
+ All these features are enabled by default if the
+ <literal>MonadComprehensions</literal> extension is enabled. The types
+ and more detailed examples on how to use comprehensions are explained
+ in the previous chapters <xref
+ linkend="generalised-list-comprehensions"/> and <xref
+ linkend="parallel-list-comprehensions"/>. In general you just have
+ to replace the type <literal>[a]</literal> with the type
+ <literal>Monad m => m a</literal> for monad comprehensions.
+ </para>
+
+ <para>
+ Note: Even though most of these examples are using the list monad,
+ monad comprehensions work for any monad.
+ The <literal>base</literal> package offers all necessary instances for
+ lists, which make <literal>MonadComprehensions</literal> backward
+ compatible to built-in, transform and parallel list comprehensions.
+ </para>
+<para> More formally, the desugaring is as follows. We write <literal>D[ e | Q]</literal>
+to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>:
+<programlisting>
+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)
+</programlisting>
+The comprehension should typecheck when its desugaring would typecheck.
+</para>
+<para>
+Monad comprehensions support rebindable syntax (<xref linkend="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 "<literal>mzip</literal>" is in scope.
+</para>
+<para>
+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
+<programlisting>
+(>>=) :: T x y a -> (a -> T y z b) -> T x z b
+</programlisting>
+In the case of transform comprehensions, notice that the groups are
+parameterised over some arbitrary type <literal>n</literal> (provided it
+has an <literal>fmap</literal>, as well as
+the comprehension being over an arbitrary monad.
+</para>
+</sect2>
+
<!-- ===================== REBINDABLE SYNTAX =================== -->
<sect2 id="rebindable-syntax">
<programlisting>
f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool )
</programlisting>
-Here, the type signature <literal>forall a. ST s Bool</literal> brings the
+Here, the type signature <literal>forall s. ST s Bool</literal> brings the
type variable <literal>s</literal> into scope, in the annotated expression
<literal>(op >>= \(x :: STRef s Int) -> g x)</literal>.
</para>
<programlisting>
/usr/bin/ld: Undefined symbols:
_ZCMain_main_closure
-___stginit_ZCMain
</programlisting>
</para>
<varlistentry>
<term>
- <option>-pgmm</option> <replaceable>cmd</replaceable>
- <indexterm><primary><option>-pgmm</option></primary></indexterm>
- </term>
- <listitem>
- <para>Use <replaceable>cmd</replaceable> as the
- mangler.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-pgms</option> <replaceable>cmd</replaceable>
<indexterm><primary><option>-pgms</option></primary></indexterm>
</term>
<varlistentry>
<term>
- <option>-keep-raw-s-file</option>,
- <option>-keep-raw-s-files</option>
- <indexterm><primary><option>-keep-raw-s-file</option></primary></indexterm>
- <indexterm><primary><option>-keep-raw-s-files</option></primary></indexterm>
- </term>
- <listitem>
- <para>Keep intermediate <literal>.raw-s</literal> files.
- These are the direct output from the C compiler, before
- GHC does “assembly mangling” to produce the
- <literal>.s</literal> file. Again, these are not produced
- when using the native code generator.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-keep-tmp-files</option>
<indexterm><primary><option>-keep-tmp-files</option></primary></indexterm>
<indexterm><primary>temporary files</primary><secondary>keeping</secondary></indexterm>
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
</varlistentry>
<varlistentry>
+ <term><option>-fwarn-missing-local-sigs</option>:</term>
+ <listitem>
+ <indexterm><primary><option>-fwarn-missing-local-sigs</option></primary></indexterm>
+ <indexterm><primary>type signatures, missing</primary></indexterm>
+
+ <para>If you use the
+ <option>-fwarn-missing-local-sigs</option> 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.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
<term><option>-fwarn-name-shadowing</option>:</term>
<listitem>
<indexterm><primary><option>-fwarn-name-shadowing</option></primary></indexterm>
</listitem>
</varlistentry>
- <varlistentry>
- <term><option>-monly-[32]-regs</option>:</term>
- <listitem>
- <para>(x86 only)<indexterm><primary>-monly-N-regs
- option (iX86 only)</primary></indexterm> 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:
-
-<screen>
-Foo.hc:533: fixed or forbidden register was spilled.
-This may be due to a compiler bug or to impossible asm
-statements or clauses.
-</screen>
-
- Just give some registers back with
- <option>-monly-N-regs</option>. Try `3' first, then `2'.
- If `2' doesn't work, please report the bug to us.</para>
- </listitem>
- </varlistentry>
</variablelist>
</sect1>
// StartEnd.c
#include <Rts.h>
-extern void __stginit_Adder(void);
-
void HsStart()
{
int argc = 1;
// Initialize Haskell runtime
char** args = argv;
hs_init(&argc, &args);
-
- // Tell Haskell about all root modules
- hs_add_root(__stginit_Adder);
}
void HsEnd()
+++ /dev/null
-# -----------------------------------------------------------------------------
-#
-# (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
+++ /dev/null
-%************************************************************************
-%* *
-\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 <foo> .text (MIPS only)
-
- $i = 0; $chkcat[0] = 'misc'; $chk[0] = '';
-
- while (<INASM>) {
- 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<module>
- || /^${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 "<dollar>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 *<something involving %esp>
- # or
- # jmp <something involving another naughty register...>
- #
- # a reasonably-common case is:
- #
- # movl $_blah,<bad-reg>
- # jmp *<bad-reg>
- #
- 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 (<INASM>) {
- 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}
+++ /dev/null
-# -----------------------------------------------------------------------------
-#
-# (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))
-
+++ /dev/null
-@GccExtraViaCOpts@
# -----------------------------------------------------------------------------
# Building dependencies
+include rules/dependencies.mk
include rules/build-dependencies.mk
include rules/include-dependencies.mk
ifneq "$(GhcUnregisterised)" "YES"
BUILD_DIRS += \
- $(GHC_MANGLER_DIR) \
$(GHC_SPLIT_DIR)
endif
# -----------------------------------------------------------------------------
# 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
README \
INSTALL \
configure config.sub config.guess install-sh \
- extra-gcc-opts.in \
+ settings.in \
packages \
Makefile \
mk/config.mk.in \
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 \
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)
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
"$(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
%{_prefix}/bin/ghci
%{_prefix}/bin/ghci-%{version}
%{_prefix}/bin/ghcprof
-%{_prefix}/bin/hasktags
%{_prefix}/bin/hp2ps
%{_prefix}/bin/hpc
%{_prefix}/bin/hsc2hs-ghc
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
showNumVersionMode = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
-printMode :: String -> Mode
-printMode str = mkPreStartupMode (Print str)
-
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left
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
, 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)
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
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
XXX
Category: XXX
Data-Dir: ..
-Data-Files: extra-gcc-opts
+Data-Files: settings
Build-Type: Simple
Cabal-Version: >= 1.2
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"
endif
-INSTALL_LIBS += extra-gcc-opts
+INSTALL_LIBS += settings
ifeq "$(Windows)" "NO"
install: install_ghc_link
-exec "$executablename" -B"$topdir" -pgmc "$pgmgcc" -pgma "$pgmgcc" -pgml "$pgmgcc" -pgmP "$pgmgcc -E -undef -traditional" ${1+"$@"}
+exec "$executablename" -B"$topdir" ${1+"$@"}
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.
+++ /dev/null
-#ifndef MAKING_GHC_BUILD_SYSTEM_DEPENDENCIES
-#warning RtsFlags.h is DEPRECATED; please just #include "Rts.h"
-#endif
-
-#include "Rts.h"
#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 */
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
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);
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);
#define store_load_barrier() /* nothing */
#define load_load_barrier() /* nothing */
+#if !IN_STG_CODE || IN_STGCRUN
INLINE_HEADER StgWord
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;
{
return --(*p);
}
+#endif
#define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p)))
#
# 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'
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
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))
# binary-dist
BINDIST_EXTRAS += libffi/package.conf.in
-
+++ /dev/null
-# 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
-
+++ /dev/null
-ifeq "" "${MKDIR}"
-MKDIR:=$(shell pwd)
-#MKDIR:=$(PWD)
-else
-MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR})
-endif
-include ${MKDIR}/Makefile.inc
-
+++ /dev/null
-# 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
-
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" ]
# -----------------------------------------------------------------------------
# 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 = :
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
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
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)
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)
# the flag --with-gcc=<blah> 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<blah> to select
# correct C compiler backend). The stage number is the stage of GHC
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
PERL = @PerlCmd@
PYTHON = @PythonCmd@
PIC = pic
-PREPROCESSCMD = $(CC) -E
RANLIB = @RANLIB@
SED = @SedCmd@
TR = tr
# 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
#
SRC_ALEX_OPTS = -g
-HSTAGS = @HstagsCmd@
-
# Should we build haddock docs?
HADDOCK_DOCS = YES
# And HsColour the sources?
# 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@
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
+++ /dev/null
-# 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 -
------------------------------------------------------------------------ */
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
// 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
- -------------------------------------------------------------------------- */
-
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);
/* -----------------------------------------------------------------------------
/* 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 */
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 */
};
* 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;
}
}
static void
-freeHashList(HashList *hl)
+freeHashList (HashTable *table, HashList *hl)
{
- hl->next = freeList;
- freeList = hl;
+ hl->next = table->freeList;
+ table->freeList = hl;
}
void
segment = bucket / HSEGSIZE;
index = bucket % HSEGSIZE;
- hl = allocHashList();
+ hl = allocHashList(table);
hl->key = key;
hl->data = data;
table->dir[segment][index] = hl->next;
else
prev->next = hl->next;
- freeHashList(hl);
+ freeHashList(table,hl);
table->kcount--;
return hl->data;
}
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;
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);
}
table->mask2 = 2 * HSEGSIZE - 1;
table->kcount = 0;
table->bcount = HSEGSIZE;
+ table->freeList = NULL;
+ table->chunks = NULL;
table->hash = hash;
table->compare = compare;
void
exitHashTable(void)
{
- struct chunkList *cl;
-
- while ((cl = chunks) != NULL) {
- chunks = cl->next;
- stgFree(cl->chunk);
- stgFree(cl);
- }
+ /* nothing to do */
}
#include "Rts.h"
#include "Trace.h"
+#include "Hash.h"
+#include "RtsUtils.h"
#include <stdio.h>
#include <ctype.h>
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) {
}
static char *expectString(void) {
- char tmp[256], *res;
+ char tmp[256], *res; // XXX
int tmp_ix = 0;
expect('"');
while (tix_ch != '"') {
}
tmp[tmp_ix++] = 0;
expect('"');
- res = malloc(tmp_ix);
+ res = stgMallocBytes(tmp_ix,"Hpc.expectString");
strcpy(res,tmp);
return res;
}
static void
readTix(void) {
unsigned int i;
- HpcModuleInfo *tmpModule;
+ HpcModuleInfo *tmpModule, *lookup;
- totalTixes = 0;
-
ws();
expect('T');
expect('i');
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');
ws();
tmpModule -> tickCount = (int)expectWord64();
tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
- tmpModule -> tickOffset = totalTixes;
- totalTixes += tmpModule -> tickCount;
ws();
expect('[');
ws();
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();
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;
}
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) {
#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);
}
}
}
-/* 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;
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++) {
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
FILE *f = fopen(tixFilename,"w");
writeTix(f);
}
+
+ freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo);
+ moduleHash = NULL;
+
+ stgFree(tixFilename);
+ tixFilename = NULL;
}
//////////////////////////////////////////////////////////////////////////////
#include <sys/wait.h>
#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.
#elif defined(darwin_HOST_OS)
# define OBJFORMAT_MACHO
# include <regex.h>
+# include <mach/machine.h>
+# include <mach-o/fat.h>
# include <mach-o/loader.h>
# include <mach-o/nlist.h>
# include <mach-o/reloc.h>
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) \
# 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
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
int pagesize, size;
static nat fixed = 0;
+ IF_DEBUG(linker, debugBelch("mmapForLinker: start\n"));
pagesize = getpagesize();
size = ROUND_UP(bytes, pagesize);
}
#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);
}
#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
) {
ObjectCode* oc;
+ IF_DEBUG(linker, debugBelch("mkOc: start\n"));
oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)");
# if defined(OBJFORMAT_ELF)
oc->next = objects;
objects = oc;
+ IF_DEBUG(linker, debugBelch("mkOc: done\n"));
return oc;
}
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;
if (!f)
barf("loadObj: can't read `%s'", path);
+ /* Check if this is an archive by looking for the magic "!<arch>\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 "!<arch>\n" string and continue processing just as if
+ * we had a single architecture archive.
+ */
+
n = fread ( tmp, 1, 8, f );
- if (strncmp(tmp, "!<arch>\n", 8) != 0)
+ if (n != 8)
+ barf("loadArchive: Failed reading header from `%s'", path);
+ if (strncmp(tmp, "!<arch>\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, "!<arch>\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, "!<arch>\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);
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]);
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);
&& 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;
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);
#endif
}
+ IF_DEBUG(linker, debugBelch("loadArchive: done\n"));
return 1;
}
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
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;
}
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;
}
* 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;
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;
/* -----------------------------------------------------------------------------
* 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");
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 ));
}
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;
"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)
#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;i<symLC->nsyms;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",
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,
#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++)
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);
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);
}
// 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)
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)
|| 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)
{
i++;
}
#endif
- else
- {
+ else {
barf ("Don't know how to handle this Mach-O "
"scattered relocation entry: "
"object file %s; entry type %ld; "
*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);
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;
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",
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
reloc->r_symbolnum,
(unsigned long) symbolAddress)
-> jumpIsland;
- if(jumpIsland != 0)
- {
+ if (jumpIsland != 0) {
offsetToJumpIsland = word + jumpIsland
- (((long)image) + sect->offset - sect->addr);
}
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;
}
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),
}
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;
}
}
#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;
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)
+ }
+ else if (lc->cmd == LC_SYMTAB) {
symLC = (struct symtab_command*) lc;
+ }
+
lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize );
}
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;i<segLC->nsects;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)
{
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;i<symLC->nsyms;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
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;i<symLC->nsyms;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;
}
}
}
+
+ 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;
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 );
}
extern void* symbolsWithoutUnderscore[];
-static void machoInitSymbolsWithoutUnderscore()
+static void
+machoInitSymbolsWithoutUnderscore(void)
{
void **p = symbolsWithoutUnderscore;
__asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:");
* 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;
#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);
}
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;
{
}
-void freeProfiling1 (void)
+void freeProfiling (void)
{
}
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:
* 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.
*/
/* 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:
/* 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);
}
* 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;
#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;
#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);
}
}
#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;
#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);
}
}
#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;
// 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;
}
size += ts + 1;
}
else {
- if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ if (size + ts > max_length - DOT_NUMBER) {
sprintf(tmp + size, "...");
break;
}
#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.
#include "RtsOpts.h"
#include "RtsUtils.h"
#include "Profiling.h"
+#include "RtsFlags.h"
#ifdef HAVE_CTYPE_H
#include <ctype.h>
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.
* ---------------------------------------------------------------------------*/
return(strcmp(a, b) == 0);
}
-static void
-splitRtsFlags(char *s, int *rts_argc, char *rts_argv[])
+static void splitRtsFlags(char *s)
{
char *c1, *c2;
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);
}
} 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
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
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];
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])) {
break;
}
- if (rtsOptsEnabled != rtsOptsAll)
- {
+ if (enabled == RtsOptsSafeOnly) {
errorBelch("Most RTS options are disabled. Link with -rtsopts to enable them.");
stg_exit(EXIT_FAILURE);
}
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;
{
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;
}
}
+ 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;
}
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, ...)
{
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 <program>.<ext> */
- 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)
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
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (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 */
# include <windows.h>
#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
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;
* 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)
* 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 */
#include "HsFFI.h"
#include "sm/Storage.h"
+#include "RtsFlags.h"
#include "RtsUtils.h"
#include "Prelude.h"
#include "Schedule.h" /* initScheduler */
/* 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 */
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_<module>" 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 */
}
/* ----------------------------------------------------------------------------
#endif
endProfiling();
- freeProfiling1();
+ freeProfiling();
#ifdef PROFILING
// Originally, this was in report_ccs_profiling(). Now, retainer
/************************************************************************/
-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);
}
--------------
*/
-void stmPreGCHook(void);
+void stmPreGCHook(Capability *cap);
/*----------------------------------------------------------------------
#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
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);
#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"
#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
#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;
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)
{
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;
}
}
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
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
/* 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);
}
/* -----------------------------------------------------------------------------
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;
}
}
- 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 */
}
#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);
+ }
}
/* -----------------------------------------------------------------------------
-------------------------------------------------------------------------- */
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) {
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;
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*/);
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",
(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) {
);
}
#endif
-
- statsPrintf("\n");
+ statsPrintf("\n");
#if defined(THREADED_RTS)
{
}
#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);
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;
+ }
}
/* -----------------------------------------------------------------------------
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);
}
#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);
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
//
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().
//
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
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)
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
# -----------------------------------------------------------------------------
#include "Rts.h"
#include "RtsOpts.h"
-const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly;
+const RtsOptsEnabledEnum rtsOptsEnabled = RtsOptsSafeOnly;
// 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);
#include "Storage.h"
#include "GC.h"
#include "GCThread.h"
+#include "GCTDecl.h"
#include "GCUtils.h"
#include "Compact.h"
#include "MarkStack.h"
#include "GC.h"
#include "GCThread.h"
+#include "GCTDecl.h"
#include "Compact.h"
#include "Evac.h"
#include "Scav.h"
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)
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;
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();
// 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]);
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) {
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:
*/
// 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
#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)
// 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)
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();
pruneSparkQueue(&capabilities[n]);
}
} else {
- pruneSparkQueue(&capabilities[gct->thread_index]);
+ pruneSparkQueue(gct->cap);
}
#endif
// 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",
// 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);
+ }
}
}
#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
nat g;
gen_workspace *ws;
+ t->cap = &capabilities[n];
+
#ifdef THREADED_RTS
t->id = 0;
initSpinLock(&t->gc_spin);
loop:
- traceEventGcWork(&capabilities[gct->thread_index]);
-
#if defined(THREADED_RTS)
if (n_gc_threads > 1) {
scavenge_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);
// usleep(1);
if (any_work()) {
inc_running();
+ traceEventGcWork(gct->cap);
goto loop;
}
// any_work() does not remove the work from the queue, it
// scavenge_loop() to perform any pending work.
}
- traceEventGcDone(&capabilities[gct->thread_index]);
+ traceEventGcDone(gct->cap);
}
#if defined(THREADED_RTS)
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;
}
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();
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);
}
}
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);
// 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(); }
}
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;
#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
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);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (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
#define SM_GCTHREAD_H
#include "WSDeque.h"
+#include "GetTime.h" // for Ticks
#include "BeginPrivate.h"
------------------------------------------------------------------------- */
typedef struct gc_thread_ {
+ Capability *cap;
+
#ifdef THREADED_RTS
OSThreadId id; // The OS thread that this struct belongs to
SpinLock gc_spin;
// 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;
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
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
#include "Storage.h"
#include "GC.h"
#include "GCThread.h"
+#include "GCTDecl.h"
#include "GCUtils.h"
#include "Printer.h"
#include "Trace.h"
#include "BeginPrivate.h"
+#include "GCTDecl.h"
+
bdescr *allocBlock_sync(void);
void freeChain_sync(bdescr *bd);
#include "MarkWeak.h"
#include "GC.h"
#include "GCThread.h"
+#include "GCTDecl.h"
#include "Evac.h"
#include "Trace.h"
#include "Schedule.h"
for (i = 0; i < n_capabilities; i++) {
markBlocks(nurseries[i].blocks);
+ markBlocks(capabilities[i].pinned_object_block);
}
#ifdef PROFILING
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;
// 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;
$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
# 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
# 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
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)) \
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)) \
"$$(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
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
$(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 \
"$$($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
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
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
--- /dev/null
+# -----------------------------------------------------------------------------
+#
+# (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
+
# 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
# - 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
--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)
# .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 $$@
$(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"
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)"
--- /dev/null
+[("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@")]
+
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/<local-path>
+# otherwise sync-all works on repos of form
+# $repo_base/<remote-path>
+# 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 <local-path> and <remote-path> 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.
}
}
-sub repoexists {
- my ($scm, $localpath) = @_;
-
- if ($scm eq "darcs") {
- -d "$localpath/_darcs";
- }
- else {
- -d "$localpath/.git";
- }
-}
-
sub scmall {
my $command = shift;
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";
}
- # --<tag> 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 = <<END;
What do you want to do?
Supported commands:
* whatsnew
+ * commit
* push
* pull
* get, with options:
* --partial
* fetch
* send
- * set-origin
* new
+ * remote add <branch-name>
+ * remote rm <branch-name>
+ * remote set-url [--push] <branch-name>
+ * checkout
+ * grep
+ * clean
+ * reset
+ * config
Available package-tags are:
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;
+ }
+ # --<tag> 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
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
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'
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 \
import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
+import Panic ( panic )
import DynFlags ( defaultDynFlags )
import Bag
import Exception
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
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
projects / ghc-hetmet.git / commitdiff