diff --git a/.gitignore b/.gitignore
index bbcff222d2ee592ef547c47a9e481f4df8af1482..3e2e7f4391b75c6e3efc30d22e8c5d1d94b7e5de 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,6 +7,7 @@
*.BAK
*.orig
*.prof
+*.rej
*.hi
*.hi-boot
@@ -29,6 +30,12 @@ config.log
config.status
configure
+# -----------------------------------------------------------------------------
+# Ignore any overlapped darcs repos and back up files
+
+*-darcs-backup*
+_darcs/
+
# -----------------------------------------------------------------------------
# sub-repositories
@@ -79,9 +86,7 @@ configure
/bindist-list
/bindistprep/
/bindisttest/HelloWorld
-/bindisttest/a/
-/bindisttest/install\ dir/
-/bindisttest/output
+/bindisttest/
/ch01.html
/ch02.html
/compiler/cmm/CmmLex.hs
@@ -119,8 +124,12 @@ configure
/docs/users_guide/users_guide.xml
/docs/users_guide/users_guide/
/docs/users_guide/what_glasgow_exts_does.gen.xml
+/driver/ghc/dist/
+/driver/haddock/dist/
/driver/ghci/ghc-pkg-inplace
/driver/ghci/ghci-inplace
+/driver/ghci/dist/
+/driver/ghci/ghci.res
/driver/mangler/dist/ghc-asm
/driver/mangler/dist/ghc-asm.prl
/driver/package.conf
@@ -128,7 +137,7 @@ configure
/driver/split/dist/ghc-split
/driver/split/dist/ghc-split.prl
/driver/stamp-pkg-conf-rts
-/extra-gcc-opts
+/settings
/ghc.spec
/ghc/ghc-bin.cabal
/ghc/stage1/
@@ -150,6 +159,8 @@ configure
/libffi/package.conf.inplace
/libffi/package.conf.inplace.raw
/libffi/stamp*
+/libffi/package.conf.install
+/libffi/package.conf.install.raw
/libraries/bin-package-db/GNUmakefile
/libraries/bin-package-db/ghc.mk
/libraries/bootstrapping.conf
@@ -185,6 +196,8 @@ configure
/rts/package.conf.inplace.raw
/rts/sm/Evac_thr.c
/rts/sm/Scav_thr.c
+/rts/package.conf.install
+/rts/package.conf.install.raw
/stage3.package.conf
/testsuite_summary.txt
/testlog
@@ -218,3 +231,4 @@ configure
/utils/runghc/runhaskell
/utils/runstdtest/runstdtest
/utils/unlit/unlit
+
diff --git a/MAKEHELP b/MAKEHELP
index 85497e984f87ebc7bbd41eaaa983505b588144fa..c14767f11367de1dac4fbe015ff9202b53b2ef10 100644
--- a/MAKEHELP
+++ b/MAKEHELP
@@ -25,12 +25,6 @@ Common commands:
Shows the targets available in <dir>
- make html
- make pdf
- make ps
-
- Make documentation
-
make install
Installs GHC, libraries and tools under $(prefix)
diff --git a/Makefile b/Makefile
index 1a23e2ebbe20f1c3ba81f411836ca05df3417eed..0929f284ca20b903733b7d9eca5756caf91af4c1 100644
--- a/Makefile
+++ b/Makefile
@@ -45,7 +45,7 @@ endif
include mk/custom-settings.mk
# No need to update makefiles for these targets:
-REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS))
+REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS))
# configure touches certain files even if they haven't changed. This
# can mean a lot of unnecessary recompilation after a re-configure, so
@@ -102,12 +102,6 @@ framework-pkg:
$(MAKE) -C distrib/MacOS $@
endif
-# install-docs is a historical target that isn't supported in GHC 6.12. See #3662.
-install-docs:
- @echo "The install-docs target is not supported in GHC 6.12.1 and later."
- @echo "'make install' now installs everything, including documentation."
- @exit 1
-
# If the user says 'make A B', then we don't want to invoke two
# instances of the rule above in parallel:
.NOTPARALLEL:
diff --git a/aclocal.m4 b/aclocal.m4
index 0e72d22afb856bbce0152614198d64a90902f7d5..c7aba3e6a3c7d5b5ed6c84859591932b39fa373c 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -105,6 +105,21 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
$4="$$4 -arch x86_64"
$5="$$5 -m64"
;;
+ alpha-*)
+ # For now, to suppress the gcc warning "call-clobbered
+ # register used for global register variable", we simply
+ # disable all warnings altogether using the -w flag. Oh well.
+ $2="$$2 -w -mieee -D_REENTRANT"
+ $3="$$3 -w -mieee -D_REENTRANT"
+ $5="$$5 -w -mieee -D_REENTRANT"
+ ;;
+ hppa*)
+ # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
+ # (very nice, but too bad the HP /usr/include files don't agree.)
+ $2="$$2 -D_HPUX_SOURCE"
+ $3="$$3 -D_HPUX_SOURCE"
+ $5="$$5 -D_HPUX_SOURCE"
+ ;;
esac
# If gcc knows about the stack protector, turn it off.
@@ -181,8 +196,8 @@ AC_DEFUN([FP_EVAL_STDERR],
# --------------------
# XXX
#
-# $1 = the command to look for
-# $2 = the variable to set
+# $1 = the variable to set
+# $2 = the command to look for
#
AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG],
[
@@ -620,7 +635,7 @@ AC_SUBST([ArArgs], ["$fp_prog_ar_args"])
# FP_PROG_AR_NEEDS_RANLIB
# -----------------------
# Sets the output variable RANLIB to "ranlib" if it is needed and found,
-# to ":" otherwise.
+# to "true" otherwise.
AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],
[AC_REQUIRE([FP_PROG_AR_IS_GNU])
AC_REQUIRE([FP_PROG_AR_ARGS])
@@ -640,38 +655,12 @@ fi])
if test $fp_cv_prog_ar_needs_ranlib = yes; then
AC_PROG_RANLIB
else
- RANLIB=":"
+ RANLIB="true"
AC_SUBST([RANLIB])
fi
])# FP_PROG_AR_NEEDS_RANLIB
-# FP_PROG_AR_SUPPORTS_INPUT
-# -------------------------
-# Sets the output variable ArSupportsInput to "-input" or "", depending on
-# whether ar supports -input flag is supported or not.
-AC_DEFUN([FP_PROG_AR_SUPPORTS_INPUT],
-[AC_REQUIRE([FP_PROG_AR_IS_GNU])
-AC_REQUIRE([FP_PROG_AR_ARGS])
-AC_CACHE_CHECK([whether $fp_prog_ar_raw supports -input], [fp_cv_prog_ar_supports_input],
-[fp_cv_prog_ar_supports_input=no
-if test $fp_prog_ar_is_gnu = no; then
- rm -f conftest*
- touch conftest.lst
- if FP_EVAL_STDERR(["$fp_prog_ar_raw" $fp_prog_ar_args conftest.a -input conftest.lst]) >/dev/null; then
- test -s conftest.err || fp_cv_prog_ar_supports_input=yes
- fi
- rm -f conftest*
-fi])
-if test $fp_cv_prog_ar_supports_input = yes; then
- ArSupportsInput="-input"
-else
- ArSupportsInput=""
-fi
-AC_SUBST([ArSupportsInput])
-])# FP_PROG_AR_SUPPORTS_INPUT
-
-
dnl
dnl AC_SHEBANG_PERL - can we she-bang perl?
dnl
@@ -691,38 +680,30 @@ rm -f conftest
])])
-# FP_HAVE_GCC
+# FP_GCC_VERSION
# -----------
# Extra testing of the result AC_PROG_CC, testing the gcc version no. Sets the
-# output variables HaveGcc and GccVersion.
-AC_DEFUN([FP_HAVE_GCC],
+# output variable GccVersion.
+AC_DEFUN([FP_GCC_VERSION],
[AC_REQUIRE([AC_PROG_CC])
-if test -z "$GCC"; then
- fp_have_gcc=NO
-else
- fp_have_gcc=YES
-fi
-if test "$fp_have_gcc" = "NO" -a -d $srcdir/ghc; then
+if test -z "$GCC"
+then
AC_MSG_ERROR([gcc is required])
fi
GccLT34=
AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
-[if test "$fp_have_gcc" = "YES"; then
- fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`"
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0],
- [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])])
- # See #2770: gcc 2.95 doesn't work any more, apparently. There probably
- # isn't a very good reason for that, but for now just make configure
- # fail.
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES)
- else
- fp_cv_gcc_version="not-installed"
- fi
+[
+ fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`"
+ FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0],
+ [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])])
+ # See #2770: gcc 2.95 doesn't work any more, apparently. There probably
+ # isn't a very good reason for that, but for now just make configure
+ # fail.
+ FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES)
])
-AC_SUBST([HaveGcc], [$fp_have_gcc])
AC_SUBST([GccVersion], [$fp_cv_gcc_version])
AC_SUBST(GccLT34)
-])# FP_HAVE_GCC
+])# FP_GCC_VERSION
dnl Small feature test for perl version. Assumes PerlCmd
dnl contains path to perl binary.
@@ -1050,18 +1031,6 @@ AC_SUBST([FopCmd])
])# FP_PROG_FOP
-# FP_PROG_HSTAGS
-# ----------------
-# Sets the output variable HstagsCmd to the full Haskell tags program path.
-# HstagsCmd is empty if no such program could be found.
-AC_DEFUN([FP_PROG_HSTAGS],
-[AC_PATH_PROG([HstagsCmd], [hasktags])
-if test -z "$HstagsCmd"; then
- AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags])
-fi
-])# FP_PROG_HSTAGS
-
-
# FP_PROG_GHC_PKG
# ----------------
# Try to find a ghc-pkg matching the ghc mentioned in the environment variable
@@ -1094,7 +1063,7 @@ AC_SUBST([GhcPkgCmd])
# integer wrap around. (Trac #952)
#
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],
@@ -1116,7 +1085,7 @@ if test "$RELEASE" = "NO"; then
AC_MSG_RESULT(given $PACKAGE_VERSION)
elif test -d .git; then
changequote(, )dnl
- ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"`
+ ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -`
if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else
changequote([, ])dnl
AC_MSG_ERROR([failed to detect version date: check that git is in your path])
@@ -1528,6 +1497,21 @@ case "$1" in
esac
])
+# BOOTSTRAPPING_GHC_INFO_FIELD
+# --------------------------------
+# If the bootstrapping compiler is >= 7.1, then set the variable
+# $1 to the value of the ghc --info field $2. Otherwise, set it to
+# $3.
+AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[
+if test $GhcCanonVersion -ge 701
+then
+ $1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'`
+else
+ $1=$3
+fi
+AC_SUBST($1)
+])
+
# LIBRARY_VERSION(lib)
# --------------------------------
# Gets the version number of a library.
diff --git a/boot b/boot
index ae573816366ea3ed0252807b098f665d8ba6971e..0b67b17f0b44da64758d447c8ac3d8469f1a8972 100755
--- a/boot
+++ b/boot
@@ -3,10 +3,18 @@
use strict;
use Cwd;
+use File::Path 'rmtree';
+use File::Basename;
my %required_tag;
+my $validate;
+my $curdir;
$required_tag{"-"} = 1;
+$validate = 0;
+
+$curdir = &cwd()
+ or die "Can't find current directory: $!";
while ($#ARGV ne -1) {
my $arg = shift @ARGV;
@@ -14,59 +22,212 @@ while ($#ARGV ne -1) {
if ($arg =~ /^--required-tag=(.*)/) {
$required_tag{$1} = 1;
}
+ elsif ($arg =~ /^--validate$/) {
+ $validate = 1;
+ }
else {
die "Bad arg: $arg";
}
}
+sub sanity_check_line_endings {
+ local $/ = undef;
+ open FILE, "packages" or die "Couldn't open file: $!";
+ binmode FILE;
+ my $string = <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();
+
diff --git a/boot-pkgs b/boot-pkgs
deleted file mode 100644
index de3008cf92882db7731ae608a47877952b6c8ae5..0000000000000000000000000000000000000000
--- a/boot-pkgs
+++ /dev/null
@@ -1,114 +0,0 @@
-#!/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;
- s/\r//g;
- if (/.+/) {
- push @library_dirs, "$package/$_";
- }
- }
- }
- else {
- push @library_dirs, $package;
- }
-}
-
-for $package (@library_dirs) {
- my $dir = &basename($package);
- my @cabals = glob("$package/*.cabal");
- if ($#cabals > 0) {
- die "Too many .cabal file in $package\n";
- }
- if ($#cabals eq 0) {
- my $cabal = $cabals[0];
- my $pkg;
- my $top;
- if (-f $cabal) {
- $pkg = $cabal;
- $pkg =~ s#.*/##;
- $pkg =~ s/\.cabal$//;
- $top = $package;
- $top =~ s#[^/]+#..#g;
- $dir = $package;
- $dir =~ s#^libraries/##g;
-
- print "Creating $package/ghc.mk\n";
- open GHCMK, "> $package/ghc.mk"
- or die "Opening $package/ghc.mk failed: $!";
- print GHCMK "${package}_PACKAGE = ${pkg}\n";
- print GHCMK "${package}_dist-install_GROUP = libraries\n";
- print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n";
- close GHCMK
- or die "Closing $package/ghc.mk failed: $!";
-
- print "Creating $package/GNUmakefile\n";
- open GNUMAKEFILE, "> $package/GNUmakefile"
- or die "Opening $package/GNUmakefile failed: $!";
- print GNUMAKEFILE "dir = ${package}\n";
- print GNUMAKEFILE "TOP = ${top}\n";
- print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n";
- print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n";
- close GNUMAKEFILE
- or die "Closing $package/GNUmakefile failed: $!";
- }
- }
-}
-
diff --git a/compiler/Makefile.local b/compiler/Makefile.local
deleted file mode 100644
index 1d5345114b9afe8b984675987b888d061b2fd49b..0000000000000000000000000000000000000000
--- a/compiler/Makefile.local
+++ /dev/null
@@ -1,75 +0,0 @@
-# Local GHC-build-tree customization for Cabal makefiles. We want to build
-# libraries using flags that the user has put in build.mk/validate.mk and
-# appropriate flags for Mac OS X deployment targets.
-
-# Careful here: including boilerplate.mk breaks things, because paths.mk and
-# opts.mk overrides some of the variable settings in the Cabal Makefile, so
-# we just include config.mk and custom-settings.mk.
-TOP=..
-SAVE_GHC := $(GHC)
-SAVE_AR := $(AR)
-SAVE_LD := $(LD)
-include $(TOP)/mk/config.mk
-include $(TOP)/mk/custom-settings.mk
-GHC := $(SAVE_GHC)
-AR := $(SAVE_AR)
-LD := $(SAVE_LD)
-
-# Now add flags from the GHC build system to the Cabal build:
-GHC_CC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS))
-GHC_OPTS += $(SRC_HC_OPTS)
-GHC_OPTS += $(GhcHcOpts)
-GHC_OPTS += $(GhcStage$(stage)HcOpts)
-GHC_OPTS += $(addprefix -optc, $(MACOSX_DEPLOYMENT_CC_OPTS))
-LIB_LD_OPTS += $(addprefix -optl, $(MACOSX_DEPLOYMENT_LD_OPTS))
-
-# XXX These didn't work in the old build system, according to the
-# comment at least. We should actually handle them properly at some
-# point:
-
-# Some .hs files #include other source files, but since ghc -M doesn't spit out
-# these dependencies we have to include them manually.
-
-# We don't add dependencies on HsVersions.h, ghcautoconf.h, or ghc_boot_platform.h,
-# because then modifying one of these files would force recompilation of everything,
-# which is probably not what you want. However, it does mean you have to be
-# careful to recompile stuff you need if you reconfigure or change HsVersions.h.
-
-# Aargh, these don't work properly anyway, because GHC's recompilation checker
-# just reports "compilation NOT required". Do we have to add -fforce-recomp for each
-# of these .hs files? I haven't done anything about this yet.
-
-# $(odir)/codeGen/Bitmap.$(way_)o : ../includes/MachDeps.h
-# $(odir)/codeGen/CgCallConv.$(way_)o : ../includes/StgFun.h
-# $(odir)/codeGen/CgProf.$(way_)o : ../includes/MachDeps.h
-# $(odir)/codeGen/CgProf.$(way_)o : ../includes/Constants.h
-# $(odir)/codeGen/CgProf.$(way_)o : ../includes/DerivedConstants.h
-# $(odir)/codeGen/CgTicky.$(way_)o : ../includes/DerivedConstants.h
-# $(odir)/codeGen/ClosureInfo.$(way_)o : ../includes/MachDeps.h
-# $(odir)/codeGen/SMRep.$(way_)o : ../includes/MachDeps.h
-# $(odir)/codeGen/SMRep.$(way_)o : ../includes/ClosureTypes.h
-# $(odir)/ghci/ByteCodeAsm.$(way_)o : ../includes/Bytecodes.h
-# $(odir)/ghci/ByteCodeFFI.$(way_)o : nativeGen/NCG.h
-# $(odir)/ghci/ByteCodeInstr.$(way_)o : ../includes/MachDeps.h
-# $(odir)/ghci/ByteCodeItbls.$(way_)o : ../includes/ClosureTypes.h
-# $(odir)/ghci/ByteCodeItbls.$(way_)o : nativeGen/NCG.h
-# $(odir)/main/Constants.$(way_)o : ../includes/MachRegs.h
-# $(odir)/main/Constants.$(way_)o : ../includes/Constants.h
-# $(odir)/main/Constants.$(way_)o : ../includes/MachDeps.h
-# $(odir)/main/Constants.$(way_)o : ../includes/DerivedConstants.h
-# $(odir)/main/Constants.$(way_)o : ../includes/GHCConstants.h
-# $(odir)/nativeGen/AsmCodeGen.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/MachCodeGen.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/MachCodeGen.$(way_)o : ../includes/MachDeps.h
-# $(odir)/nativeGen/MachInstrs.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/MachRegs.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/MachRegs.$(way_)o : ../includes/MachRegs.h
-# $(odir)/nativeGen/PositionIndependentCode.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/PprMach.$(way_)o : nativeGen/NCG.h
-# $(odir)/nativeGen/RegAllocInfo.$(way_)o : nativeGen/NCG.h
-# $(odir)/typecheck/TcForeign.$(way_)o : nativeGen/NCG.h
-# $(odir)/utils/Binary.$(way_)o : ../includes/MachDeps.h
-# $(odir)/utils/FastMutInt.$(way_)o : ../includes/MachDeps.h
-# $(PRIMOP_BITS) is defined in Makefile
-# $(odir)/prelude/PrimOp.o: $(PRIMOP_BITS)
-
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index f07788203a58b6d0bc87c1d1d2ab05026c7a0068..7ea66e1db2bf722a704c66f5c26e72c1e0e2d035 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -72,13 +72,16 @@ module BasicTypes(
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
- SuccessFlag(..), succeeded, failed, successIf
+ SuccessFlag(..), succeeded, failed, successIf,
+
+ FractionalLit(..), negateFractionalLit, integralFractionalLit
) where
import FastString
import Outputable
import Data.Data hiding (Fixity)
+import Data.Function (on)
\end{code}
%************************************************************************
@@ -862,3 +865,36 @@ isEarlyActive (ActiveBefore {}) = True
isEarlyActive _ = False
\end{code}
+
+
+\begin{code}
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+ = FL { fl_text :: String -- How the value was written in the source
+ , fl_value :: Rational -- Numeric value of the literal
+ }
+ deriving (Data, Typeable, Show)
+ -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
+
+negateFractionalLit :: FractionalLit -> FractionalLit
+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+
+integralFractionalLit :: Integer -> FractionalLit
+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+ (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+ compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+ ppr = text . fl_text
+\end{code}
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 5a62326718bf8673821de53f1e23c6485cbf5843..312ae943a8ca3c9987060f2fc4f1461142abeb1e 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -18,7 +18,7 @@ module DataCon (
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
- dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+ dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
@@ -31,7 +31,7 @@ module DataCon (
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
- isVanillaDataCon, classDataCon,
+ isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
@@ -41,6 +41,7 @@ module DataCon (
#include "HsVersions.h"
import Type
+import Unify
import Coercion
import TyCon
import Class
@@ -57,7 +58,6 @@ import Module
import qualified Data.Data as Data
import Data.Char
import Data.Word
-import Data.List ( partition )
\end{code}
@@ -256,8 +256,7 @@ data DataCon
-- dcUnivTyVars = [a]
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
- -- dcEqTheta = [x~y]
- -- dcDictTheta = [Ord x]
+ -- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcRepTyCon = T
@@ -265,7 +264,7 @@ data DataCon
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no coercions, nothing.
- -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
+ -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
-- NB 1: newtypes always have a vanilla data con
-- NB 2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
@@ -300,8 +299,8 @@ data DataCon
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
- dcEqTheta :: ThetaType, -- The *equational* constraints
- dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints
+ dcOtherTheta :: ThetaType, -- The other constraints in the data con's type
+ -- other than those in the dcEqSpec
dcStupidTheta :: ThetaType, -- The context of the data type declaration
-- data Eq a => T a = ...
@@ -338,9 +337,9 @@ data DataCon
-- length = 0 (if not a record) or dataConSourceArity.
-- Constructor representation
- dcRepArgTys :: [Type], -- Final, representation argument types,
- -- after unboxing and flattening,
- -- and *including* existential dictionaries
+ dcRepArgTys :: [Type], -- Final, representation argument types,
+ -- after unboxing and flattening,
+ -- and *including* all existential evidence args
dcRepStrictness :: [StrictnessMark],
-- One for each *representation* *value* argument
@@ -519,8 +518,8 @@ mkDataCon name declared_infix
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
+ dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys,
@@ -536,10 +535,9 @@ mkDataCon name declared_infix
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
- (eq_theta,dict_theta) = partition isEqPred theta
- dict_tys = mkPredTys dict_theta
- real_arg_tys = dict_tys ++ orig_arg_tys
- real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts
+ full_theta = eqSpecPreds eq_spec ++ theta
+ real_arg_tys = mkPredTys full_theta ++ orig_arg_tys
+ real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
@@ -547,11 +545,6 @@ mkDataCon name declared_infix
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
- mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
- mkFunTys (mkPredTys eq_theta) $
- -- NB: the dict args are already in rep_arg_tys
- -- because they might be flattened..
- -- but the equality predicates are not
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
@@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
--- | The equational constraints on the data constructor type
-dataConEqTheta :: DataCon -> ThetaType
-dataConEqTheta = dcEqTheta
-
--- | The type class and implicit parameter contsraints on the data constructor type
-dataConDictTheta :: DataCon -> ThetaType
-dataConDictTheta = dcDictTheta
+-- | The *full* constraints on the constructor type
+dataConTheta :: DataCon -> ThetaType
+dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
+ = eqSpecPreds eq_spec ++ theta
-- | Get the Id of the 'DataCon' worker: a function that is the "actual"
-- constructor and has no top level binding in the program. The type may
@@ -666,10 +656,10 @@ dataConFieldType con label
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks
--- | Strictness of /existential/ arguments only
+-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
+dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc)
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
@@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc
--
-- 4) The /original/ result type of the 'DataCon'
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
-dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
+dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+ dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
- = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
+ = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
-- | The \"full signature\" of the 'DataCon' returns, in order:
--
@@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_
--
-- 6) The original result type of the 'DataCon'
dataConFullSig :: DataCon
- -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
+ -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+ dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
- = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
+ = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
@@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
+ dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
- mkFunTys (mkPredTys eq_theta) $
- mkFunTys (mkPredTys dict_theta) $
+ mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
res_ty
@@ -841,6 +830,25 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
[] -> panic "classDataCon"
\end{code}
+\begin{code}
+dataConCannotMatch :: [Type] -> DataCon -> Bool
+-- Returns True iff the data con *definitely cannot* match a
+-- scrutinee of type (T tys)
+-- where T is the type constructor for the data con
+-- NB: look at *all* equality constraints, not only those
+-- in dataConEqSpec; see Trac #5168
+dataConCannotMatch tys con
+ | null theta = False -- Common
+ | all isTyVarTy tys = False -- Also common
+ | otherwise
+ = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
+ | EqPred ty1 ty2 <- theta ]
+ where
+ dc_tvs = dataConUnivTyVars con
+ theta = dataConTheta con
+ subst = zipTopTvSubst dc_tvs tys
+\end{code}
+
%************************************************************************
%* *
\subsection{Splitting products}
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index fd65fe40090abb82fa97e2b96b070e57fed08662..5ac261255cb787d280a1bd86395b24d2622b6076 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -23,7 +23,7 @@
-- * 'Var.Var': see "Var#name_types"
module Id (
-- * The main types
- Id, DictId,
+ Var, Id, isId,
-- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
@@ -34,8 +34,7 @@ module Id (
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
- isId, idPrimRep,
- recordSelectorFieldLabel,
+ idPrimRep, recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
@@ -46,7 +45,8 @@ module Id (
-- ** Predicates on Ids
- isImplicitId, isDeadBinder, isDictId, isStrictId,
+ isImplicitId, isDeadBinder,
+ isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
@@ -57,6 +57,9 @@ module Id (
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
+ -- ** Evidence variables
+ DictId, isDictId, isEvVar, evVarPred,
+
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
@@ -95,8 +98,8 @@ import IdInfo
import BasicTypes
-- Imported and re-exported
-import Var( Var, Id, DictId,
- idInfo, idDetails, globaliseId,
+import Var( Var, Id, DictId, EvVar,
+ idInfo, idDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
@@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
-
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
-
hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.
@@ -446,6 +445,26 @@ isTickBoxOp_maybe id =
_ -> Nothing
\end{code}
+%************************************************************************
+%* *
+ Evidence variables
+%* *
+%************************************************************************
+
+\begin{code}
+isEvVar :: Var -> Bool
+isEvVar var = isPredTy (varType var)
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+evVarPred :: EvVar -> PredType
+evVarPred var
+ = case splitPredTy_maybe (varType var) of
+ Just pred -> pred
+ Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
+\end{code}
+
%************************************************************************
%* *
\subsection{IdInfo stuff}
diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index ec1f12217645e3d62d1e68020b32cd507e4f9ded..c106f5397c1684843af20aa615db478e059ecfca 100644
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
\begin{code}
module IdInfo (
-- * The IdDetails type
- IdDetails(..), pprIdDetails,
+ IdDetails(..), pprIdDetails, coVarDetails,
-- * The IdInfo type
IdInfo, -- Abstract
@@ -141,6 +141,9 @@ data IdDetails
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
+coVarDetails :: IdDetails
+coVarDetails = VanillaId
+
instance Outputable IdDetails where
ppr = pprIdDetails
diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot
index 4195156f274b73b836bca5df3bc7e9de872b11c2..257e1c6e5e051152f1500a0531377fe7a66d9dda 100644
--- a/compiler/basicTypes/IdInfo.lhs-boot
+++ b/compiler/basicTypes/IdInfo.lhs-boot
@@ -4,5 +4,7 @@ import Outputable
data IdInfo
data IdDetails
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
pprIdDetails :: IdDetails -> SDoc
\end{code}
\ No newline at end of file
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 5aebd372592d1289b664529a69aaaa8997cf30c5..c691f62676f45216a3c563d4a102a610dec196a6 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -13,7 +13,7 @@ have a standard form, namely:
\begin{code}
module MkId (
- mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
@@ -25,13 +25,18 @@ module MkId (
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
- voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
+ voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
+ coercionTokenId,
+
+ -- Re-export error Ids
+ module PrelRules
) where
#include "HsVersions.h"
import Rules
import TysPrim
+import TysWiredIn ( unitTy )
import PrelRules
import Type
import Coercion
@@ -48,7 +53,7 @@ import PrimOp
import ForeignCall
import DataCon
import Id
-import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar )
+import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
@@ -56,6 +61,7 @@ import Unique
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
+import Pair
import Outputable
import FastString
import ListSetOps
@@ -224,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
- eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
+ other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
----------- Worker (algebraic data types only) --------------
@@ -287,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- eq_tys = mkPredTys eq_theta
- dict_tys = mkPredTys dict_theta
- wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
- mkFunTys orig_arg_tys $ res_ty
- -- NB: watch out here if you allow user-written equality
- -- constraints in data constructor signatures
+ ev_tys = mkPredTys other_theta
+ wrap_ty = mkForAllTys wrap_tvs $
+ mkFunTys ev_tys $
+ mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
@@ -305,8 +309,9 @@ mkDataConIds wrap_name wkr_name data_con
`setStrictnessInfo` Just wrap_sig
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
- wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
- arg_dmds = map mk_dmd all_strict_marks
+ wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
+ wrap_stricts = dropList eq_spec all_strict_marks
+ wrap_arg_dmds = map mk_dmd wrap_stricts
mk_dmd str | isBanged str = evalDmd
| otherwise = lazyDmd
-- The Cpr info can be important inside INLINE rhss, where the
@@ -318,32 +323,26 @@ mkDataConIds wrap_name wkr_name data_con
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
+ wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
- mkLams eq_args $
- mkLams dict_args $ mkLams id_args $
+ mkLams ev_args $
+ mkLams id_args $
foldr mk_case con_app
- (zip (dict_args ++ id_args) all_strict_marks)
+ (zip (ev_args ++ id_args) wrap_stricts)
i3 []
+ -- The ev_args is the evidence arguments *other than* the eq_spec
+ -- Because we are going to apply the eq_spec args manually in the
+ -- wrapper
con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
Var wrk_id `mkTyApps` res_ty_args
`mkVarApps` ex_tvs
- -- Equality evidence:
- `mkTyApps` map snd eq_spec
- `mkVarApps` eq_args
+ `mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids
- (dict_args,i2) = mkLocals 1 dict_tys
- (id_args,i3) = mkLocals i2 orig_arg_tys
- wrap_arity = i3-1
- (eq_args,_) = mkCoVarLocals i3 eq_tys
-
- mkCoVarLocals i [] = ([],i)
- mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
- y = mkCoVar (mkSysTvName (mkBuiltinUnique i)
- (fsLit "dc_co")) x
- in (y:ys,j)
+ (ev_args,i2) = mkLocals 1 ev_tys
+ (id_args,i3) = mkLocals i2 orig_arg_tys
+ wrap_arity = i3-1
mk_case
:: (Id, HsBang) -- Arg, strictness
@@ -458,7 +457,7 @@ mkDictSelId no_unf name clas
occNameFS (getOccName name)
, ru_fn = name
, ru_nargs = n_ty_args + 1
- , ru_try = dictSelRule val_index n_ty_args n_eq_args }
+ , ru_try = dictSelRule val_index n_ty_args }
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
@@ -474,8 +473,6 @@ mkDictSelId no_unf name clas
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
- eq_theta = dataConEqTheta data_con
- n_eq_args = length eq_theta
-- 'index' is a 0-index into the *value* arguments of the dictionary
val_index = assoc "MkId.mkDictSelId" sel_index_prs name
@@ -485,25 +482,23 @@ mkDictSelId no_unf name clas
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
- eq_ids = map mkWildEvBinder eq_theta
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
- [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+ [(DataAlt data_con, arg_ids, Var the_arg_id)]
-dictSelRule :: Int -> Arity -> Arity
+dictSelRule :: Int -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
-dictSelRule val_index n_ty_args n_eq_args id_unf args
+dictSelRule val_index n_ty_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
- , let val_args = drop n_eq_args con_args
- = Just (val_args !! val_index)
+ = Just (con_args !! val_index)
| otherwise
= Nothing
\end{code}
@@ -607,7 +602,7 @@ mkProductBox arg_ids ty
mkReboxingAlt
:: [Unique] -- Uniques for the new Ids
-> DataCon
- -> [Var] -- Source-level args, including existential dicts
+ -> [Var] -- Source-level args, *including* all evidence vars
-> CoreExpr -- RHS
-> CoreAlt
@@ -628,15 +623,14 @@ mkReboxingAlt us con args rhs
-- Type variable case
go (arg:args) stricts us
- | isTyCoVar arg
+ | isTyVar arg
= let (binds, args') = go args stricts us
in (binds, arg:args')
-- Term variable case
go (arg:args) (str:stricts) us
| isMarkedUnboxed str
- =
- let (binds, unpacked_args') = go args stricts us'
+ = let (binds, unpacked_args') = go args stricts us'
(us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
in
(NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
@@ -674,13 +668,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- coercion constructor of the newtype or applied by itself).
wrapNewTypeBody tycon args result_expr
- = wrapFamInstBody tycon args inner
+ = ASSERT( isNewTyCon tycon )
+ wrapFamInstBody tycon args $
+ mkCoerce (mkSymCo co) result_expr
where
- inner
- | Just co_con <- newTyConCo_maybe tycon
- = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
- | otherwise
- = result_expr
+ co = mkAxInstCo (newTyConCo tycon) args
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker. We have to do it this way as
@@ -689,10 +681,8 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo_maybe tycon
- = mkCoerce (mkTyConApp co_con args) result_expr
- | otherwise
- = result_expr
+ = ASSERT( isNewTyCon tycon )
+ mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
@@ -702,14 +692,14 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
+ = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
| otherwise
= body
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCoerce (mkTyConApp co_con args) scrut
+ = mkCoerce (mkAxInstCo co_con args) scrut
| otherwise
= scrut
\end{code}
@@ -826,11 +816,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
that they aren't discarded by the occurrence analyser.
\begin{code}
-mkDefaultMethodId :: Id -- Selector Id
- -> Name -- Default method name
- -> Id -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> ThetaType
@@ -858,7 +843,7 @@ mkDictFunTy tvs theta clas tys
(classSCTheta clas)
-- See Note [Silent Superclass Arguments]
discard pred = isEmptyVarSet (tyVarsOfPred pred)
- || any (`tcEqPred` pred) theta
+ || any (`eqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
\end{code}
@@ -885,12 +870,13 @@ they can unify with both unlifted and lifted types. Hence we provide
another gun with which to shoot yourself in the foot.
\begin{code}
-lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
-nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
-seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
-realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
-lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
+unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
+nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
+seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
+realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
+lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
+coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
\end{code}
\begin{code}
@@ -908,7 +894,7 @@ unsafeCoerceId
(mkFunTy argAlphaTy openBetaTy)
[x] = mkTemplateLocals [argAlphaTy]
rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $
- Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy)
+ Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy)
------------------------------------------------
nullAddrId :: Id
@@ -944,7 +930,7 @@ seqId = pcMiscPrelId seqName ty info
match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
- = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
+ = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ _ = Nothing
@@ -1054,6 +1040,12 @@ realWorldPrimId -- :: State# RealWorld
voidArgId :: Id
voidArgId -- :: State# RealWorld
= mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
+
+coercionTokenId :: Id -- :: () ~ ()
+coercionTokenId -- Used to replace Coercion terms when we go to STG
+ = pcMiscPrelId coercionTokenName
+ (mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
+ noCafIdInfo
\end{code}
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index c4bdba209c1cb457062bc2b0c087e95a9f8d2a3c..89b3eddfd71b1ff73fe8d9db0cb4c2090f62c9de 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -73,7 +73,6 @@ module Module
import Config
import Outputable
-import qualified Pretty
import Unique
import UniqFM
import FastString
@@ -155,6 +154,7 @@ addBootSuffixLocn locn
\begin{code}
-- | A ModuleName is essentially a simple string, e.g. @Data.List@.
newtype ModuleName = ModuleName FastString
+ deriving Typeable
instance Uniquable ModuleName where
getUnique (ModuleName nm) = getUnique nm
@@ -175,8 +175,6 @@ instance Binary ModuleName where
put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs)
-INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName")
-
instance Data ModuleName where
-- don't traverse?
toConstr _ = abstractConstr "ModuleName"
@@ -224,7 +222,7 @@ data Module = Module {
modulePackageId :: !PackageId, -- pkg-1.0
moduleName :: !ModuleName -- A.B.C
}
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Typeable)
instance Uniquable Module where
getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n)
@@ -236,8 +234,6 @@ instance Binary Module where
put_ bh (Module p n) = put_ bh p >> put_ bh n
get bh = do p <- get bh; n <- get bh; return (Module p n)
-INSTANCE_TYPEABLE0(Module,moduleTc,"Module")
-
instance Data Module where
-- don't traverse?
toConstr _ = abstractConstr "Module"
@@ -256,9 +252,10 @@ mkModule :: PackageId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
-pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
+pprModule mod@(Module p n) =
+ pprPackagePrefix p mod <> pprModuleName n
-pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
+pprPackagePrefix :: PackageId -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
@@ -280,7 +277,7 @@ pprPackagePrefix p mod = getPprStyle doc
\begin{code}
-- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0
-newtype PackageId = PId FastString deriving( Eq )
+newtype PackageId = PId FastString deriving( Eq, Typeable )
-- here to avoid module loops with PackageConfig
instance Uniquable PackageId where
@@ -291,8 +288,6 @@ instance Uniquable PackageId where
instance Ord PackageId where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
-INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId")
-
instance Data PackageId where
-- don't traverse?
toConstr _ = abstractConstr "PackageId"
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 70cf298a4f6e2405247849ed8b683d021e67d1a9..f2ae963891b9f114302306c508e7201fdfdcd937 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -106,6 +106,7 @@ data Name = Name {
--(note later when changing Int# -> FastInt: is that still true about UNPACK?)
n_loc :: !SrcSpan -- Definition site
}
+ deriving Typeable
-- NOTE: we make the n_loc field strict to eliminate some potential
-- (and real!) space leaks, due to the fact that we don't look at
@@ -363,8 +364,6 @@ instance Uniquable Name where
instance NamedThing Name where
getName n = n
-INSTANCE_TYPEABLE0(Name,nameTc,"Name")
-
instance Data Name where
-- don't traverse?
toConstr _ = abstractConstr "Name"
diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index e2acaf7109da17b6da550f3dc3bc6967e8d5432c..bef9e928fda04721e208bb05be703a18c0398a21 100644
--- a/compiler/basicTypes/NameSet.lhs
+++ b/compiler/basicTypes/NameSet.lhs
@@ -48,7 +48,12 @@ import Data.Data
\begin{code}
type NameSet = UniqSet Name
-INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet")
+-- TODO: These Data/Typeable instances look very dubious. Surely either
+-- UniqFM should have the instances, or this should be a newtype?
+
+nameSetTc :: TyCon
+nameSetTc = mkTyCon "NameSet"
+instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] }
instance Data NameSet where
gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
@@ -176,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus
get (Just d1, _u1) d2 = d1 `unionNameSets` d2
allUses :: DefUses -> Uses
--- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
allUses dus = foldr get emptyNameSet dus
where
get (_d1, u1) u2 = u1 `unionNameSets` u2
@@ -184,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus
duUses :: DefUses -> Uses
-- ^ Collect all 'Uses', regardless of whether the group is itself used,
-- but remove 'Defs' on the way
-duUses dus
- = foldr get emptyNameSet dus
+duUses dus = foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index f02ae8d0da3f01042561c17f230021f28228ec7f..446d11a994b51db9201bf6c3d29ef2d017d2c77a 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -48,11 +48,12 @@ module OccName (
-- ** Derived 'OccName's
isDerivedOccName,
- mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
@@ -209,6 +210,7 @@ data OccName = OccName
{ occNameSpace :: !NameSpace
, occNameFS :: !FastString
}
+ deriving Typeable
\end{code}
@@ -221,8 +223,6 @@ instance Ord OccName where
compare (OccName sp1 s1) (OccName sp2 s2)
= (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2)
-INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName")
-
instance Data OccName where
-- don't traverse?
toConstr _ = abstractConstr "OccName"
@@ -540,9 +540,10 @@ isDerivedOccName occ =
\end{code}
\begin{code}
-mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
- mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
- mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
+ mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
+ mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
@@ -554,6 +555,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
+mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
@@ -572,10 +574,23 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
--- Generic derivable classes
+-- Generic derivable classes (old)
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
mkGenOcc2 = mk_simple_deriv varName "$gto"
+-- Generic deriving mechanism (new)
+mkGenD = mk_simple_deriv tcName "D1"
+
+mkGenC :: OccName -> Int -> OccName
+mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+
+mkGenS :: OccName -> Int -> Int -> OccName
+mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
+ (occNameString occ)
+
+mkGenR = mk_simple_deriv tcName "Rep_"
+mkGenRCo = mk_simple_deriv tcName "CoRep_"
+
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 5dcdabe605930c98c30558dff593cd191e932b1f..d2cbd7f07c2cb987ec17ae17d52d65e6def6c65e 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -185,8 +185,6 @@ instance Outputable SrcLoc where
ppr (UnhelpfulLoc s) = ftext s
-INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan")
-
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "SrcSpan"
@@ -237,10 +235,10 @@ data SrcSpan
-- also used to indicate an empty span
#ifdef DEBUG
- deriving (Eq, Show) -- Show is used by Lexer.x, becuase we
- -- derive Show for Token
+ deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+ -- derive Show for Token
#else
- deriving Eq
+ deriving (Eq, Typeable)
#endif
-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index ec83494bb2571988ae47f8bc5f0f6f23a76f964e..3c3ff7f44055e84f020fac1ca3d93404760f3152 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -32,7 +32,7 @@
module Var (
-- * The main data type and synonyms
- Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
+ Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
@@ -41,34 +41,25 @@ module Var (
setVarName, setVarUnique, setVarType,
-- ** Constructing, taking apart, modifying 'Id's
- mkGlobalVar, mkLocalVar, mkExportedLocalVar,
+ mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
idInfo, idDetails,
lazySetIdInfo, setIdDetails, globaliseId,
setIdExported, setIdNotExported,
-- ** Predicates
- isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
+ isId, isTyVar, isTcTyVar,
isLocalVar, isLocalId,
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
- mkTyVar, mkTcTyVar, mkWildCoVar,
+ mkTyVar, mkTcTyVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
- setTyVarName, setTyVarUnique, setTyVarKind,
-
- -- ** Constructing 'CoVar's
- mkCoVar,
-
- -- ** Taking 'CoVar's apart
- coVarName,
-
- -- ** Modifying 'CoVar's
- setCoVarUnique, setCoVarName
+ setTyVarName, setTyVarUnique, setTyVarKind
) where
@@ -77,8 +68,7 @@ module Var (
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
-import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails )
-import {-# SOURCE #-} TypeRep( isCoercionKind )
+import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
import Name hiding (varName)
import Unique
@@ -100,7 +90,7 @@ import Data.Data
-- large number of SOURCE imports of Id.hs :-(
\begin{code}
-type EvVar = Var -- An evidence variable: dictionary or equality constraint
+type EvVar = Var -- An evidence variable: dictionary or equality constraint
-- Could be an DictId or a CoVar
type Id = Var -- A term-level identifier
@@ -110,9 +100,10 @@ type DictId = EvId -- A dictionary variable
type IpId = EvId -- A term-level implicit parameter
type TyVar = Var
-type CoVar = TyVar -- A coercion variable is simply a type
+type CoVar = Id -- A coercion variable is simply an Id
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
+type TyCoVar = TyVar -- Something that is a type OR coercion variable.
\end{code}
%************************************************************************
@@ -136,8 +127,7 @@ data Var
realUnique :: FastInt, -- Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
- varType :: Kind, -- ^ The type or kind of the 'Var' in question
- isCoercionVar :: Bool
+ varType :: Kind -- ^ The type or kind of the 'Var' in question
}
| TcTyVar { -- Used only during type inference
@@ -155,6 +145,7 @@ data Var
idScope :: IdScope,
id_details :: IdDetails, -- Stable, doesn't change
id_info :: IdInfo } -- Unstable, updated by simplifier
+ deriving Typeable
data IdScope -- See Note [GlobalId/LocalId]
= GlobalId
@@ -187,9 +178,8 @@ instance Outputable Var where
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
ppr_debug :: Var -> SDoc
-ppr_debug (TyVar { isCoercionVar = False }) = ptext (sLit "tv")
-ppr_debug (TyVar { isCoercionVar = True }) = ptext (sLit "co")
-ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
+ppr_debug (TyVar {}) = ptext (sLit "tv")
+ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
ppr_id_scope :: IdScope -> SDoc
@@ -216,8 +206,6 @@ instance Ord Var where
a > b = realUnique a ># realUnique b
a `compare` b = varUnique a `compare` varUnique b
-INSTANCE_TYPEABLE0(Var,varTc,"Var")
-
instance Data Var where
-- don't traverse?
toConstr _ = abstractConstr "Var"
@@ -270,11 +258,9 @@ setTyVarKind tv k = tv {varType = k}
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
- TyVar { varName = name
+mkTyVar name kind = TyVar { varName = name
, realUnique = getKeyFastInt (nameUnique name)
, varType = kind
- , isCoercionVar = False
}
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
@@ -294,36 +280,6 @@ setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
\end{code}
-%************************************************************************
-%* *
-\subsection{Coercion variables}
-%* *
-%************************************************************************
-
-\begin{code}
-coVarName :: CoVar -> Name
-coVarName = varName
-
-setCoVarUnique :: CoVar -> Unique -> CoVar
-setCoVarUnique = setVarUnique
-
-setCoVarName :: CoVar -> Name -> CoVar
-setCoVarName = setVarName
-
-mkCoVar :: Name -> Kind -> CoVar
-mkCoVar name kind = ASSERT( isCoercionKind kind )
- TyVar { varName = name
- , realUnique = getKeyFastInt (nameUnique name)
- , varType = kind
- , isCoercionVar = True
- }
-
-mkWildCoVar :: Kind -> TyVar
--- ^ Create a type variable that is never referred to, so its unique doesn't
--- matter
-mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
-\end{code}
-
%************************************************************************
%* *
\subsection{Ids}
@@ -349,6 +305,10 @@ mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkLocalVar details name ty info
= mk_id name ty (LocalId NotExported) details info
+mkCoVar :: Name -> Type -> CoVar
+-- Coercion variables have no IdInfo
+mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo
+
-- | Exported 'Var's will not be removed as dead code
mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkExportedLocalVar details name ty info
@@ -394,20 +354,11 @@ setIdNotExported id = ASSERT( isLocalId id )
%************************************************************************
\begin{code}
-isTyCoVar :: Var -> Bool -- True of both type and coercion variables
-isTyCoVar (TyVar {}) = True
-isTyCoVar (TcTyVar {}) = True
-isTyCoVar _ = False
-
-isTyVar :: Var -> Bool -- True of both type variables only
-isTyVar v@(TyVar {}) = not (isCoercionVar v)
+isTyVar :: Var -> Bool -- True of both type variables only
+isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
isTyVar _ = False
-isCoVar :: Var -> Bool -- Only works after type checking (sigh)
-isCoVar v@(TyVar {}) = isCoercionVar v
-isCoVar _ = False
-
isTcTyVar :: Var -> Bool
isTcTyVar (TcTyVar {}) = True
isTcTyVar _ = False
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index f275714e5c478d6bc70f3b811ea72db3cb35c2a8..fca625692f47ef9365d5503524b6d4f70fc537a1 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -6,7 +6,7 @@
\begin{code}
module VarEnv (
-- * Var, Id and TyVar environments (maps)
- VarEnv, IdEnv, TyVarEnv,
+ VarEnv, IdEnv, TyVarEnv, CoVarEnv,
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv,
@@ -29,7 +29,7 @@ module VarEnv (
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, lookupInScope_Directly,
- unionInScope, elemInScopeSet, uniqAway,
+ unionInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
@@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
type VarEnv elt = UniqFM elt
type IdEnv elt = VarEnv elt
type TyVarEnv elt = VarEnv elt
+type CoVarEnv elt = VarEnv elt
emptyVarEnv :: VarEnv a
mkVarEnv :: [(Var, a)] -> VarEnv a
diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs
index 6f03aad1bf05c1ce4c051fee1688969a98d166e5..e0ff52d6904c958236a88b9d26b9d6f2e1903ea1 100644
--- a/compiler/basicTypes/VarSet.lhs
+++ b/compiler/basicTypes/VarSet.lhs
@@ -6,7 +6,7 @@
\begin{code}
module VarSet (
-- * Var, Id and TyVar set types
- VarSet, IdSet, TyVarSet,
+ VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
@@ -22,7 +22,7 @@ module VarSet (
#include "HsVersions.h"
-import Var ( Var, TyVar, Id )
+import Var ( Var, TyVar, CoVar, TyCoVar, Id )
import Unique
import UniqSet
\end{code}
@@ -37,6 +37,8 @@ import UniqSet
type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
+type TyCoVarSet = UniqSet TyCoVar
+type CoVarSet = UniqSet CoVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 9b929a42c42fab1ef11021a9f674993f2a285579..f6498436d5e0dd1591a317ff5739a4f516a16992 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -596,7 +596,7 @@ maybeAsmTemp _ = Nothing
-- | Check whether a label corresponds to a C function that has
-- a prototype in a system header somehere, or is built-in
--- to the C compiler. For these labels we abovoid generating our
+-- to the C compiler. For these labels we avoid generating our
-- own C prototypes.
isMathFun :: CLabel -> Bool
isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs
@@ -854,8 +854,8 @@ instance Outputable CLabel where
pprCLabel :: CLabel -> SDoc
-#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
+ | cGhcWithNativeCodeGen == "YES"
= getPprStyle $ \ sty ->
if asmStyle sty then
ptext asmTempLabelPrefix <> pprUnique u
@@ -863,23 +863,22 @@ pprCLabel (AsmTempLabel u)
char '_' <> pprUnique u
pprCLabel (DynamicLinkerLabel info lbl)
+ | cGhcWithNativeCodeGen == "YES"
= pprDynamicLinkerAsmLabel info lbl
pprCLabel PicBaseLabel
+ | cGhcWithNativeCodeGen == "YES"
= ptext (sLit "1b")
pprCLabel (DeadStripPreventer lbl)
+ | cGhcWithNativeCodeGen == "YES"
= pprCLabel lbl <> ptext (sLit "_dsp")
-#endif
-pprCLabel lbl =
-#if ! OMIT_NATIVE_CODEGEN
- getPprStyle $ \ sty ->
- if asmStyle sty then
- maybe_underscore (pprAsmCLbl lbl)
- else
-#endif
- pprCLbl lbl
+pprCLabel lbl
+ = getPprStyle $ \ sty ->
+ if cGhcWithNativeCodeGen == "YES" && asmStyle sty
+ then maybe_underscore (pprAsmCLbl lbl)
+ else pprCLbl lbl
maybe_underscore doc
| underscorePrefix = pp_cSEP <> doc
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 2e9f952f7b44e955b9d262d9a9cb7f97f5348aeb..a6b215b38febae7e5d24bb386a8b2a4fdfc83d1a 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -9,10 +9,11 @@
#endif
module Cmm
- ( CmmGraph(..), CmmBlock
+ ( CmmGraph, GenCmmGraph(..), CmmBlock
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
- , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+ , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+ , modifyGraph
, lastNode, replaceLastNode, insertBetween
, ofBlockMap, toBlockMap, insertBlock
, ofBlockList, toBlockList, bodyToBlockList
@@ -41,10 +42,12 @@ import Panic
-------------------------------------------------
-- CmmBlock, CmmGraph and Cmm
-data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C }
+type CmmGraph = GenCmmGraph CmmNode
+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
-type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
+type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
+type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
@@ -56,6 +59,9 @@ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph
-------------------------------------------------
-- Manipulating CmmGraphs
+modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
+
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
@@ -150,26 +156,26 @@ insertBetween b ms succId = insert $ lastNode b
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
-analFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f
-analBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f
+analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
+analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
-analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f
-analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f
+analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
+analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
-- Running forward and backward dataflow analysis + optional rewrite
-dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
(graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
-dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index b9f6db3982512b6e49359babf651464ddcb94ce6..35eabb331704e26e3a83cb8468b661105e3eeb36 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -1,6 +1,7 @@
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
@@ -66,68 +67,67 @@ mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
+-- EZY: It might be helpful to have an easy way of dumping the "pre"
+-- input for any given phase, besides just turning it all on with
+-- -ddump-cmmz
+
cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
- -- Why bother doing it this early?
- -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
- -- (dualLivenessWithInsertion callPPs) g
- -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
- -- 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
- dump Opt_D_dump_cmmz "Post common block elimination" g
+ -- Why bother doing these early: dualLivenessWithInsertion,
+ -- insertLateReloads, rewriteAssignments?
+ ----------- Eliminate common blocks -------------------
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
- dump Opt_D_dump_cmmz "Post Proc Points Added" g
+ dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
- g <-
- -- pprTrace "pre Spills" (ppr g) $
- 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) $
- 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 runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
- (removeDeadAssignmentsAndReloads procPoints) g
- -- Remove redundant reloads (and any other redundant asst)
-
- ----------- Debug only: add code to put zero in dead stack slots----
- -- Debugging: stubbing slots on death can cause crashes early
- g <- -- trace "post dead-assign elim" $
- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+ g <- run $ dualLivenessWithInsertion procPoints g
+ dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
+ ----------- Sink and inline assignments -------------------
+ g <- runOptimization $ rewriteAssignments g
+ dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+
+ ----------- Eliminate dead assignments -------------------
+ -- Remove redundant reloads (and any other redundant asst)
+ g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
+ dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
+
+ ----------- Zero dead stack slots (Debug only) ---------------
+ -- Debugging: stubbing slots on death can cause crashes early
+ g <- if opt_StubDeadValues
+ then run $ stubSlotsOnDeath g
+ else return g
+ dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- 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
- dump Opt_D_dump_cmmz "after manifestSP" g
+ g <- run $ manifestSP spEntryMap areaMap entry_off g
+ dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- run $ procPointAnalysis procPoints g
- dump Opt_D_dump_cmmz "procpoint map" procPointMap
+ dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
- mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+ mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
@@ -135,30 +135,29 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+ mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
- let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
- let gs'' = map (bundleCAFs cafEnv) gs'
- mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
- return (localCAFs, gs'')
+ gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
+ mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+ gs <- return $ map (bundleCAFs cafEnv) gs
+ mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+ return (localCAFs, gs)
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)
+ dump f txt g = do
+ -- ToDo: No easy way of say "dump all the cmmz, *and* split
+ -- them into files." Also, -ddump-cmmz doesn't play nicely
+ -- with -ddump-to-file, since the headers get omitted.
+ dumpIfSet_dyn dflags f txt (ppr g)
+ when (not (dopt f dflags)) $
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr 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 <- r $ pass g
- dump flag ("Post " ++ txt) $ g
- return g
-
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 55a5b73ac50f235942fe81896725573509312ed2..869bc1b4acc76b8bd3f856e756d2506a1c04e3bc 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -4,7 +4,7 @@ module CmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
- , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
+ , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
@@ -425,7 +425,8 @@ instance Ord GlobalReg where
compare _ EagerBlackholeInfo = GT
-- convenient aliases
-spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg = CmmGlobal BaseReg
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
spLimReg = CmmGlobal SpLim
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 95b1eef6a3df934c3affb28d203c2642ab67e78e..32fead337ea8319048049d0a37f5159391dc3655 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -24,7 +24,6 @@ import OldPprCmm()
import Constants
import FastString
-import Control.Monad
import Data.Maybe
-- -----------------------------------------------------------------------------
@@ -70,8 +69,10 @@ lintCmmBlock labels (BasicBlock id stmts)
lintCmmExpr :: CmmExpr -> CmmLint CmmType
lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr
- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
- cmmCheckWordAddress expr
+ -- Disabled, if we have the inlining phase before the lint phase,
+ -- we can have funny offsets due to pointer tagging. -- EZY
+ -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
+ -- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
tys <- mapM lintCmmExpr args
@@ -99,14 +100,14 @@ isOffsetOp _ = False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
-cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
-cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset e
-cmmCheckWordAddress _
+_cmmCheckWordAddress _
= return ()
-- No warnings for unaligned arithmetic with the node register,
@@ -152,6 +153,7 @@ lintTarget (CmmPrim {}) = return ()
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index e67321c0b0fd462349ddddf282012ea28b248009..7d50d9ae722df58359dc959325cfad30c2abf5fe 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -10,7 +10,7 @@
module CmmNode
( CmmNode(..)
, UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , mapExp, mapExpDeep, foldExp, foldExpDeep
+ , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
)
where
@@ -30,31 +30,54 @@ import Prelude hiding (succ)
data CmmNode e x where
CmmEntry :: Label -> CmmNode C O
+
CmmComment :: FastString -> CmmNode O O
+
CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
+
CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
+
CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
+ -- Like a "fat machine instruction"; can occur
+ -- in the middle of a block
ForeignTarget -> -- call target
CmmFormals -> -- zero or more results
CmmActuals -> -- zero or more arguments
CmmNode O O
+ -- Semantics: kills only result regs; all other regs (both GlobalReg
+ -- and LocalReg) are preserved. But there is a current
+ -- bug for what can be put in arguments, see
+ -- Note [Register Parameter Passing]
+
CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
+
CmmCondBranch :: { -- conditional branch
cml_pred :: CmmExpr,
cml_true, cml_false :: Label
} -> CmmNode O C
+
CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
- CmmCall :: { -- A call (native or safe foreign)
+
+ CmmCall :: { -- A native call or tail call
cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
cml_cont :: Maybe Label,
-- Label of continuation (Nothing for return or tail call)
+-- ToDO: add this:
+-- cml_args_regs :: [GlobalReg],
+-- It says which GlobalRegs are live for the parameters at the
+-- moment of the call. Later stages can use this to give liveness
+-- everywhere, which in turn guides register allocation.
+-- It is the companion of cml_args; cml_args says which stack words
+-- hold parameters, while cml_arg_regs says which global regs hold parameters.
+-- But do note [Register parameter passing]
+
cml_args :: ByteOff,
-- Byte offset, from the *old* end of the Area associated with
-- the Label (if cml_cont = Nothing, then Old area), of
@@ -78,10 +101,12 @@ data CmmNode e x where
-- cml_ret_off are treated as live, even if the sequel of
-- the call goes into a loop.
} -> CmmNode O C
+
CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
+ -- Always the last node of a block
tgt :: ForeignTarget, -- call target and convention
res :: CmmFormals, -- zero or more results
- args :: CmmActuals, -- zero or more arguments
+ args :: CmmActuals, -- zero or more arguments; see Note [Register parameter passing]
succ :: Label, -- Label of continuation
updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
intrbl:: Bool -- whether or not the call is interruptible
@@ -89,11 +114,13 @@ data CmmNode e x where
{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
-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.)
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction". In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.) However, see [Register parameter passing].
Safe ones are trickier. A safe foreign call
r = f(x)
@@ -116,6 +143,21 @@ constructors do *not* (currently) know the foreign call conventions.
Note that a safe foreign call needs an info table.
-}
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention. For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing. These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call. This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments. This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently. We should fix this!
+-}
+
---------------------------------------------
-- Eq instance of CmmNode
-- It is a shame GHC cannot infer it by itself :(
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index c71f188ba75513ad525d04654b9c8ae886aaf1b6..a2eecd5c4877247a32009b4c292db232cbcde2ac 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
module CmmOpt (
+ cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
@@ -30,10 +31,69 @@ import UniqFM
import Unique
import FastTypes
import Outputable
+import BlockId
import Data.Bits
import Data.Word
import Data.Int
+import Data.Maybe
+import Data.List
+
+import Compiler.Hoopl hiding (Unique)
+
+-- -----------------------------------------------------------------------------
+-- Eliminates dead blocks
+
+{-
+We repeatedly expand the set of reachable blocks until we hit a
+fixpoint, and then prune any blocks that were not in this set. This is
+actually a required optimization, as dead blocks can cause problems
+for invariants in the linear register allocator (and possibly other
+places.)
+-}
+
+-- Deep fold over statements could probably be abstracted out, but it
+-- might not be worth the effort since OldCmm is moribund
+cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmEliminateDeadBlocks [] = []
+cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
+ let -- Calculate what's reachable from what block
+ reachableMap = foldl' f emptyUFM blocks -- lazy in values
+ where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+ reachableFrom stmts = foldl stmt [] stmts
+ where
+ stmt m CmmNop = m
+ stmt m (CmmComment _) = m
+ stmt m (CmmAssign _ e) = expr m e
+ stmt m (CmmStore e1 e2) = expr (expr m e1) e2
+ stmt m (CmmCall c _ as _ _) = f (actuals m as) c
+ where f m (CmmCallee e _) = expr m e
+ f m (CmmPrim _) = m
+ stmt m (CmmBranch b) = b:m
+ stmt m (CmmCondBranch e b) = b:(expr m e)
+ stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
+ stmt m (CmmJump e as) = expr (actuals m as) e
+ stmt m (CmmReturn as) = actuals m as
+ actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+ -- We have to do a deep fold into CmmExpr because
+ -- there may be a BlockId in the CmmBlock literal.
+ expr m (CmmLit l) = lit m l
+ expr m (CmmLoad e _) = expr m e
+ expr m (CmmReg _) = m
+ expr m (CmmMachOp _ es) = foldl' expr m es
+ expr m (CmmStackSlot _ _) = m
+ expr m (CmmRegOff _ _) = m
+ lit m (CmmBlock b) = b:m
+ lit m _ = m
+ -- go todo done
+ reachable = go [base_id] (setEmpty :: BlockSet)
+ where go [] m = m
+ go (x:xs) m
+ | setMember x m = go xs m
+ | otherwise = go (add ++ xs) (setInsert x m)
+ where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+ (lookupUFM reachableMap x)
+ in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 8c2498e5f8a9343af9102da7ca8ed955c3a28a8c..0ee429d9c16ac27898b7749c264f39e07604e951 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -396,13 +396,15 @@ stmt :: { ExtCode }
| NAME '(' exprs0 ')' ';'
{% stmtMacro $1 $3 }
| 'switch' maybe_range expr '{' arms default '}'
- { doSwitch $2 $3 $5 $6 }
+ { do as <- sequence $5; doSwitch $2 $3 as $6 }
| 'goto' NAME ';'
{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr maybe_actuals ';'
{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
| 'return' maybe_actuals ';'
{ do e <- sequence $2; stmtEC (CmmReturn e) }
+ | 'if' bool_expr 'goto' NAME
+ { do l <- lookupLabel $4; cmmRawIf $2 l }
| 'if' bool_expr '{' body '}' else
{ cmmIfThenElse $2 $4 $6 }
@@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) }
: '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
| {- empty -} { Nothing }
-arms :: { [([Int],ExtCode)] }
+arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
: {- empty -} { [] }
| arm arms { $1 : $2 }
-arm :: { ([Int],ExtCode) }
- : 'case' ints ':' '{' body '}' { ($2, $5) }
+arm :: { ExtFCode ([Int],Either BlockId ExtCode) }
+ : 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
+
+arm_body :: { ExtFCode (Either BlockId ExtCode) }
+ : '{' body '}' { return (Right $2) }
+ | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
@@ -458,6 +464,8 @@ default :: { Maybe ExtCode }
-- 'default' branches
| {- empty -} { Nothing }
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
else :: { ExtCode }
: {- empty -} { nopEC }
| 'else' '{' body '}' { $3 }
@@ -681,15 +689,7 @@ machOps = listToUFM $
( "gtu", MO_U_Gt ),
( "ltu", MO_U_Lt ),
- ( "flt", MO_S_Lt ),
- ( "fle", MO_S_Le ),
- ( "feq", MO_Eq ),
- ( "fne", MO_Ne ),
- ( "fgt", MO_S_Gt ),
- ( "fge", MO_S_Ge ),
- ( "fneg", MO_S_Neg ),
-
- ( "and", MO_And ),
+ ( "and", MO_And ),
( "or", MO_Or ),
( "xor", MO_Xor ),
( "com", MO_Not ),
@@ -697,7 +697,20 @@ machOps = listToUFM $
( "shrl", MO_U_Shr ),
( "shra", MO_S_Shr ),
- ( "lobits8", flip MO_UU_Conv W8 ),
+ ( "fadd", MO_F_Add ),
+ ( "fsub", MO_F_Sub ),
+ ( "fneg", MO_F_Neg ),
+ ( "fmul", MO_F_Mul ),
+ ( "fquot", MO_F_Quot ),
+
+ ( "feq", MO_F_Eq ),
+ ( "fne", MO_F_Ne ),
+ ( "fge", MO_F_Ge ),
+ ( "fle", MO_F_Le ),
+ ( "fgt", MO_F_Gt ),
+ ( "flt", MO_F_Lt ),
+
+ ( "lobits8", flip MO_UU_Conv W8 ),
( "lobits16", flip MO_UU_Conv W16 ),
( "lobits32", flip MO_UU_Conv W32 ),
( "lobits64", flip MO_UU_Conv W64 ),
@@ -952,6 +965,10 @@ cmmIfThenElse cond then_part else_part = do
-- fall through to join
code (labelC join_id)
+cmmRawIf cond then_id = do
+ c <- cond
+ emitCond c then_id
+
-- 'emitCond cond true_id' emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
@@ -991,7 +1008,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.
-doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
-> Maybe ExtCode -> ExtCode
doSwitch mb_range scrut arms deflt
= do
@@ -1018,12 +1035,12 @@ doSwitch mb_range scrut arms deflt
-- ToDo: check for out of range and jump to default if necessary
stmtEC (CmmSwitch expr entries)
where
- emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
- emitArm (ints,code) = do
+ emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
+ emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+ emitArm (ints,Right code) = do
blockid <- forkLabelledCodeEC code
return [ (i,blockid) | i <- ints ]
-
-- -----------------------------------------------------------------------------
-- Putting it all together
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index d0d54d909d1025ffa673fe2d672f802565c12f43..fbe979b9abe6472b9eebdefccbdc3ba6e9b26a58 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -378,6 +378,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
-- 4. build info tables for the procedures -- and update the info table for
-- the SRTs in the entry procedure as well.
-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmTop -> FuelUniqSM [CmmTop]
splitAtProcPoints entry_label callPPs procPoints procMap
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 17364ad05204d1a7fe8b27d76d0aa95a0648cea2..2dcfb027a39861679b9e5594872bf061bf29ac86 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE GADTs,NoMonoLocalBinds #-}
+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 701
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
@@ -14,9 +15,7 @@ module CmmSpillReload
--, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , availRegsLattice
- , cmmAvailableReloads
- , insertLateReloads
+ , rewriteAssignments
, removeDeadAssignmentsAndReloads
)
where
@@ -26,13 +25,16 @@ import Cmm
import CmmExpr
import CmmLive
import OptimizationFuel
+import StgCmmUtils
import Control.Monad
import Outputable hiding (empty)
import qualified Outputable as PP
import UniqSet
+import UniqFM
+import Unique
-import Compiler.Hoopl
+import Compiler.Hoopl hiding (Unique)
import Data.Maybe
import Prelude hiding (succ, zip)
@@ -172,11 +174,6 @@ insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
text "after"{-, ppr m-}]) $
Just $ mkMiddles $ [m, spill reg]
else Nothing
- middle m@(CmmUnsafeForeignCall _ fs _) live = return $
- case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
- map reload (uniqSetToList (kill fs (in_regs live))) of
- [] -> Nothing
- reloads -> Just $ mkMiddles (m : reloads)
middle _ _ = return Nothing
nothing _ _ = return Nothing
@@ -188,91 +185,6 @@ spill, reload :: LocalReg -> CmmNode O O
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction. Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use. Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
- | AvailRegs RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add
- where empty = UniverseMinus emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add _ (OldFact old) (NewFact new) =
- if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
- where join = interAvail new old
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
-interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs _) (UniverseMinus _) = True
-smallerAvail (UniverseMinus _) (AvailRegs _) = False
-smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
-extendAvail :: AvailRegs -> LocalReg -> AvailRegs
-extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
-extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
-
-delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs s) r = elemRegSet r s
-
-cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
-cmmAvailableReloads g =
- liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analFwd availRegsLattice availReloadsTransfer
-
-availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
-availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-
-middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
-middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
- | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
- | l `isStackSlotOf` r = avail
-middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (CmmStore {}) avail = avail
-middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
-middleAvail (CmmComment {}) avail = avail
-
-lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
-lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = map (\id -> (id, avail)) $ successors l
-
-insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
-insertLateReloads g =
- liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analRewFwd availRegsLattice availReloadsTransfer rewrites
- where rewrites = mkFRewrite3 first middle last
- first _ _ = return Nothing
- middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
- last l avail = return $ maybe_reload_before avail l (mkLast l)
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ reloadTail used tail
- reloadTail regset t = foldl rel t $ uniqSetToList regset
- where rel t r = mkMiddle (reload r) <*> t
-
removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignmentsAndReloads procPoints g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
@@ -283,10 +195,464 @@ removeDeadAssignmentsAndReloads procPoints g =
-- but GHC panics while compiling, see bug #4045.
middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+ -- XXX maybe this should be somewhere else...
+ middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
+ middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
middle _ _ = return Nothing
nothing _ _ = return Nothing
+----------------------------------------------------------------
+--- Usage information
+
+-- We decorate all register assignments with usage information,
+-- that is, the maximum number of times the register is referenced
+-- while it is live along all outgoing control paths. There are a few
+-- subtleties here:
+--
+-- - If a register goes dead, and then becomes live again, the usages
+-- of the disjoint live range don't count towards the original range.
+--
+-- a = 1; // used once
+-- b = a;
+-- a = 2; // used once
+-- c = a;
+--
+-- - A register may be used multiple times, but these all reside in
+-- different control paths, such that any given execution only uses
+-- it once. In that case, the usage count may still be 1.
+--
+-- a = 1; // used once
+-- if (b) {
+-- c = a + 3;
+-- } else {
+-- c = a + 1;
+-- }
+--
+-- This policy corresponds to an inlining strategy that does not
+-- duplicate computation but may increase binary size.
+--
+-- - If we naively implement a usage count, we have a counting to
+-- infinity problem across joins. Furthermore, knowing that
+-- something is used 2 or more times in one runtime execution isn't
+-- particularly useful for optimizations (inlining may be beneficial,
+-- but there's no way of knowing that without register pressure
+-- information.)
+--
+-- while (...) {
+-- // first iteration, b used once
+-- // second iteration, b used twice
+-- // third iteration ...
+-- a = b;
+-- }
+-- // b used zero times
+--
+-- There is an orthogonal question, which is that for every runtime
+-- execution, the register may be used only once, but if we inline it
+-- in every conditional path, the binary size might increase a lot.
+-- But tracking this information would be tricky, because it violates
+-- the finite lattice restriction Hoopl requires for termination;
+-- we'd thus need to supply an alternate proof, which is probably
+-- something we should defer until we actually have an optimization
+-- that would take advantage of this. (This might also interact
+-- strangely with liveness information.)
+--
+-- a = ...;
+-- // a is used one time, but in X different paths
+-- case (b) of
+-- 1 -> ... a ...
+-- 2 -> ... a ...
+-- 3 -> ... a ...
+-- ...
+--
+-- This analysis is very similar to liveness analysis; we just keep a
+-- little extra info. (Maybe we should move it to CmmLive, and subsume
+-- the old liveness analysis.)
+
+data RegUsage = SingleUse | ManyUse
+ deriving (Ord, Eq, Show)
+-- Absence in map = ZeroUse
+
+{-
+-- minBound is bottom, maxBound is top, least-upper-bound is max
+-- ToDo: Put this in Hoopl. Note that this isn't as useful as I
+-- originally hoped, because you usually want to leave out the bottom
+-- element when you have things like this put in maps. Maybe f is
+-- useful on its own as a combining function.
+boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
+boundedOrdLattice n = DataflowLattice n minBound f
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+-}
+
+-- Custom node type we'll rewrite to. CmmAssign nodes to local
+-- registers are replaced with AssignLocal nodes.
+data WithRegUsage n e x where
+ Plain :: n e x -> WithRegUsage n e x
+ AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
+
+instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
+ foldRegsUsed f z (Plain n) = foldRegsUsed f z n
+ foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
+ foldRegsDefd f z (Plain n) = foldRegsDefd f z n
+ foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
+
+instance NonLocal n => NonLocal (WithRegUsage n) where
+ entryLabel (Plain n) = entryLabel n
+ successors (Plain n) = successors n
+
+liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
+liftRegUsage = mapGraph Plain
+
+eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
+eraseRegUsage = mapGraph f
+ where f :: WithRegUsage CmmNode e x -> CmmNode e x
+ f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
+ f (Plain n) = n
+
+type UsageMap = UniqFM RegUsage
+
+usageLattice :: DataflowLattice UsageMap
+usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+
+-- We reuse the names 'gen' and 'kill', although we're doing something
+-- slightly different from the Dragon Book
+usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
+usageTransfer = mkBTransfer3 first middle last
+ where first _ f = f
+ middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
+ middle n f = gen_kill n f
+ last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
+ -- Checking for CmmCall/CmmForeignCall is unnecessary, because
+ -- spills/reloads have already occurred by the time we do this
+ -- analysis.
+ -- XXX Deprecated warning is puzzling: what label are we
+ -- supposed to use?
+ -- ToDo: With a bit more cleverness here, we can avoid
+ -- disappointment and heartbreak associated with the inability
+ -- to inline into CmmCall and CmmForeignCall by
+ -- over-estimating the usage to be ManyUse.
+ last n f = gen_kill n (joinOutFacts usageLattice n f)
+ gen_kill a = gen a . kill a
+ gen a f = foldRegsUsed increaseUsage f a
+ kill a f = foldRegsDefd delFromUFM f a
+ increaseUsage f r = addToUFM_C combine f r SingleUse
+ where combine _ _ = ManyUse
+
+usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
+usageRewrite = mkBRewrite3 first middle last
+ where first _ _ = return Nothing
+ middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
+ middle (Plain (CmmAssign (CmmLocal l) e)) f
+ = return . Just
+ $ case lookupUFM f l of
+ Nothing -> emptyGraph
+ Just usage -> mkMiddle (AssignLocal l e usage)
+ middle _ _ = return Nothing
+ last _ _ = return Nothing
+
+type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
+annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
+annotateUsage vanilla_g =
+ let g = modifyGraph liftRegUsage vanilla_g
+ in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
+ analRewBwd usageLattice usageTransfer usageRewrite
+
+----------------------------------------------------------------
+--- Assignment tracking
+
+-- The idea is to maintain a map of local registers do expressions,
+-- such that the value of that register is the same as the value of that
+-- expression at any given time. We can then do several things,
+-- as described by Assignment.
+
+-- Assignment describes the various optimizations that are valid
+-- at a given point in the program.
+data Assignment =
+-- This assignment can always be inlined. It is cheap or single-use.
+ AlwaysInline CmmExpr
+-- This assignment should be sunk down to its first use. (This will
+-- increase code size if the register is used in multiple control flow
+-- paths, but won't increase execution time, and the reduction of
+-- register pressure is worth it.)
+ | AlwaysSink CmmExpr
+-- We cannot safely optimize occurrences of this local register. (This
+-- corresponds to top in the lattice structure.)
+ | NeverOptimize
+
+-- Extract the expression that is being assigned to
+xassign :: Assignment -> Maybe CmmExpr
+xassign (AlwaysInline e) = Just e
+xassign (AlwaysSink e) = Just e
+xassign NeverOptimize = Nothing
+
+-- Extracts the expression, but only if they're the same constructor
+xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
+xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
+xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e')
+xassign2 _ = Nothing
+
+-- Note: We'd like to make decisions about "not optimizing" as soon as
+-- possible, because this will make running the transfer function more
+-- efficient.
+type AssignmentMap = UniqFM Assignment
+
+assignmentLattice :: DataflowLattice AssignmentMap
+assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
+ where add _ (OldFact old) (NewFact new)
+ = case (old, new) of
+ (NeverOptimize, _) -> (NoChange, NeverOptimize)
+ (_, NeverOptimize) -> (SomeChange, NeverOptimize)
+ (xassign2 -> Just (e, e'))
+ | e == e' -> (NoChange, old)
+ | otherwise -> (SomeChange, NeverOptimize)
+ _ -> (SomeChange, NeverOptimize)
+
+-- Deletes sinks from assignment map, because /this/ is the place
+-- where it will be sunk to.
+deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
+deleteSinks n m = foldRegsUsed (adjustUFM f) m n
+ where f (AlwaysSink _) = NeverOptimize
+ f old = old
+
+-- Invalidates any expressions that use a register.
+invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
+-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- This requires the entire spine of the map to be continually rebuilt,
+ - which causes crazy memory usage!
+invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
+ where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
+ invalidateUsers' _ old = old
+-}
+
+-- Note [foldUFM performance]
+-- These calls to fold UFM no longer leak memory, but they do cause
+-- pretty killer amounts of allocation. So they'll be something to
+-- optimize; we need an algorithmic change to prevent us from having to
+-- traverse the /entire/ map continually.
+
+middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
+
+-- Algorithm for annotated assignments:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Add the assignment to our list of valid local assignments with
+-- the correct optimization policy.
+-- 3. Look for all assignments that reference that register and
+-- invalidate them.
+middleAssignment n@(AssignLocal r e usage) assign
+ = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
+ where add m = addToUFM m r
+ $ case usage of
+ SingleUse -> AlwaysInline e
+ ManyUse -> decide e
+ decide CmmLit{} = AlwaysInline e
+ decide CmmReg{} = AlwaysInline e
+ decide CmmLoad{} = AlwaysSink e
+ decide CmmStackSlot{} = AlwaysSink e
+ decide CmmMachOp{} = AlwaysSink e
+ -- We'll always inline simple operations on the global
+ -- registers, to reduce register pressure: Sp - 4 or Hp - 8
+ -- EZY: Justify this optimization more carefully.
+ decide CmmRegOff{} = AlwaysInline e
+
+-- Algorithm for unannotated assignments of global registers:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that reference this register and
+-- invalidate them.
+middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+ = invalidateUsersOf reg . deleteSinks n $ assign
+
+-- Algorithm for unannotated assignments of *local* registers: do
+-- nothing (it's a reload, so no state should have changed)
+middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
+
+-- Algorithm for stores:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that load from memory locations that
+-- were clobbered by this store and invalidate them.
+middleAssignment (Plain n@(CmmStore lhs rhs)) assign
+ = let m = deleteSinks n assign
+ in foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- Also leaky
+ = mapUFM_Directly p . deleteSinks n $ assign
+ -- ToDo: There's a missed opportunity here: even if a memory
+ -- access we're attempting to sink gets clobbered at some
+ -- location, it's still /better/ to sink it to right before the
+ -- point where it gets clobbered. How might we do this?
+ -- Unfortunately, it's too late to change the assignment...
+ where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
+ p _ old = old
+-}
+
+-- Assumption: Unsafe foreign calls don't clobber memory
+-- Since foreign calls clobber caller saved registers, we need
+-- invalidate any assignments that reference those global registers.
+-- This is kind of expensive. (One way to optimize this might be to
+-- store extra information about expressions that allow this and other
+-- checks to be done cheaply.)
+middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
+ = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+ where deleteCallerSaves m = foldUFM_Directly f m m
+ f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+ g (CmmReg (CmmGlobal r)) _ | callerSaves r = True
+ g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+ g _ b = b
+
+middleAssignment (Plain (CmmComment {})) assign
+ = assign
+
+-- Assumptions:
+-- * Writes using Hp do not overlap with any other memory locations
+-- (An important invariant being relied on here is that we only ever
+-- use Hp to allocate values on the heap, which appears to be the
+-- case given hpReg usage, and that our heap writing code doesn't
+-- do anything stupid like overlapping writes.)
+-- * Stack slots do not overlap with any other memory locations
+-- * Stack slots for different areas do not overlap
+-- * Stack slots within the same area and different offsets may
+-- overlap; we need to do a size check (see 'overlaps').
+-- * Register slots only overlap with themselves. (But this shouldn't
+-- happen in practice, because we'll fail to inline a reload across
+-- the next spill.)
+-- * Non stack-slot stores always conflict with each other. (This is
+-- not always the case; we could probably do something special for Hp)
+clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+ -> (Unique, CmmExpr) -- (register, expression) that may be clobbered
+ -> Bool
+clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+-- ToDo: Also catch MachOp case
+clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
+ | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
+clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
+ = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
+ f (CmmLoad e _) = containsStackSlot e
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+ -- Maybe there's an invariant broken if this actually ever
+ -- returns True
+ containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off
+ containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
+ containsStackSlot (CmmStackSlot{}) = True
+ containsStackSlot _ = False
+clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
+ f _ = False
+clobbers _ (_, e) = f e
+ where f (CmmLoad (CmmStackSlot _ _) _) = False
+ f (CmmLoad{}) = True -- conservative
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+
+-- Check for memory overlapping.
+-- Diagram:
+-- 4 8 12
+-- s -w- o
+-- [ I32 ]
+-- [ F64 ]
+-- s' -w'- o'
+type CallSubArea = (AreaId, Int, Int) -- area, offset, width
+overlaps :: CallSubArea -> CallSubArea -> Bool
+overlaps (a, _, _) (a', _, _) | a /= a' = False
+overlaps (_, o, w) (_, o', w') =
+ let s = o - w
+ s' = o' - w'
+ in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK
+
+lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
+-- Variables are dead across calls, so invalidating all mappings is justified
+lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
+
+assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
+assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
+
+assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
+assignmentRewrite = mkFRewrite3 first middle last
+ where
+ first _ _ = return Nothing
+ middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
+ middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
+ middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
+ last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
+ -- Tuple is (inline?, reloads)
+ precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
+ where f (i, l) r = case lookupUFM assign r of
+ Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
+ Just (AlwaysInline _) -> (True, l)
+ Just NeverOptimize -> (i, l)
+ -- This case can show up when we have
+ -- limited optimization fuel.
+ Nothing -> (i, l)
+ rewrite _ (False, []) _ _ = Nothing
+ -- Note [CmmCall Inline Hack]
+ -- Conservative hack: don't do any inlining on what will
+ -- be translated into an OldCmm CmmCalls, since the code
+ -- produced here tends to be unproblematic and I need to write
+ -- lint passes to ensure that we don't put anything in the
+ -- arguments that could be construed as a global register by
+ -- some later translation pass. (For example, slots will turn
+ -- into dereferences of Sp). See [Register parameter passing].
+ -- ToDo: Fix this up to only bug out if all inlines were for
+ -- CmmExprs with global registers (we can't use the
+ -- straightforward mapExpDeep call, in this case.) ToDo: We miss
+ -- an opportunity here, where all possible inlinings should
+ -- instead be sunk.
+ rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
+ rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
+
+ rewriteLocal _ (False, []) _ _ _ _ = Nothing
+ rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
+ where n' = AssignLocal l e' u
+ e' = if i then wrapRecExp (inlineExp assign) e else e
+ -- inlinable check omitted, since we can always inline into
+ -- assignments.
+
+ inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
+ inline False _ n = n
+ inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
+ inline True assign n = mapExpDeep (inlineExp assign) n
+
+ inlineExp assign old@(CmmReg (CmmLocal r))
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) -> x
+ _ -> old
+ inlineExp assign old@(CmmRegOff (CmmLocal r) i)
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) ->
+ case x of
+ (CmmRegOff r' i') -> CmmRegOff r' (i + i')
+ _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ where rep = typeWidth (localRegType r)
+ _ -> old
+ inlineExp _ old = old
+
+ inlinable :: CmmNode e x -> Bool
+ inlinable (CmmCall{}) = False
+ inlinable (CmmForeignCall{}) = False
+ inlinable (CmmUnsafeForeignCall{}) = False
+ inlinable _ = True
+
+rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
+rewriteAssignments g = do
+ g' <- annotateUsage g
+ g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
+ analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
+ return (modifyGraph eraseRegUsage g'')
---------------------
-- prettyprinting
@@ -305,11 +671,7 @@ instance Outputable DualLive where
if isEmptyUniqSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
-instance Outputable AvailRegs where
- ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
- else ppr_regs "available = all but" s
- ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
- else ppr_regs "available = " s
+-- ToDo: Outputable instance for UsageMap and AssignmentMap
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 01543c444e3f170f72edb8c7d5bc47a247353c02..c0fb6af037f716cb3fbba34261a512eb2a810193 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -13,7 +13,7 @@
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
- , layout, manifestSP, igraph, areaBuilder
+ , getSpEntryMap, layout, manifestSP, igraph, areaBuilder
, stubSlotsOnDeath ) -- to help crash early during debugging
where
@@ -195,7 +195,7 @@ liveLastOut env l =
type Set x = Map x ()
data IGraphBuilder n =
Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z
- , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
+ , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int]
}
areaBuilder :: IGraphBuilder Area
@@ -242,10 +242,13 @@ igraph builder env g = foldr interfere Map.empty (postorderDfs g)
-- what's the highest offset (in bytes) used in each Area?
-- We'll need to allocate that much space for each Area.
+-- Mapping of areas to area sizes (not offsets!)
+type AreaSizeMap = AreaMap
+
-- JD: WHY CAN'T THIS COME FROM THE slot-liveness info?
-getAreaSize :: ByteOff -> CmmGraph -> AreaMap
+getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap
-- The domain of the returned mapping consists only of Areas
- -- used for (a) variable spill slots, and (b) parameter passing ares for calls
+ -- used for (a) variable spill slots, and (b) parameter passing areas for calls
getAreaSize entry_off g =
foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last))
(Map.singleton (CallArea Old) entry_off) g
@@ -266,10 +269,11 @@ getAreaSize entry_off g =
-- The 'max' is important. Two calls, to f and g, might share a common
-- continuation (and hence a common CallArea), but their number of overflow
-- parameters might differ.
+ -- EZY: Ought to use insert with combining function...
-- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
+conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int
conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
foldNodes subarea foldNode Map.empty
where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
@@ -278,10 +282,10 @@ conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
setAdd w s = Map.insert w () s
--- Find any open space on the stack, starting from the offset.
--- If the area is a CallArea or a spill slot for a pointer, then it must
--- be word-aligned.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
+-- Find any open space for 'area' on the stack, starting from the
+-- 'offset'. If the area is a CallArea or a spill slot for a pointer,
+-- then it must be word-aligned.
+freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int
freeSlotFrom ig areaSize offset areaMap area =
let size = Map.lookup area areaSize `orElse` 0
conflicts = conflictSlots ig areaSize areaMap (area, size, size)
@@ -299,11 +303,24 @@ freeSlotFrom ig areaSize offset areaMap area =
in findSpace (align (offset + size)) size
-- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
+allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap
allocSlotFrom ig areaSize from areaMap area =
if Map.member area areaMap then areaMap
else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
+-- Figure out all of the offsets from the slot location; this will be
+-- non-zero for procpoints.
+type SpEntryMap = BlockEnv Int
+getSpEntryMap :: Int -> CmmGraph -> SpEntryMap
+getSpEntryMap entry_off g@(CmmGraph {g_entry = entry})
+ = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
+ where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
+ add_sp_off b env =
+ case lastNode b of
+ CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
+ CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env
+ _ -> env
+
-- | Greedy stack layout.
-- Compute liveness, build the interference graph, and allocate slots for the areas.
-- We visit each basic block in a (generally) forward order.
@@ -326,12 +343,16 @@ allocSlotFrom ig areaSize from areaMap area =
-- Note: The stack pointer only has to be younger than the youngest live stack slot
-- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
+layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
-- The domain of the returned map includes an Area for EVERY block
-- including each block that is not the successor of a call (ie is not a proc-point)
--- That's how we return the info of what the SP should be at the entry of every block
+-- That's how we return the info of what the SP should be at the entry of every non
+-- procpoint block. However, note that procpoint blocks have their
+-- /slot/ stored, which is not necessarily the value of the SP on entry
+-- to the block (in fact, it probably isn't, due to argument passing).
+-- See [Procpoint Sp offset]
-layout procPoints env entry_off g =
+layout procPoints spEntryMap env entry_off g =
let ig = (igraph areaBuilder env g, areaBuilder)
env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
areaSize = getAreaSize entry_off g
@@ -370,21 +391,87 @@ layout procPoints env entry_off g =
allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m
allocLast bid l areaMap =
foldr (setSuccSPs inSp) areaMap' (successors l)
- where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap
+ where inSp = slot + spOffset -- [Procpoint Sp offset]
+ -- If it's not in the map, we should use our previous
+ -- calculation unchanged.
+ spOffset = mapLookup bid spEntryMap `orElse` 0
+ slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap
areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l
alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
alloc' areaMap _ = areaMap
- initMap = Map.insert (CallArea (Young (g_entry g))) 0 $
- Map.insert (CallArea Old) 0 Map.empty
-
+ initMap = Map.insert (CallArea (Young (g_entry g))) 0
+ . Map.insert (CallArea Old) 0
+ $ Map.empty
+
areaMap = foldl layoutAreas initMap (postorderDfs g)
in -- pprTrace "ProcPoints" (ppr procPoints) $
- -- pprTrace "Area SizeMap" (ppr areaSize) $
- -- pprTrace "Entry SP" (ppr entrySp) $
- -- pprTrace "Area Map" (ppr areaMap) $
+ -- pprTrace "Area SizeMap" (ppr areaSize) $
+ -- pprTrace "Entry offset" (ppr entry_off) $
+ -- pprTrace "Area Map" (ppr areaMap) $
areaMap
+{- Note [Procpoint Sp offset]
+
+The calculation of inSp is a little tricky. (Un)fortunately, if you get
+it wrong, you will get inefficient but correct code. You know you've
+got it wrong if the generated stack pointer bounces up and down for no
+good reason.
+
+Why can't we just set inSp to the location of the slot? (This is what
+the code used to do.) The trouble is when we actually hit the proc
+point the start of the slot will not be the same as the actual Sp due
+to argument passing:
+
+ a:
+ I32[(young<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.
@@ -394,8 +481,8 @@ layout procPoints env entry_off g =
-- stack pointer to be younger than the live values on the stack at proc points.
-- 3. Compute the maximum stack offset used in the procedure and replace
-- the stack high-water mark with that offset.
-manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
-manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
+manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
+manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) =
ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g)
where slot a = -- pprTrace "slot" (ppr a) $
Map.lookup a areaMap `orElse` panic "unallocated Area"
@@ -404,13 +491,6 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
sp_high = maxSlot slot g
proc_entry_sp = slot (CallArea Old) + entry_off
- add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
- add_sp_off b env =
- case lastNode b of
- CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
- CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env
- _ -> env
- spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
spOffset id = mapLookup id spEntryMap `orElse` 0
sp_on_entry id | id == entry = proc_entry_sp
@@ -427,10 +507,26 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
where spIn = sp_on_entry (entryLabel block)
middle spOff m = mapExpDeep (replSlot spOff) m
+ -- XXX there shouldn't be any global registers in the
+ -- CmmCall, so there shouldn't be any slots in
+ -- CmmCall... check that...
last spOff l = mapExpDeep (replSlot spOff) l
replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+ -- Invariant: Sp is always greater than SpLim. Thus, if
+ -- the high water mark is zero, we can optimize away the
+ -- conditional branch. Relies on dead code elimination
+ -- to get rid of the dead GC blocks.
+ -- EZY: Maybe turn this into a guard that checks if a
+ -- statement is stack-check ish? Maybe we should make
+ -- an actual mach-op for it, so there's no chance of
+ -- mixing this up with something else...
+ replSlot _ (CmmMachOp (MO_U_Lt _)
+ [CmmMachOp (MO_Sub _)
+ [ CmmReg (CmmGlobal Sp)
+ , CmmLit (CmmInt 0 _)],
+ CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
replSlot _ e = e
replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 69b481b501169a9477cfef6b5fa504d4c12cd0c5..c9e422fb4e866214dc74181d52c7ada7863b926c 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -24,7 +24,7 @@ module MkGraph
, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
-- Reexport of needed Cmm stuff
, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..)
+ , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
, Cmm, CmmTop
)
where
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 57d458cc95e00d7d9478902ecbd35cb075b4727f..f5c08172d785f3ccf4430a98422a77376f8e5b0a 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -144,12 +144,14 @@ data CmmStmt -- Old-style
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
- | CmmCall -- A call (forign, native or primitive), with
+ | CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
HintedCmmFormals -- zero or more results
HintedCmmActuals -- zero or more arguments
CmmSafety -- whether to build a continuation
CmmReturnInfo
+ -- Some care is necessary when handling the arguments of these, see
+ -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmBranch BlockId -- branch to another BB in this fn
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 10f4e8bacfbff2bcab6d71b760f56e09d6c6d67e..aa7d914253100e0654a3536107d1c94bb19c3809 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -64,10 +64,6 @@ import Data.Word
import Data.Array.ST
import Control.Monad.ST
-#if x86_64_TARGET_ARCH
-import StaticFlags ( opt_Unregisterised )
-#endif
-
#if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
#define BEWARE_LOAD_STORE_ALIGNMENT
#endif
@@ -820,17 +816,6 @@ pprCall ppr_fn cconv results args _
| otherwise
=
-#if x86_64_TARGET_ARCH
- -- HACK around gcc optimisations.
- -- x86_64 needs a __DISCARD__() here, to create a barrier between
- -- putting the arguments into temporaries and passing the arguments
- -- to the callee, because the argument expressions may refer to
- -- machine registers that are also used for passing arguments in the
- -- C calling convention.
- (if (not opt_Unregisterised)
- then ptext (sLit "__DISCARD__();")
- else empty) $$
-#endif
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes
index 0852711f96dde654736a19cd213f6d0e5b7edfd9..c0ccadfbecaa9673906f4e639d1adc4713733a15 100644
--- a/compiler/cmm/cmm-notes
+++ b/compiler/cmm/cmm-notes
@@ -1,3 +1,7 @@
+More notes (May 11)
+~~~~~~~~~~~~~~~~~~~
+In CmmNode, consider spliting CmmCall into two: call and jump
+
Notes on new codegen (Aug 10)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -15,14 +19,11 @@ Things to do:
This will fix the spill before stack check problem but only really as a side
effect. A 'real fix' probably requires making the spiller know about sp checks.
- - There is some silly stuff happening with the Sp. We end up with code like:
- Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8
- Seems to be perhaps caused by the issue above but also maybe a optimisation
- pass needed?
+ EZY: I don't understand this comment. David Terei, can you clarify?
- - Proc pass all arguments on the stack, adding more code and slowing down things
- a lot. We either need to fix this or even better would be to get rid of
- proc points.
+ - Proc points pass all arguments on the stack, adding more code and
+ slowing down things a lot. We either need to fix this or even better
+ would be to get rid of proc points.
- CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to
Old.Cmm. We should abstract it to work on both representations, it needs only to
@@ -32,7 +33,7 @@ Things to do:
we could convert codeGen/StgCmm* clients to the Hoopl's semantics?
It's all deeply unsatisfactory.
- - Improve preformance of Hoopl.
+ - Improve performance of Hoopl.
A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters
(using the same ghc-cmm branch +libraries compiled by the old codegenerator)
@@ -50,6 +51,9 @@ Things to do:
So we generate a bit better code, but it takes us longer!
+ EZY: Also importantly, Hoopl uses dramatically more memory than the
+ old code generator.
+
- Are all blockToNodeList and blockOfNodeList really needed? Maybe we could
splice blocks instead?
@@ -57,7 +61,7 @@ Things to do:
a block catenation function would be probably nicer than blockToNodeList
/ blockOfNodeList combo.
- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that
+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that
delete splitEntrySeq from HooplUtils.
- manifestSP seems to touch a lot of the graph representation. It is
@@ -76,6 +80,9 @@ Things to do:
calling convention, and the code for calling foreign calls is generated
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline
+ EZY (2011-04-16): The mini-inliner has been generalized and ported,
+ but the constant folding and other optimizations need to still be
+ ported.
- AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);
we ultimately want to share this with the Cmm branch eliminator.
@@ -113,7 +120,7 @@ Things to do:
- See "CAFs" below; we want to totally refactor the way SRTs are calculated
- Pull out Areas into its own module
- Parameterise AreaMap
+ Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)
Add ByteWidth = Int
type SubArea = (Area, ByteOff, ByteWidth)
ByteOff should not be defined in SMRep -- that is too high up the hierarchy
@@ -293,8 +300,8 @@ cpsTop:
insert spills/reloads across
LastCalls, and
Branches to proc-points
- Now sink those reloads:
- - CmmSpillReload.insertLateReloads
+ Now sink those reloads (and other instructions):
+ - CmmSpillReload.rewriteAssignments
- CmmSpillReload.removeDeadAssignmentsAndReloads
* CmmStackLayout.stubSlotsOnDeath
@@ -344,7 +351,7 @@ to J that way. This is an awkward choice. (We think that we currently
never pass variables to join points via arguments.)
Furthermore, there is *no way* to pass q to J in a register (other
-than a paramter register).
+than a parameter register).
What we want is to do register allocation across the whole caboodle.
Then we could drop all the code that deals with the above awkward
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 5f2b6bf95e2df3c30b702ea3e32b87b7d9a0462f..c922979092c8d0f295720f25d424414e968ee68b 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -10,13 +10,17 @@ module CgPrimOp (
cgPrimOp
) where
+import BasicTypes
import ForeignCall
import ClosureInfo
import StgSyn
import CgForeignCall
import CgBindery
import CgMonad
+import CgHeapery
import CgInfoTbls
+import CgTicky
+import CgProf
import CgUtils
import OldCmm
import CLabel
@@ -224,6 +228,19 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] _
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _
= stmtC (CmmAssign (CmmLocal res) arg)
+emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
+ doCopyArrayOp src src_off dst dst_off n live
+emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
+ doCopyMutableArrayOp src src_off dst dst_off n live
+emitPrimOp [res] CloneArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+emitPrimOp [res] FreezeArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] ThawArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+
-- Reading/writing pointer arrays
emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix
@@ -666,3 +683,198 @@ cmmLoadIndexOffExpr off rep base idx
setInfo :: CmmExpr -> CmmExpr -> CmmStmt
setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
+-- ----------------------------------------------------------------------------
+-- Copying pointer arrays
+
+-- | Takes a source 'Array#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy. Copies the given number of
+-- elements from the source array to the destination array.
+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+doCopyArrayOp = emitCopyArray copy
+ where
+ -- Copy data (we assume the arrays aren't overlapping since
+ -- they're of different types)
+ copy _src _dst = emitMemcpyCall
+
+-- | Takes a source 'MutableArray#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy. Copies the given number of
+-- elements from the source array to the destination array.
+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+doCopyMutableArrayOp = emitCopyArray copy
+ where
+ -- The only time the memory might overlap is when the two arrays
+ -- we were provided are the same array!
+ -- TODO: Optimize branch for common case of no aliasing.
+ copy src dst dst_p src_p bytes live =
+ emitIfThenElse (cmmEqWord src dst)
+ (emitMemmoveCall dst_p src_p bytes live)
+ (emitMemcpyCall dst_p src_p bytes live)
+
+emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code)
+ -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars
+ -> Code
+emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
+ -- Assign the arguments to temporaries so the code generator can
+ -- calculate liveness for us.
+ src <- assignTemp_ src0
+ src_off <- assignTemp_ src_off0
+ dst <- assignTemp_ dst0
+ dst_off <- assignTemp_ dst_off0
+ n <- assignTemp_ n0
+
+ -- Set the dirty bit in the header.
+ stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+
+ dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize
+ dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off
+ src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
+ bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
+
+ copy src dst dst_p src_p bytes live
+
+ -- The base address of the destination card table
+ dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
+
+ emitSetCards dst_off dst_cards_p n live
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it form the source array.
+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+emitCloneArray info_p res_r src0 src_off0 n0 live = do
+ -- Assign the arguments to temporaries so the code generator can
+ -- calculate liveness for us.
+ src <- assignTemp_ src0
+ src_off <- assignTemp_ src_off0
+ n <- assignTemp_ n0
+
+ card_words <- assignTemp $ (n `cmmUShrWord`
+ (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
+ `cmmAddWord` CmmLit (mkIntCLit 1)
+ size <- assignTemp $ n `cmmAddWord` card_words
+ words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
+
+ arr_r <- newTemp bWord
+ emitAllocateCall arr_r myCapability words live
+ tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
+ (CmmLit $ mkIntCLit 0)
+
+ let arr = CmmReg (CmmLocal arr_r)
+ emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
+ stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+ oFFSET_StgMutArrPtrs_ptrs)) n
+ stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+ oFFSET_StgMutArrPtrs_size)) size
+
+ dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize
+ src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
+ src_off
+
+ emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live
+
+ emitMemsetCall (cmmOffsetExprW dst_p n)
+ (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ (card_words `cmmMulWord` wordSize)
+ live
+ stmtC $ CmmAssign (CmmLocal res_r) arr
+ where
+ arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
+ (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+ wordSize = CmmLit (mkIntCLit wORD_SIZE)
+ myCapability = CmmReg baseReg `cmmSubWord`
+ CmmLit (mkIntCLit oFFSET_Capability_r)
+
+-- | Takes and offset in the destination array, the base address of
+-- the card table, and the number of elements affected (*not* the
+-- number of cards). Marks the relevant cards as dirty.
+emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitSetCards dst_start dst_cards_start n live = do
+ start_card <- assignTemp $ card dst_start
+ emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
+ (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
+ `cmmAddWord` CmmLit (mkIntCLit 1))
+ live
+ where
+ -- Convert an element index to a card index
+ card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- | Emit a call to @memcpy@.
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemcpyCall dst src n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memcpy CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted src AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemmoveCall dst src n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memmove CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted src AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memset@. The second argument must be of type
+-- 'W8'.
+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemsetCall dst c n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memset CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted c NoHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @allocate@.
+emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitAllocateCall res cap n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [CmmHinted res AddrHint]
+ (CmmCallee allocate CCallConv)
+ [ (CmmHinted cap AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
+ ForeignLabelInExternalPackage IsFunction))
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 922d330b26df620c177edae5e7ee96129d62aca1..4df7c77914e62f237077a30803e021bffddff014 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -20,7 +20,7 @@ module CgUtils (
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
- assignTemp, newTemp,
+ assignTemp, assignTemp_, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
@@ -29,7 +29,7 @@ module CgUtils (
activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmUGtWord,
+ cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
@@ -180,8 +180,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
+cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
@@ -587,6 +589,9 @@ mkByteStringCLit bytes
--
-------------------------------------------------------------------------
+-- | If the expression is trivial, return it. Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
assignTemp :: CmmExpr -> FCode CmmExpr
-- For a non-trivial expression, e, create a local
-- variable and assign the expression to it
@@ -596,6 +601,14 @@ assignTemp e
; stmtC (CmmAssign (CmmLocal reg) e)
; return (CmmReg (CmmLocal reg)) }
+-- | Assign the expression to a temporary register and return an
+-- expression referring to this register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e = do
+ reg <- newTemp (cmmExprType e)
+ stmtC (CmmAssign (CmmLocal reg) e)
+ return (CmmReg (CmmLocal reg))
+
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 48416e3f69a42db85ce5846ce8224aef54f18f10..d9178116840129bc1fa9d7673d5e802ed51b4974 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -340,6 +340,23 @@ emitRtsCall' res pkg fun args _vols safe
-- * Regs.h claims that BaseReg should be saved last and loaded first
-- * This might not have been tickled before since BaseReg is callee save
-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h). It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers. We can't (nor want) to do that
+-- here, as we don't have liveness information. And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs = (caller_save, caller_load)
where
@@ -396,6 +413,51 @@ callerSaves :: GlobalReg -> Bool
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = True
#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1 _) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2 _) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3 _) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4 _) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5 _) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6 _) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7 _) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8 _) = True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1) = True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2) = True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3) = True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4) = True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1) = True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2) = True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1) = True
+#endif
#ifdef CALLER_SAVES_Sp
callerSaves Sp = True
#endif
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 678c961c18589015d7ed267590273ffafeb712f9..0fa1c381e9efe45e2c42acfb407756faa9c3d8b3 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -29,6 +29,7 @@ import BasicTypes
import Unique
import Outputable
import FastString
+import Pair
\end{code}
%************************************************************************
@@ -79,11 +80,13 @@ exprArity e = go e
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Note n e) | notSccNote n = go e
- go (Cast e co) = go e `min` length (typeArity (snd (coercionKind co)))
- -- Note [exprArity invariant]
+ go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co)))
+ -- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
-- See Note [exprArity for applications]
+ -- NB: coercions count as a value argument
+
go _ = 0
@@ -549,7 +552,7 @@ arityType cheap_fn (Lam x e)
| isId x = arityLam x (arityType cheap_fn e)
| otherwise = arityType cheap_fn e
- -- Applications; decrease arity
+ -- Applications; decrease arity, except for types
arityType cheap_fn (App fun (Type _))
= arityType cheap_fn fun
arityType cheap_fn (App fun arg )
@@ -663,14 +666,14 @@ etaExpand n orig_expr
-- Strip off existing lambdas and casts
-- Note [Eta expansion and SCCs]
go 0 expr = expr
- go n (Lam v body) | isTyCoVar v = Lam v (go n body)
- | otherwise = Lam v (go (n-1) body)
+ go n (Lam v body) | isTyVar v = Lam v (go n body)
+ | otherwise = Lam v (go (n-1) body)
go n (Cast expr co) = Cast (go n expr) co
go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
etaInfoAbs etas (etaInfoApp subst' expr etas)
where
in_scope = mkInScopeSet (exprFreeVars expr)
- (in_scope', etas) = mkEtaWW n in_scope (exprType expr)
+ (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
subst' = mkEmptySubst in_scope'
-- Wrapper Unwrapper
@@ -685,10 +688,10 @@ instance Outputable EtaInfo where
pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
pushCoercion co1 (EtaCo co2 : eis)
- | isIdentityCoercion co = eis
- | otherwise = EtaCo co : eis
+ | isReflCo co = eis
+ | otherwise = EtaCo co : eis
where
- co = co1 `mkTransCoercion` co2
+ co = co1 `mkTransCo` co2
pushCoercion co eis = EtaCo co : eis
@@ -696,7 +699,7 @@ pushCoercion co eis = EtaCo co : eis
etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs [] expr = expr
etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
-etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co)
+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
--------------
etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
@@ -704,15 +707,12 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
-- ((substExpr s e) `appliedto` eis)
etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)
- = etaInfoApp subst' e eis
- where
- subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2)
- | otherwise = CoreSubst.extendIdSubst subst v1 (Var v2)
+ = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
etaInfoApp subst (Cast e co1) eis
= etaInfoApp subst e (pushCoercion co' eis)
where
- co' = CoreSubst.substTy subst co1
+ co' = CoreSubst.substCo subst co1
etaInfoApp subst (Case e b _ alts) eis
= Case (subst_expr subst e) b1 (coreAltsType alts') alts'
@@ -739,24 +739,24 @@ etaInfoApp subst e eis
go e (EtaCo co : eis) = go (Cast e co) eis
--------------
-mkEtaWW :: Arity -> InScopeSet -> Type
+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
-> (InScopeSet, [EtaInfo])
-- EtaInfo contains fresh variables,
-- not free in the incoming CoreExpr
-- Outgoing InScopeSet includes the EtaInfo vars
-- and the original free vars
-mkEtaWW orig_n in_scope orig_ty
+mkEtaWW orig_n orig_expr in_scope orig_ty
= go orig_n empty_subst orig_ty []
where
- empty_subst = mkTvSubst in_scope emptyTvSubstEnv
+ empty_subst = TvSubst in_scope emptyTvSubstEnv
go n subst ty eis -- See Note [exprArity invariant]
| n == 0
= (getTvInScope subst, reverse eis)
| Just (tv,ty') <- splitForAllTy_maybe ty
- , let (subst', tv') = substTyVarBndr subst tv
+ , let (subst', tv') = Type.substTyVarBndr subst tv
-- Avoid free vars of the original expression
= go n subst' ty' (EtaVar tv' : eis)
@@ -772,11 +772,11 @@ mkEtaWW orig_n in_scope orig_ty
-- eta_expand 1 e T
-- We want to get
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
- go n subst ty' (EtaCo (Type.substTy subst co) : eis)
+ go n subst ty' (EtaCo co : eis)
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
- = WARN( True, ppr orig_n <+> ppr orig_ty )
+ = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTvInScope subst, reverse eis)
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index af414f7550463e383cc0fa6104258d367962d172..88509f90f32c8a63e2896fb495dc66daa7405851 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -49,6 +49,7 @@ import Name
import VarSet
import Var
import TcType
+import Coercion
import Util
import BasicTypes( Activation )
import Outputable
@@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
+expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
expr_fvs (Var var) = oneVar var
expr_fvs (Lit _) = noVars
expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyVarsOfType co)
+expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
expr_fvs (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
@@ -248,10 +250,11 @@ exprOrphNames e
where n = idName v
go (Lit _) = emptyNameSet
go (Type ty) = orphNamesOfType ty -- Don't need free tyvars
+ go (Coercion co) = orphNamesOfCo co
go (App e1 e2) = go e1 `unionNameSets` go e2
go (Lam v e) = go e `delFromNameSet` idName v
go (Note _ e) = go e
- go (Cast e co) = go e `unionNameSets` orphNamesOfType co
+ go (Cast e co) = go e `unionNameSets` orphNamesOfCo co
go (Let (NonRec _ r) e) = go e `unionNameSets` go r
go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e
go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty
@@ -392,15 +395,15 @@ varTypeTyVars :: Var -> TyVarSet
-- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables...
varTypeTyVars var
- | isLocalId var || isCoVar var = tyVarsOfType (idType var)
- | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
+ | isLocalId var = tyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
varTypeTcTyVars :: Var -> TyVarSet
-- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables...
varTypeTcTyVars var
- | isLocalId var || isCoVar var = tcTyVarsOfType (idType var)
- | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
+ | isLocalId var = tcTyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
idFreeVars :: Id -> VarSet
-- Type variables, rule variables, and inline variables
@@ -411,7 +414,7 @@ idFreeVars id = ASSERT( isId id)
bndrRuleAndUnfoldingVars ::Var -> VarSet
-- A 'let' can bind a type variable, and idRuleVars assumes
-- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
idRuleAndUnfoldingVars :: Id -> VarSet
@@ -510,12 +513,11 @@ freeVars (Let (Rec binds) body)
body2 = freeVars body
body_fvs = freeVarsOf body2
-
freeVars (Cast expr co)
- = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
+ = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
where
expr2 = freeVars expr
- cfvs = tyVarsOfType co
+ cfvs = tyCoVarsOfCo co
freeVars (Note other_note expr)
= (freeVarsOf expr2, AnnNote other_note expr2)
@@ -523,5 +525,7 @@ freeVars (Note other_note expr)
expr2 = freeVars expr
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
\end{code}
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 5cc82a2ae220f623627bc573880cc7ce006499d5..869f276c50abce60258721e36b4906505592eb2b 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -15,6 +15,7 @@ import Demand
import CoreSyn
import CoreFVs
import CoreUtils
+import Pair
import Bag
import Literal
import DataCon
@@ -27,6 +28,7 @@ import Id
import PprCore
import ErrUtils
import SrcLoc
+import Kind
import Type
import TypeRep
import Coercion
@@ -41,6 +43,7 @@ import FastString
import Util
import Control.Monad
import Data.Maybe
+import Data.Traversable (traverse)
\end{code}
%************************************************************************
@@ -166,7 +169,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check the rhs
do { ty <- lintCoreExpr rhs
; lintBinder binder -- Check match to RHS type
- ; binder_ty <- applySubst binder_ty
+ ; binder_ty <- applySubstTy binder_ty
; checkTys binder_ty ty (mkRhsMsg binder ty)
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
; checkL (not (isUnLiftedType binder_ty)
@@ -207,14 +210,15 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
%************************************************************************
\begin{code}
-type InType = Type -- Substitution not yet applied
-type InVar = Var
-type InTyVar = TyVar
+type InType = Type -- Substitution not yet applied
+type InCoercion = Coercion
+type InVar = Var
+type InTyVar = TyVar
-type OutType = Type -- Substitution has been applied to this
-type OutVar = Var
-type OutTyVar = TyVar
-type OutCoVar = CoVar
+type OutType = Type -- Substitution has been applied to this
+type OutCoercion = Coercion
+type OutVar = Var
+type OutTyVar = TyVar
lintCoreExpr :: CoreExpr -> LintM OutType
-- The returned type has the substitution from the monad
@@ -227,6 +231,9 @@ lintCoreExpr (Var var)
= do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple"))
+ ; checkL (isId var && not (isCoVar var))
+ (ptext (sLit "Non term variable") <+> ppr var)
+
; checkDeadIdOcc var
; var' <- lookupIdInScope var
; return (idType var') }
@@ -236,7 +243,7 @@ lintCoreExpr (Lit lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
- ; co' <- applySubst co
+ ; co' <- applySubstCo co
; (from_ty, to_ty) <- lintCoercion co'
; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
; return to_ty }
@@ -251,29 +258,20 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
; lintTyBndr tv $ \ tv' ->
addLoc (BodyOfLetRec [tv]) $
extendSubstL tv' ty' $ do
- { checkKinds tv' ty'
+ { checkTyKind tv' ty'
-- Now extend the substitution so we
-- take advantage of it in the body
; lintCoreExpr body } }
- | isCoVar tv
- = do { co <- applySubst ty
- ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
- ; lintTyBndr tv $ \ tv' ->
- addLoc (BodyOfLetRec [tv]) $ do
- { let (t1,t2) = coVarKind tv'
- ; checkTys s1 t1 (mkTyVarLetErr tv ty)
- ; checkTys s2 t2 (mkTyVarLetErr tv ty)
- ; lintCoreExpr body } }
-
- | otherwise
- = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate
-
lintCoreExpr (Let (NonRec bndr rhs) body)
+ | isId bndr
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
- ; addLoc (BodyOfLetRec [bndr])
+ ; addLoc (BodyOfLetRec [bndr])
(lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
+ | otherwise
+ = failWithL (mkLetErr bndr rhs) -- Not quite accurate
+
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
do { checkL (null dups) (dupVars dups)
@@ -298,7 +296,7 @@ lintCoreExpr (Lam var expr)
else
return (mkForAllTy var' body_ty)
}
- -- The applySubst is needed to apply the subst to var
+ -- The applySubstTy is needed to apply the subst to var
lintCoreExpr e@(Case scrut var alt_ty alts) =
-- Check the scrutinee
@@ -338,6 +336,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
lintCoreExpr (Type ty)
= do { ty' <- lintInTy ty
; return (typeKind ty') }
+
+lintCoreExpr (Coercion co)
+ = do { co' <- lintInCo co
+ ; let Pair ty1 ty2 = coercionKind co'
+ ; return (mkPredTy $ EqPred ty1 ty2) }
\end{code}
%************************************************************************
@@ -352,12 +355,12 @@ subtype of the required type, as one would expect.
\begin{code}
lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty)
- = do { arg_ty' <- applySubst arg_ty
- ; lintTyApp fun_ty arg_ty' }
+ = do { arg_ty' <- applySubstTy arg_ty
+ ; lintTyApp fun_ty arg_ty' }
lintCoreArg fun_ty arg
- = do { arg_ty <- lintCoreExpr arg
- ; lintValApp arg fun_ty arg_ty }
+ = do { arg_ty <- lintCoreExpr arg
+ ; lintValApp arg fun_ty arg_ty }
-----------------
lintAltBinders :: OutType -- Scrutinee type
@@ -367,7 +370,7 @@ lintAltBinders :: OutType -- Scrutinee type
lintAltBinders scrut_ty con_ty []
= checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
lintAltBinders scrut_ty con_ty (bndr:bndrs)
- | isTyCoVar bndr
+ | isTyVar bndr
= do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
; lintAltBinders scrut_ty con_ty' bndrs }
| otherwise
@@ -378,11 +381,10 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs)
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp fun_ty arg_ty
| Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
- = do { checkKinds tyvar arg_ty
- ; if isCoVar tyvar then
- return body_ty -- Co-vars don't appear in body_ty!
- else
- return (substTyWith [tyvar] [arg_ty] body_ty) }
+ , isTyVar tyvar
+ = do { checkTyKind tyvar arg_ty
+ ; return (substTyWith [tyvar] [arg_ty] body_ty) }
+
| otherwise
= failWithL (mkTyAppMsg fun_ty arg_ty)
@@ -400,22 +402,34 @@ lintValApp arg fun_ty arg_ty
\end{code}
\begin{code}
-checkKinds :: OutVar -> OutType -> LintM ()
+checkTyKind :: OutTyVar -> OutType -> LintM ()
-- Both args have had substitution applied
-checkKinds tyvar arg_ty
+checkTyKind tyvar arg_ty
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
- | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty
- ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2)
- (addErrL (mkCoAppErrMsg tyvar arg_ty)) }
- | otherwise = do { arg_kind <- lintType arg_ty
- ; unless (arg_kind `isSubKind` tyvar_kind)
- (addErrL (mkKindErrMsg tyvar arg_ty)) }
+ = do { arg_kind <- lintType arg_ty
+ ; unless (arg_kind `isSubKind` tyvar_kind)
+ (addErrL (mkKindErrMsg tyvar arg_ty)) }
where
tyvar_kind = tyVarKind tyvar
- (s1,t1) = coVarKind tyvar
+
+-- Check that the kinds of a type variable and a coercion match, that
+-- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k.
+checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
+checkTyCoKind tv co
+ = do { (t1,t2) <- lintCoercion co
+ ; k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+ (addErrL (mkTyCoAppErrMsg tv co))
+ ; return (t1,t2) }
+ where
+ tyvar_kind = tyVarKind tv
+
+checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
+checkTyCoKinds = zipWithM checkTyCoKind
checkDeadIdOcc :: Id -> LintM ()
-- Occurrences of an Id should never be dead....
@@ -536,7 +550,7 @@ lintBinder var linterF
lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
= do { subst <- getTvSubst
- ; let (subst', tv') = substTyVarBndr subst tv
+ ; let (subst', tv') = Type.substTyVarBndr subst tv
; lintTyBndrKind tv'
; updateTvSubst subst' (thing_inside tv') }
@@ -581,10 +595,19 @@ lintInTy :: InType -> LintM OutType
-- ToDo: check the kind structure of the type
lintInTy ty
= addLoc (InType ty) $
- do { ty' <- applySubst ty
+ do { ty' <- applySubstTy ty
; _ <- lintType ty'
; return ty' }
+lintInCo :: InCoercion -> LintM OutCoercion
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+ = addLoc (InCo co) $
+ do { co' <- applySubstCo co
+ ; _ <- lintCoercion co'
+ ; return co' }
+
-------------------
lintKind :: Kind -> LintM ()
-- Check well-formedness of kinds: *, *->*, etc
@@ -598,124 +621,71 @@ lintKind kind
-------------------
lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv
- | isCoVar tv = lintCoVarKind tv
- | otherwise = lintKind (tyVarKind tv)
-
--------------------
-lintCoVarKind :: OutCoVar -> LintM ()
--- Check the kind of a coercion binder
-lintCoVarKind tv
- = do { (ty1,ty2) <- lintSplitCoVar tv
- ; k1 <- lintType ty1
- ; k2 <- lintType ty2
- ; unless (k1 `eqKind` k2)
- (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:")
- , nest 2 (quotes (ppr tv))
- , ppr [k1,k2] ])) }
+lintTyBndrKind tv = lintKind (tyVarKind tv)
-------------------
-lintSplitCoVar :: CoVar -> LintM (Type,Type)
-lintSplitCoVar cv
- = case coVarKind_maybe cv of
- Just ts -> return ts
- Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
- , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
-
--------------------
-lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
+lintCoercion :: OutCoercion -> LintM (OutType, OutType)
-- Check the kind of a coercion term, returning the kind
-lintCoercion co
- = addLoc (InCoercion co) $ lintCoercion' co
-
-lintCoercion' ty@(TyVarTy tv)
- = do { checkTyVarInScope tv
- ; if isCoVar tv then return (coVarKind tv)
- else return (ty, ty) }
-
-lintCoercion' ty@(AppTy ty1 ty2)
- = do { (s1,t1) <- lintCoercion ty1
- ; (s2,t2) <- lintCoercion ty2
- ; check_co_app ty (typeKind s1) [s2]
- ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
-
-lintCoercion' ty@(FunTy ty1 ty2)
- = do { (s1,t1) <- lintCoercion ty1
- ; (s2,t2) <- lintCoercion ty2
- ; check_co_app ty (tyConKind funTyCon) [s1, s2]
- ; return (FunTy s1 s2, FunTy t1 t2) }
-
-lintCoercion' ty@(TyConApp tc tys)
- | Just (ar, desc) <- isCoercionTyCon_maybe tc
- = do { unless (tys `lengthAtLeast` ar) (badCo ty)
- ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
- ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
- ; check_co_app ty (typeKind s) ss
- ; return (mkAppTys s ss, mkAppTys t ts) }
+lintCoercion (Refl ty)
+ = do { ty' <- lintInTy ty
+ ; return (ty', ty') }
- | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon
- = badCo ty
+lintCoercion co@(TyConAppCo tc cos)
+ = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+ ; check_co_app co (tyConKind tc) ss
+ ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
- | otherwise
- = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
- ; check_co_app ty (tyConKind tc) ss
- ; return (TyConApp tc ss, TyConApp tc ts) }
-
-lintCoercion' ty@(PredTy (ClassP cls tys))
- = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
- ; check_co_app ty (tyConKind (classTyCon cls)) ss
- ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
-
-lintCoercion' (PredTy (IParam n p_ty))
- = do { (s,t) <- lintCoercion p_ty
- ; return (PredTy (IParam n s), PredTy (IParam n t)) }
-
-lintCoercion' ty@(PredTy (EqPred {}))
- = failWithL (badEq ty)
-
-lintCoercion' (ForAllTy tv ty)
- | isCoVar tv
- = do { (co1, co2) <- lintSplitCoVar tv
- ; (s1,t1) <- lintCoercion co1
- ; (s2,t2) <- lintCoercion co2
- ; (sr,tr) <- lintCoercion ty
- ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) }
+lintCoercion co@(AppCo co1 co2)
+ = do { (s1,t1) <- lintCoercion co1
+ ; (s2,t2) <- lintCoercion co2
+ ; check_co_app co (typeKind s1) [s2]
+ ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
- | otherwise
- = do { lintKind (tyVarKind tv)
- ; (s,t) <- addInScopeVar tv (lintCoercion ty)
- ; return (ForAllTy tv s, ForAllTy tv t) }
-
-badCo :: Coercion -> LintM a
-badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
-
----------------
-lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
--- Always called with correct number of coercion arguments
--- First arg is just for error message
-lintCoTyConApp _ CoLeft (co:_) = lintLR fst co
-lintCoTyConApp _ CoRight (co:_) = lintLR snd co
-lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co
-lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co
-lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co
-
-lintCoTyConApp _ CoSym (co:_)
- = do { (ty1,ty2) <- lintCoercion co
- ; return (ty2,ty1) }
-
-lintCoTyConApp co CoTrans (co1:co2:_)
+lintCoercion (ForAllCo v co)
+ = do { lintKind (tyVarKind v)
+ ; (s,t) <- addInScopeVar v (lintCoercion co)
+ ; return (ForAllTy v s, ForAllTy v t) }
+
+lintCoercion (CoVarCo cv)
+ = do { checkTyCoVarInScope cv
+ ; return (coVarKind cv) }
+
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+ , co_ax_lhs = lhs
+ , co_ax_rhs = rhs })
+ cos)
+ = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
+ ; return (substTyWith tvs tys1 lhs,
+ substTyWith tvs tys2 rhs) }
+
+lintCoercion (UnsafeCo ty1 ty2)
+ = do { ty1' <- lintInTy ty1
+ ; ty2' <- lintInTy ty2
+ ; return (ty1', ty2') }
+
+lintCoercion (SymCo co)
+ = do { (ty1, ty2) <- lintCoercion co
+ ; return (ty2, ty1) }
+
+lintCoercion co@(TransCo co1 co2)
= do { (ty1a, ty1b) <- lintCoercion co1
; (ty2a, ty2b) <- lintCoercion co2
- ; checkL (ty1b `coreEqType` ty2a)
+ ; checkL (ty1b `eqType` ty2a)
(hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
; return (ty1a, ty2b) }
-lintCoTyConApp _ CoInst (co:arg_ty:_)
- = do { co_tys <- lintCoercion co
+lintCoercion the_co@(NthCo d co)
+ = do { (s,t) <- lintCoercion co
+ ; sn <- checkTcApp the_co d s
+ ; tn <- checkTcApp the_co d t
+ ; return (sn, tn) }
+
+lintCoercion (InstCo co arg_ty)
+ = do { co_tys <- lintCoercion co
; arg_kind <- lintType arg_ty
- ; case decompInst_maybe co_tys of
- Just ((tv1,tv2), (ty1,ty2))
+ ; case splitForAllTy_maybe `traverse` toPair co_tys of
+ Just (Pair (tv1,ty1) (tv2,ty2))
| arg_kind `isSubKind` tyVarKind tv1
-> return (substTyWith [tv1] [arg_ty] ty1,
substTyWith [tv2] [arg_ty] ty2)
@@ -723,40 +693,20 @@ lintCoTyConApp _ CoInst (co:arg_ty:_)
-> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
-lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
- = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
- ; sequence_ (zipWith checkKinds tvs tys1)
- ; return (substTyWith tvs tys1 lhs_ty,
- substTyWith tvs tys2 rhs_ty) }
-
-lintCoTyConApp _ CoUnsafe (ty1:ty2:_)
- = do { _ <- lintType ty1
- ; _ <- lintType ty2 -- Ignore kinds; it's unsafe!
- ; return (ty1,ty2) }
-
-lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args
-
----------
-lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
-lintLR sel co
- = do { (ty1,ty2) <- lintCoercion co
- ; case decompLR_maybe (ty1,ty2) of
- Just res -> return (sel res)
- Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) }
-
-----------
-lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
-lintCsel sel co
- = do { (ty1,ty2) <- lintCoercion co
- ; case decompCsel_maybe (ty1,ty2) of
- Just res -> return (sel res)
- Nothing -> failWithL (ptext (sLit "Bad argument of csel")) }
+checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp co n ty
+ | Just (_, tys) <- splitTyConApp_maybe ty
+ , n < length tys
+ = return (tys !! n)
+ | otherwise
+ = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co)
+ 2 (ptext (sLit "Offending type:") <+> ppr ty))
-------------------
lintType :: OutType -> LintM Kind
lintType (TyVarTy tv)
- = do { checkTyVarInScope tv
+ = do { checkTyCoVarInScope tv
; return (tyVarKind tv) }
lintType ty@(AppTy t1 t2)
@@ -767,6 +717,8 @@ lintType ty@(FunTy t1 t2)
= lint_ty_app ty (tyConKind funTyCon) [t1,t2]
lintType ty@(TyConApp tc tys)
+ | tc `hasKey` eqPredPrimTyConKey -- See Note [The (~) TyCon] in TysPrim
+ = lint_eq_pred ty tys
| tyConHasKind tc
= lint_ty_app ty (tyConKind tc) tys
| otherwise
@@ -782,15 +734,31 @@ lintType ty@(PredTy (ClassP cls tys))
lintType (PredTy (IParam _ p_ty))
= lintType p_ty
-lintType ty@(PredTy (EqPred {}))
- = failWithL (badEq ty)
+lintType ty@(PredTy (EqPred t1 t2))
+ = do { k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; unless (k1 `eqKind` k2)
+ (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
+ , nest 2 (ppr ty) ]))
+ ; return unliftedTypeKind }
----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
lint_ty_app ty k tys
= do { ks <- mapM lintType tys
; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
-
+
+lint_eq_pred :: Type -> [OutType] -> LintM Kind
+lint_eq_pred ty arg_tys
+ | [ty1,ty2] <- arg_tys
+ = do { k1 <- lintType ty1
+ ; k2 <- lintType ty2
+ ; checkL (k1 `eqKind` k2)
+ (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
+ ; return unliftedTypeKind }
+ | otherwise
+ = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty)
+
----------------
check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
check_co_app ty k tys
@@ -812,10 +780,6 @@ lint_kind_app doc kfn ks = go kfn ks
Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
(addErrL fail_msg)
; go kfb ks }
---------------
-badEq :: Type -> SDoc
-badEq ty = hang (ptext (sLit "Unexpected equality predicate:"))
- 1 (quotes (ppr ty))
\end{code}
%************************************************************************
@@ -870,7 +834,7 @@ data LintLocInfo
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
| TopLevelBindings
| InType Type -- Inside a type
- | InCoercion Coercion -- Inside a type
+ | InCo Coercion -- Inside a coercion
\end{code}
@@ -936,12 +900,15 @@ updateTvSubst subst' m =
getTvSubst :: LintM TvSubst
getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
-applySubst :: Type -> LintM Type
-applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
+applySubstTy :: Type -> LintM Type
+applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
+
+applySubstCo :: Coercion -> LintM Coercion
+applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
- = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
+ = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
\end{code}
\begin{code}
@@ -969,8 +936,8 @@ checkBndrIdInScope binder id
msg = ptext (sLit "is out of scope inside info for") <+>
ppr binder
-checkTyVarInScope :: TyVar -> LintM ()
-checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
+checkTyCoVarInScope :: TyCoVar -> LintM ()
+checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var =
@@ -982,7 +949,7 @@ checkTys :: OutType -> OutType -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
\end{code}
%************************************************************************
@@ -1021,8 +988,8 @@ dumpLoc TopLevelBindings
= (noSrcLoc, empty)
dumpLoc (InType ty)
= (noSrcLoc, text "In the type" <+> quotes (ppr ty))
-dumpLoc (InCoercion ty)
- = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+ = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
@@ -1114,29 +1081,21 @@ mkNonFunAppMsg fun_ty arg_ty arg
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
-mkTyVarLetErr :: TyVar -> Type -> Message
-mkTyVarLetErr tyvar ty
- = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
- hang (ptext (sLit "Type/coercion variable:"))
- 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
- hang (ptext (sLit "Arg type/coercion:"))
- 4 (ppr ty)]
-
-mkKindErrMsg :: TyVar -> Type -> Message
-mkKindErrMsg tyvar arg_ty
- = vcat [ptext (sLit "Kinds don't match in type application:"),
- hang (ptext (sLit "Type variable:"))
- 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
- hang (ptext (sLit "Arg type:"))
- 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-
-mkCoAppErrMsg :: TyVar -> Type -> Message
-mkCoAppErrMsg tyvar arg_ty
- = vcat [ptext (sLit "Kinds don't match in coercion application:"),
- hang (ptext (sLit "Coercion variable:"))
+mkLetErr :: TyVar -> CoreExpr -> Message
+mkLetErr bndr rhs
+ = vcat [ptext (sLit "Bad `let' binding:"),
+ hang (ptext (sLit "Variable:"))
+ 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+ hang (ptext (sLit "Rhs:"))
+ 4 (ppr rhs)]
+
+mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
+mkTyCoAppErrMsg tyvar arg_co
+ = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
+ hang (ptext (sLit "Type variable:"))
4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext (sLit "Arg coercion:"))
- 4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))]
+ 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
@@ -1168,6 +1127,15 @@ mkStrictMsg binder
hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
]
+
+mkKindErrMsg :: TyVar -> Type -> Message
+mkKindErrMsg tyvar arg_ty
+ = vcat [ptext (sLit "Kinds don't match in type application:"),
+ hang (ptext (sLit "Type variable:"))
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+ hang (ptext (sLit "Arg type:"))
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
mkArityMsg :: Id -> Message
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
@@ -1203,3 +1171,56 @@ dupExtVars vars
= hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
2 (ppr vars)
\end{code}
+
+-------------- DEAD CODE -------------------
+
+-------------------
+checkCoKind :: CoVar -> OutCoercion -> LintM ()
+-- Both args have had substitution applied
+checkCoKind covar arg_co
+ = do { (s2,t2) <- lintCoercion arg_co
+ ; unless (s1 `eqType` s2 && t1 `coreEqType` t2)
+ (addErrL (mkCoAppErrMsg covar arg_co)) }
+ where
+ (s1,t1) = coVarKind covar
+
+lintCoVarKind :: OutCoVar -> LintM ()
+-- Check the kind of a coercion binder
+lintCoVarKind tv
+ = do { (ty1,ty2) <- lintSplitCoVar tv
+ ; lintEqType ty1 ty2
+
+
+-------------------
+lintSplitCoVar :: CoVar -> LintM (Type,Type)
+lintSplitCoVar cv
+ = case coVarKind_maybe cv of
+ Just ts -> return ts
+ Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
+ , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
+
+mkCoVarLetErr :: CoVar -> Coercion -> Message
+mkCoVarLetErr covar co
+ = vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
+ hang (ptext (sLit "Coercion variable:"))
+ 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+ hang (ptext (sLit "Arg coercion:"))
+ 4 (ppr co)]
+
+mkCoAppErrMsg :: CoVar -> Coercion -> Message
+mkCoAppErrMsg covar arg_co
+ = vcat [ptext (sLit "Kinds don't match in coercion application:"),
+ hang (ptext (sLit "Coercion variable:"))
+ 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+ hang (ptext (sLit "Arg coercion:"))
+ 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
+
+
+mkCoAppMsg :: Type -> Coercion -> Message
+mkCoAppMsg ty arg_co
+ = vcat [text "Illegal type application:",
+ hang (ptext (sLit "exp type:"))
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+ hang (ptext (sLit "arg type:"))
+ 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))]
+
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 42379b4c0141763505586553ab6ff1cfff5ce369..04057160b8f27d81e545c24e80c25a5d239d47ca 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -37,6 +37,7 @@ import OrdList
import ErrUtils
import DynFlags
import Util
+import Pair
import Outputable
import MonadUtils
import FastString
@@ -78,9 +79,9 @@ The goal of this pass is to prepare for code generation.
weaker guarantee of no clashes which the simplifier provides.
And that is what the code generator needs.
- We don't clone TyVars. The code gen doesn't need that,
+ We don't clone TyVars or CoVars. The code gen doesn't need that,
and doing so would be tiresome because then we'd need
- to substitute in types.
+ to substitute in types and coercions.
7. Give each dynamic CCall occurrence a fresh unique; this is
@@ -104,19 +105,21 @@ Invariants
Here is the syntax of the Core produced by CorePrep:
Trivial expressions
- triv ::= lit | var | triv ty | /\a. triv | triv |> co
+ triv ::= lit | var
+ | triv ty | /\a. triv
+ | truv co | /\c. triv | triv |> co
Applications
- app ::= lit | var | app triv | app ty | app |> co
+ app ::= lit | var | app triv | app ty | app co | app |> co
Expressions
body ::= app
| let(rec) x = rhs in body -- Boxed only
| case body of pat -> body
- | /\a. body
+ | /\a. body | /\c. body
| body |> co
- Right hand sides (only place where lambdas can occur)
+ Right hand sides (only place where value lambdas can occur)
rhs ::= /\a.rhs | \x.rhs | body
We define a synonym for each of these non-terminals. Functions
@@ -440,9 +443,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- For example
-- f (g x) ===> ([v = g x], f v)
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
@@ -528,7 +532,7 @@ rhsToBody (Cast e co)
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
- | all isTyCoVar bndrs -- Type lambdas are ok
+ | all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { fn <- newVar (exprType expr)
@@ -579,6 +583,10 @@ cpeApp env expr
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
+ collect_args (App fun arg@(Coercion arg_co)) depth
+ = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+ ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
@@ -608,7 +616,7 @@ cpeApp env expr
-- partial application might be seq'd
collect_args (Cast fun co) depth
- = do { let (_ty1,ty2) = coercionKind co
+ = do { let Pair _ty1 ty2 = coercionKind co
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
@@ -751,11 +759,12 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
+cpe_ExprIsTrivial (Coercion _) = True
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
\end{code}
@@ -1070,7 +1079,7 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
- | isLocalId bndr
+ | isLocalId bndr, not (isCoVar bndr)
= do bndr' <- setVarUnique bndr <$> getUniqueM
-- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
@@ -1082,7 +1091,7 @@ cloneBndr env bndr
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
- -- And we don't clone tyvars
+ -- And we don't clone tyvars, or coercion variables
= return (env, bndr)
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index a229b8c4e986496c41732ed22cd41bdb93d8d723..047e6c337b2553dbc187bbf14f0e27901af943bb 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -12,14 +12,15 @@ module CoreSubst (
-- ** Substituting into expressions and related types
deShadowBinds, substSpec, substRulesForImportedIds,
- substTy, substExpr, substExprSC, substBind, substBindSC,
+ substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
+ substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
- extendSubst, extendSubstList, zapSubstEnv,
+ extendCvSubst, extendCvSubstList,
+ extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
isInScope, setInScope,
delBndr, delBndrs,
@@ -37,18 +38,23 @@ module CoreSubst (
import CoreSyn
import CoreFVs
import CoreUtils
-import PprCore
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import qualified Type
-import Type ( Type, TvSubst(..), TvSubstEnv )
-import Coercion ( isIdentityCoercion )
+import qualified Coercion
+
+ -- We are defining local versions
+import Type hiding ( substTy, extendTvSubst, extendTvSubstList
+ , isInScope, substTyVarBndr )
+import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
+
import OptCoercion ( optCoercion )
+import PprCore ( pprCoreBindings )
import VarSet
import VarEnv
import Id
import Name ( Name )
-import Var ( Var, TyVar, setVarUnique )
+import Var
import IdInfo
import Unique
import UniqSupply
@@ -92,7 +98,8 @@ data Subst
= Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/
-- applying the substitution
IdSubstEnv -- Substitution for Ids
- TvSubstEnv -- Substitution for TyVars
+ TvSubstEnv -- Substitution from TyVars to Types
+ CvSubstEnv -- Substitution from TyCoVars to Coercions
-- INVARIANT 1: See #in_scope_invariant#
-- This is what lets us deal with name capture properly
@@ -126,6 +133,11 @@ In consequence:
* In substIdBndr, we extend the IdSubstEnv only when the unique changes
+* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
+ substExpr does nothing (Note that the above rule for substIdBndr
+ maintains this property. If the incoming envts are both empty, then
+ substituting the type and IdInfo can't change anything.)
+
* In lookupIdSubst, we *must* look up the Id in the in-scope set, because
it may contain non-trivial changes. Example:
(/\a. \x:a. ...x...) Int
@@ -140,7 +152,8 @@ In consequence:
* (However, we don't need to do so for expressions found in the IdSubst
itself, whose range is assumed to be correct wrt the in-scope set.)
-Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
+Why do we make a different choice for the IdSubstEnv than the
+TvSubstEnv and CvSubstEnv?
* For Ids, we change the IdInfo all the time (e.g. deleting the
unfolding), and adding it back later, so using the TyVar convention
@@ -158,70 +171,82 @@ type IdSubstEnv = IdEnv CoreExpr
----------------------------
isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
+isEmptySubst (Subst _ id_env tv_env cv_env)
+ = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
-
-mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs ids = Subst in_scope ids tvs
-
--- getTvSubst :: Subst -> TvSubst
--- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
--- getTvSubstEnv :: Subst -> TvSubstEnv
--- getTvSubstEnv (Subst _ _ tv_env) = tv_env
---
--- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
--- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
+mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
+mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
-- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _ _) = in_scope
+substInScope (Subst in_scope _ _ _) = in_scope
-- | Remove all substitutions for 'Id's and 'Var's that might have been built up
-- while preserving the in-scope set
zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
-- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
extendTvSubst :: Subst -> TyVar -> Type -> Subst
-extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
+extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
-extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also
--- 'extendIdSubst' and 'extendTvSubst'
-extendSubst :: Subst -> Var -> CoreArg -> Subst
-extendSubst (Subst in_scope ids tvs) tv (Type ty)
- = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
-extendSubst (Subst in_scope ids tvs) id expr
- = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
+-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst
+extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)
+
+-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the
+-- 'Subst': see also 'extendCvSubst'
+extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst
+extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst'
+-- | Add a substitution appropriate to the thing being substituted
+-- (whether an expression, type, or coercion). See also
+-- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
+extendSubst :: Subst -> Var -> CoreArg -> Subst
+extendSubst subst var arg
+ = case arg of
+ Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty
+ Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
+ _ -> ASSERT( isId var ) extendIdSubst subst var arg
+
+extendSubstWithVar :: Subst -> Var -> Var -> Subst
+extendSubstWithVar subst v1 v2
+ | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
+ | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
+ | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2)
+
+-- | Add a substitution as appropriate to each of the terms being
+-- substituted (whether expressions, types, or coercions). See also
+-- 'extendSubst'.
extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
extendSubstList subst [] = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _) v
+lookupIdSubst doc (Subst in_scope ids _ _) v
| not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
@@ -231,18 +256,22 @@ lookupIdSubst doc (Subst in_scope ids _) v
-- | Find the substitution for a 'TyVar' in the 'Subst'
lookupTvSubst :: Subst -> TyVar -> Type
-lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+
+-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst'
+lookupCvSubst :: Subst -> CoVar -> Coercion
+lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
delBndr :: Subst -> Var -> Subst
-delBndr (Subst in_scope tvs ids) v
- | isId v = Subst in_scope tvs (delVarEnv ids v)
- | otherwise = Subst in_scope (delVarEnv tvs v) ids
+delBndr (Subst in_scope ids tvs cvs) v
+ | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
+ | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
+ | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
delBndrs :: Subst -> [Var] -> Subst
-delBndrs (Subst in_scope tvs ids) vs
- = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id)
- where
- (vs_id, vs_tv) = partition isId vs
+delBndrs (Subst in_scope ids tvs cvs) vs
+ = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
+ -- Easist thing is just delete all from all!
-- | Simultaneously substitute for a bunch of variables
-- No left-right shadowing
@@ -252,49 +281,51 @@ mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
mkOpenSubst in_scope pairs = Subst in_scope
(mkVarEnv [(id,e) | (id, e) <- pairs, isId id])
(mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+ (mkVarEnv [(v,co) | (v, Coercion co) <- pairs])
------------------------------
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
-- | Add the 'Var' to the in-scope set, but do not remove
-- any existing substitutions for it
addInScopeSet :: Subst -> VarSet -> Subst
-addInScopeSet (Subst in_scope ids tvs) vs
- = Subst (in_scope `extendInScopeSetSet` vs) ids tvs
+addInScopeSet (Subst in_scope ids tvs cvs) vs
+ = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
-- | Add the 'Var' to the in-scope set: as a side effect,
-- and remove any existing substitutions for it
extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
+extendInScope (Subst in_scope ids tvs cvs) v
= Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs) vs
+extendInScopeList (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
+ (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
-- | Optimized version of 'extendInScopeList' that can be used if you are certain
--- all the things being added are 'Id's and hence none are 'TyVar's
+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs
+extendInScopeIds (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) tvs
+ (ids `delVarEnvList` vs) tvs cvs
setInScope :: Subst -> InScopeSet -> Subst
-setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs
+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
\end{code}
Pretty printing, for debugging only
\begin{code}
instance Outputable Subst where
- ppr (Subst in_scope ids tvs)
+ ppr (Subst in_scope ids tvs cvs)
= ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
$$ ptext (sLit " IdSubst =") <+> ppr ids
$$ ptext (sLit " TvSubst =") <+> ppr tvs
+ $$ ptext (sLit " CvSubst =") <+> ppr cvs
<> char '>'
\end{code}
@@ -326,10 +357,11 @@ subst_expr subst expr
where
go (Var v) = lookupIdSubst (text "subst_expr") subst v
go (Type ty) = Type (substTy subst ty)
+ go (Coercion co) = Coercion (substCo subst co)
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
- go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co)
+ go (Cast e co) = Cast (go e) (substCo subst co)
-- Do not optimise even identity coercions
-- Reason: substitution applies to the LHS of RULES, and
-- if you "optimise" an identity coercion, you may
@@ -416,8 +448,9 @@ preserve occ info in rules.
-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
- | isTyCoVar bndr = substTyVarBndr subst bndr
- | otherwise = substIdBndr (text "var-bndr") subst subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | isCoVar bndr = substCoVarBndr subst bndr
+ | otherwise = substIdBndr (text "var-bndr") subst subst bndr
-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
substBndrs :: Subst -> [Var] -> (Subst, [Var])
@@ -439,9 +472,9 @@ substIdBndr :: SDoc
-> (Subst, Id) -- ^ Transformed pair
-- NB: unfolding may be zapped
-substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
= -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
- (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
id2 | no_type_change = id1
@@ -498,8 +531,8 @@ clone_id :: Subst -- Substitution for the IdInfo
-> Subst -> (Id, Unique) -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
-clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
@@ -510,26 +543,40 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
%************************************************************************
%* *
- Types
+ Types and Coercions
%* *
%************************************************************************
-For types we just call the corresponding function in Type, but we have
-to repackage the substitution, from a Subst to a TvSubst
+For types and coercions we just call the corresponding functions in
+Type and Coercion, but we have to repackage the substitution, from a
+Subst to a TvSubst.
\begin{code}
substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
-substTyVarBndr (Subst in_scope id_env tv_env) tv
+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
= case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
(TvSubst in_scope' tv_env', tv')
- -> (Subst in_scope' id_env tv_env', tv')
+ -> (Subst in_scope' id_env tv_env' cv_env, tv')
+
+substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
+ = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
+ (CvSubst in_scope' tv_env' cv_env', cv')
+ -> (Subst in_scope' id_env tv_env' cv_env', cv')
-- | See 'Type.substTy'
substTy :: Subst -> Type -> Type
substTy subst ty = Type.substTy (getTvSubst subst) ty
getTvSubst :: Subst -> TvSubst
-getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
+getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv
+
+getCvSubst :: Subst -> CvSubst
+getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
+
+-- | See 'Coercion.substCo'
+substCo :: Subst -> Coercion -> Coercion
+substCo subst co = Coercion.substCo (getCvSubst subst) co
\end{code}
@@ -541,8 +588,8 @@ getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
\begin{code}
substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst _ _ tv_env) id
- | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
+substIdType subst@(Subst _ _ tv_env cv_env) id
+ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
| otherwise = setIdType id (substTy subst old_ty)
-- The tyVarsOfType is cheaper than it looks
-- because we cache the free tyvars of the type
@@ -555,7 +602,7 @@ substIdType subst@(Subst _ _ tv_env) id
substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo subst new_id info
| nothing_to_do = Nothing
- | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
+ | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
`setUnfoldingInfo` substUnfolding subst old_unf)
where
old_rules = specInfo info
@@ -594,7 +641,7 @@ substUnfolding _ unf = unf -- NoUnfolding, OtherCon
-------------------
substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
-substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
| Just wkr_expr <- lookupVarEnv ids wkr
= case wkr_expr of
Var w1 -> InlineWrapper w1
@@ -628,7 +675,7 @@ substSpec subst new_id (SpecInfo rules rhs_fvs)
where
subst_ru_fn = const (idName new_id)
new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
- (substVarSet subst rhs_fvs)
+ (substVarSet subst rhs_fvs)
------------------
substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
@@ -646,7 +693,6 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
-- - Rules for *local* Ids are in the IdInfo for that Id,
-- and the ru_fn field is simply replaced by the new name
-- of the Id
-
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = fn_name, ru_rhs = rhs
@@ -664,7 +710,7 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
------------------
substVarSet :: Subst -> VarSet -> VarSet
-substVarSet subst fvs
+substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
@@ -713,7 +759,7 @@ simpleOptExpr expr
-- won't *be* substituting for x if it occurs inside a
-- lambda.
--
- -- It's a bit painful to call exprFreeVars, because it makes
+ -- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
simpleOptExprWith :: Subst -> InExpr -> OutExpr
@@ -747,19 +793,22 @@ type OutExpr = CoreExpr
-- In these functions the substitution maps InVar -> OutExpr
----------------------
-simple_opt_expr :: Subst -> InExpr -> OutExpr
-simple_opt_expr subst expr
+simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
+simple_opt_expr s e = simple_opt_expr' s e
+
+simple_opt_expr' subst expr
= go expr
where
go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
go (App e1 e2) = simple_app subst e1 [go e2]
- go (Type ty) = Type (substTy subst ty)
+ go (Type ty) = Type (substTy subst ty)
+ go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co)
go (Lit lit) = Lit lit
go (Note note e) = Note note (go e)
- go (Cast e co) | isIdentityCoercion co' = go e
- | otherwise = Cast (go e) co'
+ go (Cast e co) | isReflCo co' = go e
+ | otherwise = Cast (go e) co'
where
- co' = substTy subst co
+ co' = optCoercion (getCvSubst subst) co
go (Let bind body) = case simple_opt_bind subst bind of
(subst', Nothing) -> simple_opt_expr subst' body
@@ -806,21 +855,25 @@ simple_app subst e as
= foldl App (simple_opt_expr subst e) as
----------------------
-simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
-simple_opt_bind subst (Rec prs)
- = (subst'', Just (Rec (reverse rev_prs')))
+simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind s b -- Can add trace stuff here
+ = simple_opt_bind' s b
+
+simple_opt_bind' subst (Rec prs)
+ = (subst'', res_bind)
where
+ res_bind = Just (Rec (reverse rev_prs'))
(subst', bndrs') = subst_opt_bndrs subst (map fst prs)
(subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
do_pr (subst, prs) ((b,r), b')
= case maybe_substitute subst b r2 of
Just subst' -> (subst', prs)
- Nothing -> (subst, (b2,r2):prs)
+ Nothing -> (subst, (b2,r2):prs)
where
b2 = add_info subst b b'
r2 = simple_opt_expr subst r
-simple_opt_bind subst (NonRec b r)
+simple_opt_bind' subst (NonRec b r)
= case maybe_substitute subst b r' of
Just ext_subst -> (ext_subst, Nothing)
Nothing -> (subst', Just (NonRec b2 r'))
@@ -836,10 +889,14 @@ maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
-- or returns Nothing
maybe_substitute subst b r
| Type ty <- r -- let a::* = TYPE ty in <body>
- = ASSERT( isTyCoVar b )
+ = ASSERT( isTyVar b )
Just (extendTvSubst subst b ty)
- | isId b -- let x = e in <body>
+ | Coercion co <- r
+ = ASSERT( isCoVar b )
+ Just (extendCvSubst subst b co)
+
+ | isId b -- let x = e in <body>
, safe_to_inline (idOccInfo b)
, isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
, not (isStableUnfolding (idUnfolding b))
@@ -859,19 +916,20 @@ maybe_substitute subst b r
----------------------
subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
subst_opt_bndr subst bndr
- | isTyCoVar bndr = substTyVarBndr subst bndr
- | otherwise = subst_opt_id_bndr subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | isCoVar bndr = substCoVarBndr subst bndr
+ | otherwise = subst_opt_id_bndr subst bndr
subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
-- Nuke all fragile IdInfo, unfolding, and RULES;
-- it gets added back later by add_info
-- Rather like SimplEnv.substIdBndr
--
--- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
-- carefully does not do) because simplOptExpr invalidates it
-subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
- = (Subst new_in_scope new_id_subst tv_subst, new_id)
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
+ = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
where
id1 = uniqAway in_scope old_id
id2 = setIdType id1 (substTy subst (idType old_id))
@@ -894,9 +952,9 @@ subst_opt_bndrs subst bndrs
----------------------
add_info :: Subst -> InVar -> OutVar -> OutVar
-add_info subst old_bndr new_bndr
- | isTyCoVar old_bndr = new_bndr
- | otherwise = maybeModifyIdInfo mb_new_info new_bndr
+add_info subst old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise = maybeModifyIdInfo mb_new_info new_bndr
where
mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
\end{code}
@@ -920,3 +978,4 @@ we don't know what phase we're in. Here's an example
When inlining 'foo' in 'bar' we want the let-binding for 'inner'
to remain visible until Phase 1
+
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 603b745cf2547e4a8c14894f7396f5dd502c5db1..e754c6dda5d7e936a6aa3e4a8c5feb812eee8a87 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -15,7 +15,7 @@ module CoreSyn (
-- ** 'Expr' construction
mkLets, mkLams,
- mkApps, mkTyApps, mkVarApps,
+ mkApps, mkTyApps, mkCoApps, mkVarApps,
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
@@ -23,18 +23,19 @@ module CoreSyn (
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
- mkConApp, mkTyBind,
+ mkConApp, mkTyBind, mkCoBind,
varToCoreExpr, varsToCoreExprs,
- isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
+ isId, cmpAltCon, cmpAlt, ltAlt,
-- ** Simple 'Expr' access functions and predicates
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, coreExprCc, flattenBinds,
- isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
- notSccNote,
+ isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+ isRuntimeArg, isRuntimeVar,
+ notSccNote,
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
@@ -95,7 +96,7 @@ import Util
import Data.Data
import Data.Word
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
\end{code}
@@ -239,6 +240,8 @@ data Expr b
| Type Type -- ^ A type: this should only show up at the top
-- level of an Arg
+
+ | Coercion Coercion -- ^ A coercion
deriving (Data, Typeable)
-- | Type synonym for expressions that occur in function argument positions.
@@ -878,6 +881,8 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
mkApps :: Expr b -> [Arg b] -> Expr b
-- | Apply a list of type argument expressions to a function expression in a nested fashion
mkTyApps :: Expr b -> [Type] -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps :: Expr b -> [Coercion] -> Expr b
-- | Apply a list of type or value variables to a function expression in a nested fashion
mkVarApps :: Expr b -> [Var] -> Expr b
-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
@@ -886,6 +891,7 @@ mkConApp :: DataCon -> [Arg b] -> Expr b
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
+mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
@@ -956,10 +962,16 @@ mkLets binds body = foldr Let body binds
mkTyBind :: TyVar -> Type -> CoreBind
mkTyBind tv ty = NonRec tv (Type ty)
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co = NonRec cv (Coercion co)
+
-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v = Var v
- | otherwise = Type (mkTyVarTy v)
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+ | isCoVar v = Coercion (mkCoVarCo v)
+ | otherwise = ASSERT( isId v ) Var v
varsToCoreExprs :: [CoreBndr] -> [Expr b]
varsToCoreExprs vs = map varToCoreExpr vs
@@ -1025,7 +1037,7 @@ collectTyAndValBinders expr
collectTyBinders expr
= go [] expr
where
- go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e
go tvs e = (reverse tvs, e)
collectValBinders expr
@@ -1076,15 +1088,23 @@ isRuntimeVar = isId
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg = isValArg
--- | Returns @False@ iff the expression is a 'Type' expression at its top level
+-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
isValArg :: Expr b -> Bool
-isValArg (Type _) = False
-isValArg _ = True
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {}) = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _ = False
--- | Returns @True@ iff the expression is a 'Type' expression at its top level
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level. Note this does NOT include 'Coercion's.
isTypeArg :: Expr b -> Bool
-isTypeArg (Type _) = True
-isTypeArg _ = False
+isTypeArg (Type {}) = True
+isTypeArg _ = False
-- | The number of binders that bind values rather than types
valBndrCount :: [CoreBndr] -> Int
@@ -1114,9 +1134,10 @@ seqExpr (App f a) = seqExpr f `seq` seqExpr a
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
-seqExpr (Cast e co) = seqExpr e `seq` seqType co
+seqExpr (Cast e co) = seqExpr e `seq` seqCo co
seqExpr (Note n e) = seqNote n `seq` seqExpr e
-seqExpr (Type t) = seqType t
+seqExpr (Type t) = seqType t
+seqExpr (Coercion co) = seqCo co
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
@@ -1170,9 +1191,11 @@ data AnnExpr' bndr annot
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
| AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
- | AnnCast (AnnExpr bndr annot) Coercion
+ | AnnCast (AnnExpr bndr annot) (annot, Coercion)
+ -- Put an annotation on the (root of) the coercion
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
+ | AnnCoercion Coercion
-- | A clone of the 'Alt' type but allowing annotation at every tree node
type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
@@ -1199,12 +1222,13 @@ deAnnotate :: AnnExpr bndr annot -> Expr bndr
deAnnotate (_, e) = deAnnotate' e
deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
-deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnCoercion co) = Coercion co
deAnnotate' (AnnVar v) = Var v
deAnnotate' (AnnLit lit) = Lit lit
deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
+deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co
deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
deAnnotate' (AnnLet bind body)
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 582f873d18dfbe0e0f07ec1e9cb6574011d2f827..377bfd8c84cf9dabee556fb58bda0076922ded08 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -17,7 +17,7 @@ import CoreSyn
import CoreArity
import Id
import IdInfo
-import TcType( tidyType, tidyTyVarBndr )
+import TcType( tidyType, tidyCo, tidyTyVarBndr )
import Var
import VarEnv
import UniqFM
@@ -55,11 +55,12 @@ tidyBind env (Rec prs)
------------ Expressions --------------
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
tidyExpr env (Var v) = Var (tidyVarOcc env v)
-tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Coercion co) = Coercion (tidyCo env co)
tidyExpr _ (Lit lit) = Lit lit
tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
-tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyType env co)
+tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co)
tidyExpr env (Let b e)
= tidyBind env b =: \ (env', b') ->
@@ -125,7 +126,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
-- tidyBndr is used for lambda and case binders
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
- | isTyCoVar var = tidyTyVarBndr env var
+ | isTyVar var = tidyTyVarBndr env var
| otherwise = tidyIdBndr env var
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index d1b9fa04129de2a724ef9eb90f68a4f01a907a05..051e767d96dcb715263f6c7cce7ad7e8aa22c0f0 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -60,9 +60,12 @@ import PrelNames
import VarEnv ( mkInScopeSet )
import Bag
import Util
+import Pair
import FastTypes
import FastString
import Outputable
+import ForeignCall
+
import Data.Maybe
\end{code}
@@ -107,7 +110,7 @@ mkWwInlineRule id expr arity
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding InlineCompulsory True
- expr 0 -- Arity of unfolding doesn't matter
+ (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter
(UnfWhen unSaturatedOk boringCxtOk)
mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
@@ -272,6 +275,9 @@ Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's
a function call to account for. Notice also that constructor applications
are very cheap, because exposing them to a caller is so valuable.
+[25/5/11] All sizes are now multiplied by 10, except for primops.
+This makes primops look cheap, and seems to be almost unversally
+beneficial. Done partly as a result of #4978.
Note [Do not inline top-level bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -329,7 +335,7 @@ uncondInline :: Arity -> Int -> Bool
-- See Note [INLINE for small functions]
uncondInline arity size
| arity == 0 = size == 0
- | otherwise = size <= arity + 1
+ | otherwise = size <= 10 * (arity + 1)
\end{code}
@@ -348,27 +354,29 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (Cast e _) = size_up e
size_up (Note _ e) = size_up e
size_up (Type _) = sizeZero -- Types cost nothing
+ size_up (Coercion _) = sizeZero
size_up (Lit lit) = sizeN (litSize lit)
size_up (Var f) = size_up_call f [] -- Make sure we get constructor
-- discounts even on nullary constructors
size_up (App fun (Type _)) = size_up fun
+ size_up (App fun (Coercion _)) = size_up fun
size_up (App fun arg) = size_up arg `addSizeNSD`
size_up_app fun [arg]
- size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
+ size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 10)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
= size_up rhs `addSizeNSD`
size_up body `addSizeN`
- (if isUnLiftedType (idType binder) then 0 else 1)
+ (if isUnLiftedType (idType binder) then 0 else 10)
-- For the allocation
-- If the binder has an unlifted type there is no allocation
size_up (Let (Rec pairs) body)
= foldr (addSizeNSD . size_up . snd)
- (size_up body `addSizeN` length pairs) -- (length pairs) for the allocation
+ (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation
pairs
size_up (Case (Var v) _ _ alts)
@@ -385,7 +393,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
(SizeIs max _ _) -- Size of biggest alternative
- = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut
+ = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
@@ -395,20 +403,46 @@ sizeExpr bOMB_OUT_SIZE top_args expr
alts_size tot_size _ = tot_size
- size_up (Case e _ _ alts) = size_up e `addSizeNSD`
- foldr (addAltSize . size_up_alt) sizeZero alts
- -- We don't charge for the case itself
- -- It's a strict thing, and the price of the call
- -- is paid by scrut. Also consider
- -- case f x of DEFAULT -> e
- -- This is just ';'! Don't charge for it.
- --
- -- Moreover, we charge one per alternative.
+ size_up (Case e _ _ alts) = size_up e `addSizeNSD`
+ foldr (addAltSize . size_up_alt) case_size alts
+ where
+ case_size
+ | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10)
+ | otherwise = sizeZero
+ -- Normally we don't charge for the case itself, but
+ -- we charge one per alternative (see size_up_alt,
+ -- below) to account for the cost of the info table
+ -- and comparisons.
+ --
+ -- However, in certain cases (see is_inline_scrut
+ -- below), no code is generated for the case unless
+ -- there are multiple alts. In these cases we
+ -- subtract one, making the first alt free.
+ -- e.g. case x# +# y# of _ -> ... should cost 1
+ -- case touch# x# of _ -> ... should cost 0
+ -- (see #4978)
+ --
+ -- I would like to not have the "not (lengthExceeds alts 1)"
+ -- condition above, but without that some programs got worse
+ -- (spectral/hartel/event and spectral/para). I don't fully
+ -- understand why. (SDM 24/5/11)
+
+ -- unboxed variables, inline primops and unsafe foreign calls
+ -- are all "inline" things:
+ is_inline_scrut (Var v) = isUnLiftedType (idType v)
+ is_inline_scrut scrut
+ | (Var f, _) <- collectArgs scrut
+ = case idDetails f of
+ FCallId fc -> not (isSafeForeignCall fc)
+ PrimOpId op -> not (primOpOutOfLine op)
+ _other -> False
+ | otherwise
+ = False
------------
-- size_up_app is used when there's ONE OR MORE value args
size_up_app (App fun arg) args
- | isTypeArg arg = size_up_app fun args
+ | isTyCoArg arg = size_up_app fun args
| otherwise = size_up arg `addSizeNSD`
size_up_app fun (arg:args)
size_up_app (Var fun) args = size_up_call fun args
@@ -418,14 +452,14 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up_call :: Id -> [CoreExpr] -> ExprSize
size_up_call fun val_args
= case idDetails fun of
- FCallId _ -> sizeN opt_UF_DearOp
+ FCallId _ -> sizeN (10 * (1 + length val_args))
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op -> primOpSize op (length val_args)
ClassOpId _ -> classOpSize top_args val_args
_ -> funSize top_args fun (length val_args)
------------
- size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1
+ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
@@ -461,7 +495,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
-litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
+litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4)
-- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless
-- duplication of little strings]
@@ -476,7 +510,7 @@ classOpSize _ []
classOpSize top_args (arg1 : other_args)
= SizeIs (iUnbox size) arg_discount (_ILIT(0))
where
- size = 2 + length other_args
+ size = 20 + (10 * length other_args)
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
-- The actual discount is rather arbitrarily chosen
@@ -504,8 +538,7 @@ funSize top_args fun n_val_args
res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
| otherwise = 0
-- If the function is partially applied, show a result discount
-
- size | some_val_args = 1 + n_val_args
+ size | some_val_args = 10 * (1 + n_val_args)
| otherwise = 0
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
@@ -514,16 +547,17 @@ funSize top_args fun n_val_args
conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args
- | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables
-
--- See Note [Constructor size]
- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+ | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables
-- See Note [Unboxed tuple result discount]
--- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
+ | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args)))
-- See Note [Constructor size]
- | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+ | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args)))
+ -- discont was (10 * (1 + n_val_args)), but it turns out that
+ -- adding a bigger constant here is an unambiguous win. We
+ -- REALLY like unfolding constructors that get scrutinised.
+ -- [SDM, 25/5/11]
\end{code}
Note [Constructor size]
@@ -554,23 +588,15 @@ didn't adopt the idea.
\begin{code}
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
- | not (primOpIsDupable op) = sizeN opt_UF_DearOp
- | not (primOpOutOfLine op) = sizeN 1
- -- Be very keen to inline simple primops.
- -- We give a discount of 1 for each arg so that (op# x y z) costs 2.
- -- We can't make it cost 1, else we'll inline let v = (op# x y z)
- -- at every use of v, which is excessive.
- --
- -- A good example is:
- -- let x = +# p q in C {x}
- -- Even though x get's an occurrence of 'many', its RHS looks cheap,
- -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
-
- | otherwise = sizeN n_val_args
+ = if primOpOutOfLine op
+ then sizeN (op_size + n_val_args)
+ else sizeN op_size
+ where
+ op_size = primOpCodeSize op
buildSize :: ExprSize
-buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- We really want to inline applications of build
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
-- Indeed, we should add a result_discount becuause build is
@@ -579,7 +605,7 @@ buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
-- The "4" is rather arbitrary.
augmentSize :: ExprSize
-augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
@@ -711,7 +737,7 @@ certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals,
UnfNever -> False
UnfWhen {} -> True
UnfIfGoodArgs { ug_size = size}
- -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
+ -> is_cheap && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold
certainlyWillInline _
= False
@@ -1059,10 +1085,10 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
-- *efficiency* to be gained (e.g. beta reductions, case reductions)
-- by inlining.
- = 1 -- Discount of 1 because the result replaces the call
+ = 10 -- Discount of 1 because the result replaces the call
-- so we count 1 for the function itself
- + length (take n_vals_wanted arg_infos)
+ + 10 * length (take n_vals_wanted arg_infos)
-- Discount of (un-scaled) 1 for each arg supplied,
-- because the result replaces the call
@@ -1072,13 +1098,13 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
mk_arg_discount _ TrivArg = 0
- mk_arg_discount _ NonTrivArg = 1
+ mk_arg_discount _ NonTrivArg = 10
mk_arg_discount discount ValueArg = discount
res_discount' = case cont_info of
BoringCtxt -> 0
CaseCtxt -> res_discount
- _other -> 4 `min` res_discount
+ _other -> 40 `min` res_discount
-- res_discount can be very large when a function returns
-- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
@@ -1147,12 +1173,14 @@ interestingArg e = go e 0
conlike_unfolding = isConLikeUnfolding (idUnfolding v)
go (Type _) _ = TrivArg
- go (App fn (Type _)) n = go fn n
+ go (Coercion _) _ = TrivArg
+ go (App fn (Type _)) n = go fn n
+ go (App fn (Coercion _)) n = go fn n
go (App fn _) n = go fn (n+1)
go (Note _ a) n = go a n
go (Cast e _) n = go e n
go (Lam v e) n
- | isTyCoVar v = go e n
+ | isTyVar v = go e n
| n>0 = go e (n-1)
| otherwise = ValueArg
go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
@@ -1208,7 +1236,7 @@ exprIsConApp_maybe id_unf (Cast expr co)
Nothing -> Nothing ;
Just (dc, _dc_univ_args, dc_args) ->
- let (_from_ty, to_ty) = coercionKind co
+ let Pair _from_ty to_ty = coercionKind co
dc_tc = dataConTyCon dc
in
case splitTyConApp_maybe to_ty of {
@@ -1228,41 +1256,28 @@ exprIsConApp_maybe id_unf (Cast expr co)
dc_ex_tyvars = dataConExTyVars dc
arg_tys = dataConRepArgTys dc
- dc_eqs :: [(Type,Type)] -- All equalities from the DataCon
- dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++
- [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
-
- (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args
- (co_args, val_args) = splitAtList dc_eqs rest1
+ (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
- theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
- (gammas ++ stripTypeArgs ex_args)
-
- -- Cast the existential coercion arguments
- cast_co (ty1, ty2) (Type co)
- = Type $ mkSymCoercion (substTy theta ty1)
- `mkTransCoercion` co
- `mkTransCoercion` (substTy theta ty2)
- cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
- new_co_args = zipWith cast_co dc_eqs co_args
-
+ theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+ (gammas ++ map mkReflCo (stripTypeArgs ex_args))
+
-- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args
- cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+ cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg
in
#ifdef DEBUG
let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
ppr ex_args, ppr val_args]
in
- ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
- ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
+ ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+ ASSERT2( all isTypeArg ex_args, dump_doc )
ASSERT2( equalLength val_args arg_tys, dump_doc )
#endif
- Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
+ Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
}}
exprIsConApp_maybe id_unf expr
@@ -1301,7 +1316,7 @@ exprIsConApp_maybe id_unf expr
-----------
beta (Lam v body) pairs (arg : args)
- | isTypeArg arg
+ | isTyCoArg arg
= beta body ((v,arg):pairs) args
beta (Lam {}) _ _ -- Un-saturated, or not a type lambda
@@ -1313,10 +1328,10 @@ exprIsConApp_maybe id_unf expr
subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
-- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
-
stripTypeArgs :: [CoreExpr] -> [Type]
stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
[ty | Type ty <- args]
+ -- We really do want isTypeArg here, not isTyCoArg!
\end{code}
Note [Unfolding DFuns]
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 70e1db7e2aaf7d2efe4cf4a606f0cbb8b784d261..4146b621e158df90d53bcb01ad7346e0a3203726 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -16,7 +16,7 @@ Utility functions on @Core@ syntax
-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
- mkSCC, mkCoerce, mkCoerceI,
+ mkSCC, mkCoerce,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
@@ -45,7 +45,7 @@ module CoreUtils (
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
- dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
+ dataConRepInstPat, dataConRepFSInstPat
) where
#include "HsVersions.h"
@@ -62,7 +62,6 @@ import DataCon
import PrimOp
import Id
import IdInfo
-import TcType ( isPredTy )
import Type
import Coercion
import TyCon
@@ -73,6 +72,7 @@ import TysPrim
import FastString
import Maybes
import Util
+import Pair
import Data.Word
import Data.Bits
\end{code}
@@ -91,9 +91,10 @@ exprType :: CoreExpr -> Type
-- really be said to have a type
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
+exprType (Coercion co) = coercionType co
exprType (Let _ body) = exprType body
exprType (Case _ _ ty _) = ty
-exprType (Cast _ co) = snd (coercionKind co)
+exprType (Cast _ co) = pSnd (coercionKind co)
exprType (Note _ e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
@@ -110,7 +111,7 @@ coreAltType (_,bs,rhs)
where
ty = exprType rhs
free_tvs = tyVarsOfType ty
- bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
+ bad_binder b = isTyVar b && b `elemVarSet` free_tvs
coreAltsType :: [CoreAlt] -> Type
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -143,10 +144,10 @@ Various possibilities suggest themselves:
we are doing here. It's not too expensive, I think.
\begin{code}
-mkPiType :: EvVar -> Type -> Type
+mkPiType :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- on whether it is given a type variable or a term variable.
-mkPiTypes :: [EvVar] -> Type -> Type
+mkPiTypes :: [Var] -> Type -> Type
-- ^ 'mkPiType' for multiple type or value arguments
mkPiType v ty
@@ -172,11 +173,11 @@ applyTypeToArgs e op_ty (Type ty : args)
go [ty] args
where
go rev_tys (Type ty : args) = go (ty:rev_tys) args
- go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
- where
- op_ty' = applyTysD msg op_ty (reverse rev_tys)
- msg = ptext (sLit "applyTypeToArgs") <+>
- panic_msg e op_ty
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTysD msg op_ty (reverse rev_tys)
+ msg = ptext (sLit "applyTypeToArgs") <+>
+ panic_msg e op_ty
applyTypeToArgs e op_ty (_ : args)
= case (splitFunTy_maybe op_ty) of
@@ -194,25 +195,22 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
%************************************************************************
\begin{code}
--- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
-mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI (IdCo _) e = e
-mkCoerceI (ACo co) e = mkCoerce co e
-
--- | Wrap the given expression in the coercion safely, coalescing nested coercions
+-- | Wrap the given expression in the coercion safely, dropping
+-- identity coercions and coalescing nested coercions
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
+mkCoerce co e | isReflCo co = e
mkCoerce co (Cast expr co2)
- = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
- (_from_ty2, to_ty2) = coercionKind co2} in
- from_ty `coreEqType` to_ty2 )
- mkCoerce (mkTransCoercion co2 co) expr
+ = ASSERT(let { Pair from_ty _to_ty = coercionKind co;
+ Pair _from_ty2 to_ty2 = coercionKind co2} in
+ from_ty `eqType` to_ty2 )
+ mkCoerce (mkTransCo co2 co) expr
mkCoerce co expr
- = let (from_ty, _to_ty) = coercionKind co in
--- if to_ty `coreEqType` from_ty
+ = let Pair from_ty _to_ty = coercionKind co in
+-- if to_ty `eqType` from_ty
-- then expr
-- else
- WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+ WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
(Cast expr co)
\end{code}
@@ -415,7 +413,8 @@ discount.
\begin{code}
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
-exprIsTrivial (Type _) = True
+exprIsTrivial (Type _) = True
+exprIsTrivial (Coercion _) = True
exprIsTrivial (Lit lit) = litIsTrivial lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial]
@@ -469,10 +468,11 @@ exprIsDupable e
= isJust (go dupAppSize e)
where
go :: Int -> CoreExpr -> Maybe Int
- go n (Type {}) = Just n
- go n (Var {}) = decrement n
- go n (Note _ e) = go n e
- go n (Cast e _) = go n e
+ go n (Type {}) = Just n
+ go n (Coercion {}) = Just n
+ go n (Var {}) = decrement n
+ go n (Note _ e) = go n e
+ go n (Cast e _) = go n e
go n (App f a) | Just n' <- go n a = go n' f
go n (Lit lit) | litIsDupable lit = decrement n
go _ _ = Nothing
@@ -540,13 +540,14 @@ exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in
type CheapAppFun = Id -> Int -> Bool
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
-exprIsCheap' _ (Lit _) = True
-exprIsCheap' _ (Type _) = True
-exprIsCheap' _ (Var _) = True
-exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e
-exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
-exprIsCheap' good_app (Lam x e) = isRuntimeVar x
- || exprIsCheap' good_app e
+exprIsCheap' _ (Lit _) = True
+exprIsCheap' _ (Type _) = True
+exprIsCheap' _ (Coercion _) = True
+exprIsCheap' _ (Var _) = True
+exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e
+exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
+exprIsCheap' good_app (Lam x e) = isRuntimeVar x
+ || exprIsCheap' good_app e
exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
@@ -588,12 +589,10 @@ exprIsCheap' good_app other_expr -- Applications and variables
go _ _ = False
--------------
- go_pap args = all exprIsTrivial args
- -- For constructor applications and primops, check that all
- -- the args are trivial. We don't want to treat as cheap, say,
- -- (1:2:3:4:5:[])
- -- We'll put up with one constructor application, but not dozens
-
+ go_pap args = all (exprIsCheap' good_app) args
+ -- Used to be "all exprIsTrivial args" due to concerns about
+ -- duplicating nested constructor applications, but see #4978.
+
--------------
go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
-- In principle we should worry about primops
@@ -684,8 +683,9 @@ it's applied only to dictionaries.
-- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Lit _) = True
-exprOkForSpeculation (Type _) = True
+exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
+exprOkForSpeculation (Coercion _) = True
exprOkForSpeculation (Var v)
| isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation
@@ -865,12 +865,14 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
-- we could get an infinite loop
is_hnf_like (Lit _) = True
- is_hnf_like (Type _) = True -- Types are honorary Values;
+ is_hnf_like (Type _) = True -- Types are honorary Values;
-- we don't mind copying them
+ is_hnf_like (Coercion _) = True -- Same for coercions
is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e
is_hnf_like (Note _ e) = is_hnf_like e
is_hnf_like (Cast e _) = is_hnf_like e
- is_hnf_like (App e (Type _)) = is_hnf_like e
+ is_hnf_like (App e (Type _)) = is_hnf_like e
+ is_hnf_like (App e (Coercion _)) = is_hnf_like e
is_hnf_like (App e a) = app_is_value e [a]
is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
is_hnf_like _ = False
@@ -896,36 +898,26 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
These InstPat functions go here to avoid circularity between DataCon and Id
\begin{code}
-dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
-dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
-dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
-dataConRepFSInstPat = dataConInstPat dataConRepArgTys
-dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv")))
- where
- dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
- -- Remember to include the existential dictionaries
-
-dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
- -> [FastString] -- A long enough list of FSs to use for names
- -> [Unique] -- An equally long list of uniques, at least one for each binder
- -> DataCon
- -> [Type] -- Types to instantiate the universally quantified tyvars
- -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv")))
+dataConRepFSInstPat = dataConInstPat
+
+dataConInstPat :: [FastString] -- A long enough list of FSs to use for names
+ -> [Unique] -- An equally long list of uniques, at least one for each binder
+ -> DataCon
+ -> [Type] -- Types to instantiate the universally quantified tyvars
+ -> ([TyVar], [Id]) -- Return instantiated variables
-- dataConInstPat arg_fun fss us con inst_tys returns a triple
--- (ex_tvs, co_tvs, arg_ids),
+-- (ex_tvs, arg_ids),
--
-- ex_tvs are intended to be used as binders for existential type args
--
--- co_tvs are intended to be used as binders for coercion args and the kinds
--- of these vars have been instantiated by the inst_tys and the ex_tys
--- The co_tvs include both GADT equalities (dcEqSpec) and
--- programmer-specified equalities (dcEqTheta)
---
-- arg_ids are indended to be used as binders for value arguments,
-- and their types have been instantiated with inst_tys and ex_tys
--- The arg_ids include both dicts (dcDictTheta) and
--- programmer-specified arguments (after rep-ing) (deRepArgTys)
+-- The arg_ids include both evidence and
+-- programmer-specified arguments (both after rep-ing)
--
-- Example.
-- The following constructor T1
@@ -940,29 +932,22 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
--
-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
+-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
--
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
-dataConInstPat arg_fun fss uniqs con inst_tys
- = (ex_bndrs, co_bndrs, arg_ids)
+dataConInstPat fss uniqs con inst_tys
+ = (ex_bndrs, arg_ids)
where
univ_tvs = dataConUnivTyVars con
ex_tvs = dataConExTyVars con
- arg_tys = arg_fun con
- eq_spec = dataConEqSpec con
- eq_theta = dataConEqTheta con
- eq_preds = eqSpecPreds eq_spec ++ eq_theta
+ arg_tys = dataConRepArgTys con
n_ex = length ex_tvs
- n_co = length eq_preds
-- split the Uniques and FastStrings
- (ex_uniqs, uniqs') = splitAt n_ex uniqs
- (co_uniqs, id_uniqs) = splitAt n_co uniqs'
-
- (ex_fss, fss') = splitAt n_ex fss
- (co_fss, id_fss) = splitAt n_co fss'
+ (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
+ (ex_fss, id_fss) = splitAt n_ex fss
-- Make existential type variables
ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
@@ -974,17 +959,9 @@ dataConInstPat arg_fun fss uniqs con inst_tys
-- Make the instantiating substitution
subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
- -- Make new coercion vars, instantiating kind
- co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
- mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
- where
- new_name = mkSysTvName uniq fs
- co_kind = substTy subst (mkPredTy eq_pred)
-
- -- make value vars, instantiating types
- mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+ -- Make value vars, instantiating types
+ mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
-
\end{code}
%************************************************************************
@@ -1003,7 +980,8 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
@@ -1019,7 +997,8 @@ exprIsBig :: Expr b -> Bool
-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
exprIsBig (Lit _) = False
exprIsBig (Var _) = False
-exprIsBig (Type _) = False
+exprIsBig (Type _) = False
+exprIsBig (Coercion _) = False
exprIsBig (Lam _ e) = exprIsBig e
exprIsBig (App f a) = exprIsBig f || exprIsBig a
exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
@@ -1061,14 +1040,15 @@ eqExprX id_unfolding_fun env e1 e2
, Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
= go (nukeRnEnvR env) e1 e2'
- go _ (Lit lit1) (Lit lit2) = lit1 == lit2
- go env (Type t1) (Type t2) = tcEqTypeX env t1 t2
- go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2
+ go _ (Lit lit1) (Lit lit2) = lit1 == lit2
+ go env (Type t1) (Type t2) = eqTypeX env t1 t2
+ go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
+ go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2
go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2
go env (Lam b1 e1) (Lam b2 e2)
- = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
+ = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
&& go (rnBndr2 env b1 b2) e1 e2
go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
@@ -1084,7 +1064,7 @@ eqExprX id_unfolding_fun env e1 e2
go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
= go env e1 e2
- && tcEqTypeX env (idType b1) (idType b2)
+ && eqTypeX env (idType b1) (idType b2)
&& all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
go _ _ _ = False
@@ -1128,16 +1108,17 @@ exprSize (App f a) = exprSize f + exprSize a
exprSize (Lam b e) = varSize b + exprSize e
exprSize (Let b e) = bindSize b + exprSize e
exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
-exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
+exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e
exprSize (Note n e) = noteSize n + exprSize e
-exprSize (Type t) = seqType t `seq` 1
+exprSize (Type t) = seqType t `seq` 1
+exprSize (Coercion co) = seqCo co `seq` 1
noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
-varSize b | isTyCoVar b = 1
+varSize b | isTyVar b = 1
| otherwise = seqType (idType b) `seq`
megaSeqIdInfo (idInfo b) `seq`
1
@@ -1187,30 +1168,23 @@ bndrStats v = oneTM `plusCS` tyStats (varType v)
exprStats :: CoreExpr -> CoreStats
exprStats (Var {}) = oneTM
exprStats (Lit {}) = oneTM
-exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (Type t) = tyStats t
+exprStats (Coercion c) = coStats c
exprStats (App f a) = exprStats f `plusCS` exprStats a
exprStats (Lam b e) = bndrStats b `plusCS` exprStats e
exprStats (Let b e) = bindStats b `plusCS` exprStats e
exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
exprStats (Cast e co) = coStats co `plusCS` exprStats e
exprStats (Note _ e) = exprStats e
-exprStats (Type ty) = zeroCS { cs_ty = typeSize ty }
- -- Ugh (might be a co)
altStats :: CoreAlt -> CoreStats
altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
-tyCoStats :: Type -> Type -> CoreStats
-tyCoStats fun_ty arg
- = case splitForAllTy_maybe fun_ty of
- Just (tv,_) | isCoVar tv -> coStats arg
- _ -> tyStats arg
-
tyStats :: Type -> CoreStats
tyStats ty = zeroCS { cs_ty = typeSize ty }
coStats :: Coercion -> CoreStats
-coStats co = zeroCS { cs_co = typeSize co }
+coStats co = zeroCS { cs_co = coercionSize co }
\end{code}
%************************************************************************
@@ -1252,15 +1226,17 @@ hash_expr env (Lam b e) = hash_expr (extend_env env b) e
hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
+hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
fast_hash_expr :: HashEnv -> CoreExpr -> Word32
-fast_hash_expr env (Var v) = hashVar env v
-fast_hash_expr env (Type t) = fast_hash_type env t
-fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e _) = fast_hash_expr env e
-fast_hash_expr env (Note _ e) = fast_hash_expr env e
-fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr _ _ = 1
+fast_hash_expr env (Var v) = hashVar env v
+fast_hash_expr env (Type t) = fast_hash_type env t
+fast_hash_expr env (Coercion co) = fast_hash_co env co
+fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _) = fast_hash_expr env e
+fast_hash_expr env (Note _ e) = fast_hash_expr env e
+fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _ _ = 1
fast_hash_type :: HashEnv -> Type -> Word32
fast_hash_type env ty
@@ -1269,6 +1245,13 @@ fast_hash_type env ty
in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
| otherwise = 1
+fast_hash_co :: HashEnv -> Coercion -> Word32
+fast_hash_co env co
+ | Just cv <- getCoVar_maybe co = hashVar env cv
+ | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
+ in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
+ | otherwise = 1
+
extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
extend_env (n,env) b = (n+1, extendVarEnv env b n)
@@ -1368,18 +1351,18 @@ need to address that here.
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
- = go (reverse bndrs) body (IdCo (exprType body))
+ = go (reverse bndrs) body (mkReflCo (exprType body))
where
incoming_arity = count isId bndrs
go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
-> CoreExpr -- Of type tr
- -> CoercionI -- Of type tr ~ ts
+ -> Coercion -- Of type tr ~ ts
-> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
go [] fun co
- | ok_fun fun = Just (mkCoerceI co fun)
+ | ok_fun fun = Just (mkCoerce co fun)
go (b : bs) (App fun arg) co
| Just co' <- ok_arg b arg co
@@ -1390,7 +1373,7 @@ tryEtaReduce bndrs body
---------------
-- Note [Eta reduction conditions]
ok_fun (App fun (Type ty))
- | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+ | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
= ok_fun fun
ok_fun (Var fun_id)
= not (fun_id `elem` bndrs)
@@ -1406,22 +1389,22 @@ tryEtaReduce bndrs body
| otherwise = idArity fun
---------------
- ok_lam v = isTyCoVar v || isDictId v
+ ok_lam v = isTyVar v || isEvVar v
---------------
- ok_arg :: Var -- Of type bndr_t
- -> CoreExpr -- Of type arg_t
- -> CoercionI -- Of kind (t1~t2)
- -> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2)
- -- (and similarly for tyvars, coercion args)
+ ok_arg :: Var -- Of type bndr_t
+ -> CoreExpr -- Of type arg_t
+ -> Coercion -- Of kind (t1~t2)
+ -> Maybe Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
+ -- (and similarly for tyvars, coercion args)
-- See Note [Eta reduction with casted arguments]
ok_arg bndr (Type ty) co
| Just tv <- getTyVar_maybe ty
- , bndr == tv = Just (mkForAllTyCoI tv co)
+ , bndr == tv = Just (mkForAllCo tv co)
ok_arg bndr (Var v) co
- | bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co)
+ | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
- | bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)
+ | bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index 07a1dfbd8ee1b8bcc7f48a41d2be7ba071425d1d..359419ca0654a1f8f3da9479b60ead108cc10e1c 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -4,7 +4,6 @@
\begin{code}
module ExternalCore where
-
data Module
= Module Mname [Tdef] [Vdefg]
@@ -51,21 +50,21 @@ data Alt
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
+-- Internally, we represent types and coercions separately; but for
+-- the purposes of external core (at least for now) it's still
+-- convenient to collapse them into a single type.
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
--- We distinguish primitive coercions
--- (represented in GHC by wired-in names), because
--- External Core treats them specially, so we have
--- to print them out with special syntax.
+-- We distinguish primitive coercions because External Core treats
+-- them specially, so we have to print them out with special syntax.
| TransCoercion Ty Ty
| SymCoercion Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
- | LeftCoercion Ty
- | RightCoercion Ty
+ | NthCoercion Int Ty
data Kind
= Klifted
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index f1d42738a2740631b13ed398896e80672e4600a9..b6bc7d4b376b3ed4ecd1de34dc794f7183d9c6f0 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -45,8 +45,7 @@ module MkCore (
#include "HsVersions.h"
import Id
-import IdInfo
-import Var ( EvVar, mkWildCoVar, setTyVarUnique )
+import Var ( EvVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
@@ -58,8 +57,10 @@ import PrelNames
import TcType ( mkSigmaTy )
import Type
+import Coercion
import TysPrim
import DataCon ( DataCon, dataConWorkId )
+import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo )
import Demand
import Name
import Outputable
@@ -102,6 +103,7 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
-- Check the invariant that the arg of an App is ok-for-speculation if unlifted
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mk_val_app fun arg arg_ty res_ty
where
@@ -117,6 +119,7 @@ mkCoreApps orig_fun orig_args
where
go fun _ [] = fun
go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
+ go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args
go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
go (mk_val_app fun arg arg_ty res_ty) res_ty args
where
@@ -148,8 +151,7 @@ mk_val_app fun arg arg_ty res_ty
-- fragmet of it as the fun part of a 'mk_val_app'.
mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred@(EqPred {}) = mkWildCoVar (mkPredTy pred)
-mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
-- | Make a /wildcard binder/. This is typically used when you need a binder
-- that you expect to use only at a *binding* site. Do not use it at
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index cb784e8ab4de4f8aa01e5cf87029d8d1dc777662..78df509dd69eaa9f5b8d278fbaaf36b05fe731cd 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -13,6 +13,8 @@ import Module
import CoreSyn
import HscTypes
import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
import TypeRep
import Type
import PprExternalCore () -- Instances
@@ -78,10 +80,7 @@ collect_tdefs tcon tdefs
where
tdef | isNewTyCon tcon =
C.Newtype (qtc tcon)
- (case newTyConCo_maybe tcon of
- Just co -> qtc co
- Nothing -> pprPanic ("MkExternalCore: newtype tcon\
- should have a coercion: ") (ppr tcon))
+ (qcc (newTyConCo tcon))
(map make_tbind tyvars)
(make_ty (snd (newTyConRhs tcon)))
| otherwise =
@@ -94,6 +93,8 @@ collect_tdefs _ tdefs = tdefs
qtc :: TyCon -> C.Qual C.Tcon
qtc = make_con_qid . tyConName
+qcc :: CoAxiom -> C.Qual C.Tcon
+qcc = make_con_qid . co_ax_name
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
@@ -142,15 +143,16 @@ make_exp (Var v) = do
make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = return $ C.Lit (make_lit l)
make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO
make_exp (App e1 e2) = do
rator <- make_exp e1
rand <- make_exp e2
return $ C.App rator rand
-make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b ->
+make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = make_exp e >>= (\ b ->
return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co))
+make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
make_exp (Let b e) = do
vd <- make_vdef False b
body <- make_exp e
@@ -170,7 +172,7 @@ make_alt (DataAlt dcon, vs, e) = do
(map make_tbind tbs)
(map make_vbind vbs)
newE
- where (tbs,vbs) = span isTyCoVar vs
+ where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l)))
make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault)
-- This should never happen, as the DEFAULT alternative binds no variables,
@@ -229,29 +231,12 @@ make_ty' (TyConApp tc ts) = make_tyConApp tc ts
make_ty' (PredTy p) = make_ty (predTypeRep p)
make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
- C.TransCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == symCoercionTyCon =
- C.SymCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
- C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == leftCoercionTyCon =
- C.LeftCoercion (make_ty t)
-make_tyConApp tc [t] | tc == rightCoercionTyCon =
- C.RightCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
- C.InstCoercion (make_ty t1) (make_ty t2)
--- this fails silently if we have an application
--- of a wired-in coercion tycon to the wrong number of args.
--- Not great...
make_tyConApp tc ts =
foldl C.Tapp (C.Tcon (qtc tc))
(map make_ty ts)
-
make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
- where (t1, t2) = getEqPredTys p
+make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted
@@ -299,6 +284,25 @@ make_var_qid force_unqual = make_qid force_unqual True
make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False False
+make_co :: Coercion -> C.Ty
+make_co (Refl ty) = make_ty ty
+make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos
+make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2)
+make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co)
+make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
+make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos
+make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_co (SymCo co) = C.SymCoercion (make_co co)
+make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2)
+make_co (NthCo d co) = C.NthCoercion d (make_co co)
+make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty)
+
+-- Used for both tycon app coercions and axiom instantiations.
+make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo con cos =
+ foldl C.Tapp (C.Tcon con)
+ (map make_co cos)
+
-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 041b842b811bd24797de20852fe8ba1ead6e4088..e9452dcb73a9f38b4b30064fa7192427d6dd7dcb 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
ppr_expr _ (Var name) = ppr name
ppr_expr _ (Lit lit) = ppr lit
@@ -255,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty)
| opt_SuppressTypeApplications = empty
| otherwise = ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr = pprParendExpr expr
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -268,7 +270,7 @@ instance OutputableBndr Var where
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- | isTyCoVar binder = pprKindedTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedBinder binder $$
ppIdInfo binder (idInfo binder)
@@ -279,7 +281,7 @@ pprCoreBinder bind_site bndr
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
- | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
+ | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -287,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
pprTypedLCBinder bind_site debug_on var
| not debug_on && isDeadBinder var = char '_'
| not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info
- | isTyCoVar var = parens (pprKindedTyVarBndr var)
+ | isTyVar var = parens (pprKindedTyVarBndr var)
| otherwise = parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
where
@@ -298,7 +300,7 @@ pprTypedLCBinder bind_site debug_on var
pprTypedBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedBinder binder
- | isTyCoVar binder = pprKindedTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| opt_SuppressTypeSignatures = empty
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 3c4b25e420e3754168a615db229a85ed1751884d..5303b0d1b68ffed31265e510bf9547e3c116a907 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -106,10 +106,8 @@ pty (SymCoercion t) =
sep [text "%sym", paty t]
pty (UnsafeCoercion t1 t2) =
sep [text "%unsafe", paty t1, paty t2]
-pty (LeftCoercion t) =
- sep [text "%left", paty t]
-pty (RightCoercion t) =
- sep [text "%right", paty t]
+pty (NthCoercion n t) =
+ sep [text "%nth", int n, paty t]
pty (InstCoercion t1 t2) =
sep [text "%inst", paty t1, paty t2]
pty t = pbty t
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 2432051c7bc7a638854723b8e4006a852e034fc1..59c102f88446560a4538be428e2db07a9e3482e5 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -27,10 +27,10 @@ import TysWiredIn
import PrelNames
import TyCon
import Type
-import Unify( dataConCannotMatch )
import SrcLoc
import UniqSet
import Util
+import BasicTypes
import Outputable
import FastString
\end{code}
@@ -112,7 +112,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
-- if there are view patterns, just give up - don't know what the function is
check qs = (untidy_warns, shadowed_eqns)
where
- (warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs)
+ tidy_qs = map tidy_eqn qs
+ (warns, used_nos) = check' ([1..] `zip` tidy_qs)
untidy_warns = map untidy_exhaustive warns
shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
not (i `elementOfUniqSet` used_nos)]
@@ -436,14 +437,14 @@ get_lit :: Pat id -> Maybe HsLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing
-mb_neg :: Num a => Maybe b -> a -> a
-mb_neg Nothing v = v
-mb_neg (Just _) v = -v
+mb_neg :: (a -> a) -> Maybe b -> a -> a
+mb_neg _ Nothing v = v
+mb_neg negate (Just _) v = negate v
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
@@ -643,7 +644,7 @@ might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs
-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
-might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat
+might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat
--------------
might_fail_lpat :: LPat Id -> Bool
@@ -671,8 +672,6 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
-tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
-
tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
= pat { pat_args = tidy_con id ps }
@@ -696,16 +695,18 @@ tidy_pat (TuplePat ps boxity ty)
where
arity = length ps
--- Unpack string patterns fully, so we can see when they overlap with
--- each other, or even explicit lists of Chars.
-tidy_pat (LitPat lit)
+tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (LitPat lit) = tidy_lit_pat lit
+
+tidy_lit_pat :: HsLit -> Pat Id
+-- Unpack string patterns fully, so we can see when they
+-- overlap with each other, or even explicit lists of Chars.
+tidy_lit_pat lit
| HsString s <- lit
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
| otherwise
= tidyLitPat lit
- where
- mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
-----------------
tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index b28f3eba3f2e6a42ffe85ab9081cd770161f3e12..37cbc2d5c5c6dd4c4c29cc0e6efcfe79d8c5cb62 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -301,10 +301,9 @@ addTickHsExpr (HsLet binds e) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
- (stmts', last_exp') <- addTickLStmts' forQual stmts
- (addTickLHsExpr last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
@@ -365,6 +364,20 @@ addTickHsExpr (HsWrap w e) =
(return w)
(addTickHsExpr e) -- explicitly no tick on inside
+addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) =
+ liftM5 HsArrApp
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (return ty1)
+ (return arr_ty)
+ (return lr)
+
+addTickHsExpr (HsArrForm e fix cmdtop) =
+ liftM3 HsArrForm
+ (addTickLHsExpr e)
+ (return fix)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
addTickHsExpr e@(HsType _) = return e
-- Others dhould never happen in expression content.
@@ -410,45 +423,50 @@ addTickLStmts isGuard stmts = do
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
- = bindLocals binders $ do
- lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
- a <- res
- return (lstmts', a)
- where
- binders = collectLStmtsBinders lstmts
+ = bindLocals (collectLStmtsBinders lstmts) $
+ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+ ; a <- res
+ ; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt _isGuard (LastStmt e ret) = do
+ liftM2 LastStmt
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' ty) = do
- liftM3 ExprStmt
+addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
+ liftM4 ExprStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs) = do
- liftM ParStmt
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
+ liftM4 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
-
-addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
- liftM4 TransformStmt
- (addTickLStmts isGuard stmts)
- (return ids)
- (addTickLHsExprAlways usingExpr)
- (addTickMaybeByLHsExpr maybeByExpr)
-
-addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
- liftM4 GroupStmt
- (addTickLStmts isGuard stmts)
- (return binderMap)
- (fmapMaybeM addTickLHsExprAlways by)
- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+ (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+ (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+ , trS_by = by, trS_using = using
+ , trS_ret = returnExpr, trS_bind = bindExpr
+ , trS_fmap = liftMExpr }) = do
+ t_s <- addTickLStmts isGuard stmts
+ t_y <- fmapMaybeM addTickLHsExprAlways by
+ t_u <- addTickLHsExprAlways using
+ t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+ t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+ t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+ return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+ , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
@@ -469,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) =
(addTickLStmts isGuard stmts)
(return ids)
-addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
-addTickMaybeByLHsExpr maybeByExpr =
- case maybeByExpr of
- Nothing -> return Nothing
- Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
-
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
@@ -555,10 +567,10 @@ addTickHsCmd (HsLet binds c) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
- (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
- where
+addTickHsCmd (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
+
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
(addTickLHsExpr e1)
@@ -596,9 +608,12 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
-addTickCmdGRHS (GRHS stmts cmd) = do
- (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
- return $ GRHS stmts' expr'
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS stmts cmd)
+ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+ stmts (addTickLHsCmd cmd)
+ ; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts stmts = do
@@ -621,10 +636,15 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
(addTickLHsCmd c)
(return bind)
(return fail)
-addTickCmdStmt (ExprStmt c bind' ty) = do
- liftM3 ExprStmt
+addTickCmdStmt (LastStmt c ret) = do
+ liftM2 LastStmt
+ (addTickLHsCmd c)
+ (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (ExprStmt c bind' guard' ty) = do
+ liftM4 ExprStmt
(addTickLHsCmd c)
- (return bind')
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickCmdStmt (LetStmt binds) = do
liftM LetStmt
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 37a3cf9236ab918572163d197892fa0ffdff7ae1..7b008e9aaf2a4571995e36efd8e9eff4b702d187 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -378,6 +378,8 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList.
That keeps the desugaring of list comprehensions simple too.
+
+
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 58bf6b88e705baa2153a07beda77c0aecede34da..7f798f81f79c55001e6043afe74c7d745e4148bd 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
- = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
- -> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- --------------------------
-- A | xs |- do { c } :: [] t
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
let
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
- (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+ (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
@@ -674,7 +675,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
core_mux <- matchEnvStack env_ids []
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
@@ -1061,7 +1062,6 @@ collectl (L _ pat) bndrs
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 815c0d1cfb2222319b65e8e49b185cedd4b1ba26..65cb8157daaef65e72e26a0e92b9ac83f1628106 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+ dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
DsEvBind(..), AutoScc(..)
) where
@@ -36,6 +36,7 @@ import Digraph
import TcType
import Type
+import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
@@ -230,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs)
free_vars_of :: EvTerm -> [EvVar]
free_vars_of (EvId v) = [v]
- free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
- free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
+ free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co)
+ free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co)
free_vars_of (EvDFunApp _ _ vs) = vs
free_vars_of (EvSuperClass d _) = [d]
@@ -247,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
(arg_tys, _) = splitFunTys rho
bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
++ map mkWildValBinder arg_tys
- mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
+ mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var))
co_var
| otherwise = mkWildEvBinder p
@@ -263,7 +264,7 @@ dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co) = Cast (Var v) co
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co) = Type co
+dsEvTerm (EvCoercion co) = Coercion co
dsEvTerm (EvSuperClass d n)
= ASSERT( isClassPred (classSCTheta cls !! n) )
-- We can only select *dictionary* superclasses
@@ -597,17 +598,13 @@ decomposeRuleLhs bndrs lhs
bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
2 (ppr opt_lhs)
- dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
- <+> ptext (sLit "is not bound in RULE lhs"))
+ dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
+ , ptext (sLit "is not bound in RULE lhs")])
2 (ppr opt_lhs)
pp_bndr bndr
- | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
- | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
- | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
- | otherwise = ptext (sLit "variable") <+> ppr bndr
-
- get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs"
- (tcSplitPredTy_maybe (idType b))
+ | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
+ | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
+ | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
\end{code}
Note [Simplifying the left-hand side of a RULE]
@@ -634,7 +631,6 @@ otherwise we don't match when given an argument like
NB: tcSimplifyRuleLhs is very careful not to generate complicated
dictionary expressions that we might have to match
-
Note [Matching seqId]
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index f46d99e504c111c7e6e73ed2c2c43db8646c4a5c..58ebc26b2b0890342a201ddfc406f5398a15bdbf 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -273,7 +273,7 @@ boxResult result_ty
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
- wrap the_call = mkCoerceI (mkSymCoI co) $
+ wrap the_call = mkCoerce (mkSymCo co) $
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
@@ -372,7 +372,7 @@ resultWrapper result_ty
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
- return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+ return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 1781aef5f842c61db4bba595441e8863b8609eb3..e33b113ae783ddc8ea1f035743d455f245022c2a 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -49,8 +49,8 @@ import DynFlags
import StaticFlags
import CostCentre
import Id
-import Var
import VarSet
+import VarEnv
import DataCon
import TysWiredIn
import BasicTypes
@@ -325,26 +325,12 @@ dsExpr (HsLet binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDo ListComp stmts body result_ty)
- = -- Special case for list comprehensions
- dsListComp stmts body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
-
-dsExpr (HsDo DoExpr stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo GhciStmt stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo MDoExpr stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo PArrComp stmts body result_ty)
- = -- Special case for array comprehensions
- dsPArrComp (map unLoc stmts) body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
+dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr stmts _) = dsDo stmts
+dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
+dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
+dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
@@ -527,12 +513,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
mk_alt upd_fld_env con
= do { let (univ_tvs, ex_tvs, eq_spec,
- eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
+ theta, arg_tys, _) = dataConFullSig con
subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
-- I'm not bothering to clone the ex_tvs
; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
- ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
+ ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
@@ -543,21 +529,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
wrap = mkWpEvVarApps theta_vars `WpCompose`
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
- , isNothing (lookupTyVar wrap_subst tv) ]
+ , not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
-- Tediously wrap the application in a cast
-- Note [Update for GADTs]
wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (WpCast wrap_co) rhs
- wrap_co = mkTyConApp tycon [ lookup tv ty
- | (tv,ty) <- univ_tvs `zip` out_inst_tys]
- lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
- Just ty' -> ty'
- Nothing -> ty
- wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
- | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
-
+ wrap_co = mkTyConAppCo tycon [ lookup tv ty
+ | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+ lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
+ Just co' -> co'
+ Nothing -> mkReflCo ty
+ wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
+ | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+
pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
@@ -597,7 +583,7 @@ dsExpr (HsTick ix vars e) = do
dsExpr (HsBinTick ixT ixF e) = do
e2 <- dsLExpr e
- do { ASSERT(exprType e2 `coreEqType` boolTy)
+ do { ASSERT(exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
\end{code}
@@ -708,25 +694,20 @@ handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
\begin{code}
-dsDo :: [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsDo stmts body result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
= goL stmts
where
- -- result_ty must be of the form (m b)
- (m_ty, _b_ty) = tcSplitAppTy result_ty
-
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ goL [] = panic "dsDo"
+ goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
- go _ (ExprStmt rhs then_expr _) stmts
+ go _ (LastStmt body _) stmts
+ = ASSERT( null stmts ) dsLExpr body
+ -- The 'return' op isn't used for 'do' expressions
+
+ go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
- ; case tcSplitAppTy_maybe (exprType rhs2) of
- Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
- _ -> return ()
+ ; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
@@ -750,29 +731,29 @@ dsDo stmts body result_ty
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_rec_rets = rec_rets }) stmts
+ , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
= ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts)
where
- -- returnE <- dsExpr return_id
- -- mfixE <- dsExpr mfix_id
- new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
- bind_op
+ new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+ mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+ tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
rets = map noLoc rec_rets
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
- mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
- body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+ mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
+ mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+ (mkFunTy tup_ty body_ty))
+ mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+ body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
+ ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+ ret_stmt = noLoc $ mkLastStmt ret_app
+ -- This LastStmt will be desugared with dsDo,
+ -- which ignores the return_op in the LastStmt,
+ -- so we must apply the return_op explicitly
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
@@ -790,104 +771,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++
showSDoc (ppr (getLoc pat))
\end{code}
-Translation for RecStmt's:
------------------------------
-We turn (RecStmt [v1,..vn] stmts) into:
-
- (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
- return (v1,..vn))
-
-\begin{code}
-{-
-dsMDo :: HsStmtContext Name
- -> [(Name,Id)]
- -> [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsMDo ctxt tbl stmts body result_ty
- = goL stmts
- where
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-
- (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- return_id = lookupEvidence tbl returnMName
- bind_id = lookupEvidence tbl bindMName
- then_id = lookupEvidence tbl thenMName
- fail_id = lookupEvidence tbl failMName
-
- go _ (LetStmt binds) stmts
- = do { rest <- goL stmts
- ; dsLocalBinds binds rest }
-
- go _ (ExprStmt rhs then_expr rhs_ty) stmts
- = do { rhs2 <- dsLExpr rhs
- ; warnDiscardedDoBindings rhs m_ty rhs_ty
- ; then_expr2 <- dsExpr then_expr
- ; rest <- goL stmts
- ; return (mkApps then_expr2 [rhs2, rest]) }
-
- go _ (BindStmt pat rhs bind_op _) stmts
- = do { body <- goL stmts
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
- result_ty (cantFailMatchResult body)
- ; match_code <- handle_failure pat match fail_op
- ; return (mkApps bind_op [rhs', Lam var match_code]) }
-
- go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
- , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
- , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
- = ASSERT( length rec_ids > 0 )
- ASSERT( length rec_ids == length rec_rets )
- ASSERT( isEmptyTcEvBinds _ev_binds )
- pprTrace "dsMDo" (ppr later_ids) $
- goL (new_bind_stmt : stmts)
- where
- new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
- bind_op noSyntaxExpr
-
- -- Remove the later_ids that appear (without fancy coercions)
- -- in rec_rets, because there's no need to knot-tie them separately
- -- See Note [RecStmt] in HsExpr
- later_ids' = filter (`notElem` mono_rec_ids) later_ids
- mono_rec_ids = [ id | HsVar id <- rec_rets ]
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
-
- -- The rec_tup_pat must bind the rec_ids only; remember that the
- -- trimmed_laters may share the same Names
- -- Meanwhile, the later_pats must bind the later_vars
- rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
- later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
- rets = map nlHsVar later_ids' ++ map noLoc rec_rets
-
- mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
- body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
-
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-
- mk_wild_pat :: Id -> LPat Id
- mk_wild_pat v = noLoc $ WildPat $ idType v
-
- mk_later_pat :: Id -> LPat Id
- mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
- | otherwise = nlVarPat v
-
- mk_tup_pat :: [LPat Id] -> LPat Id
- mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
--}
-\end{code}
-
%************************************************************************
%* *
@@ -904,7 +787,7 @@ warnAboutIdentities (Var v) co_fn
| idName v `elem` conversionNames
, let fun_ty = exprType (co_fn (Var v))
, Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
- , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty
+ , arg_ty `eqType` res_ty -- So we are converting ty -> ty
= warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
, nest 2 $ ptext (sLit "can probably be omitted")
, parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
@@ -927,30 +810,34 @@ conversionNames
\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
-warnDiscardedDoBindings rhs container_ty returning_ty = do {
- -- Warn about discarding non-() things in 'monadic' binding
- ; warn_unused <- doptDs Opt_WarnUnusedDoBind
- ; if warn_unused && not (returning_ty `tcEqType` unitTy)
- then warnDs (unusedMonadBind rhs returning_ty)
- else do {
- -- Warn about discarding m a things in 'monadic' binding of the same type,
- -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
- ; warn_wrong <- doptDs Opt_WarnWrongDoBind
- ; case tcSplitAppTy_maybe returning_ty of
- Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
- warnDs (wrongMonadBind rhs returning_ty)
- _ -> return () } }
+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+ | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+ = do { -- Warn about discarding non-() things in 'monadic' binding
+ ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+ ; if warn_unused && not (isUnitTy elt_ty)
+ then warnDs (unusedMonadBind rhs elt_ty)
+ else
+ -- Warn about discarding m a things in 'monadic' binding of the same type,
+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+ ; case tcSplitAppTy_maybe elt_ty of
+ Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
+ -> warnDs (wrongMonadBind rhs elt_ty)
+ _ -> return () } }
+
+ | otherwise -- RHS does have type of form (m ty), which is wierd
+ = return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
-unusedMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+unusedMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
-wrongMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+wrongMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
\end{code}
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 4d0a148e1598f2ba80de82a371f92275b3be457e..b391b8f02aaba37f3d3719dd59870639abaece5c 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,7 +28,6 @@ import Type
import TyCon
import Coercion
import TcType
-import Var
import CmmExpr
import CmmUtils
@@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do
IsFunction
_ -> IsData
(resTy, foRhs) <- resultWrapper ty
- ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
+ ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
let
rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
stdcall_info = fun_type_arg_stdcall_info cconv ty
@@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
- let io_app = mkLams tvs $
- Lam cback $
- mkCoerceI (mkSymCoI co) $
+ let io_app = mkLams tvs $
+ Lam cback $
+ mkCoerce (mkSymCo co) $
mkApps (Var bindIOId)
[ Type stable_ptr_ty
, Type res_ty
@@ -483,7 +482,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
typeCmmType (mkStablePtrPrimTy alphaTy))
-- stuff to do with the return type of the C function
- res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
+ res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
cResType | res_hty_is_unit = text "void"
| otherwise = showStgType res_hty
@@ -675,7 +674,7 @@ getPrimTyOf ty
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: Type -> Char
primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
| otherwise
= case typePrimRep (getPrimTyOf ty) of
IntRep -> signed_word
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index a7260e2af86aa24483b5be85016805881a219448..d3fcf76d1c6a86664993f051b67d601f9a0f6a5c 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -106,11 +106,11 @@ matchGuards [] _ rhs _
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
-matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
+matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
-matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index cd22b8ff8c927f999148ddcd8c904c5db7c8ad68..aabd6b0d0d0776ed06632f65f321f55182f9e9b1 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -3,9 +3,10 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-Desugaring list comprehensions and array comprehensions
+Desugaring list comprehensions, monad comprehensions and array comprehensions
\begin{code}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
@@ -13,11 +14,11 @@ Desugaring list comprehensions and array comprehensions
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module DsListComp ( dsListComp, dsPArrComp ) where
+module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import HsSyn
import TcHsSyn
@@ -37,6 +38,7 @@ import PrelNames
import SrcLoc
import Outputable
import FastString
+import TcType
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -47,12 +49,14 @@ There will be at least one ``qualifier'' in the input.
\begin{code}
dsListComp :: [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of list elements
+ -> Type -- Type of entire list
-> DsM CoreExpr
-dsListComp lquals body elt_ty = do
+dsListComp lquals res_ty = do
dflags <- getDOptsDs
let quals = map unLoc lquals
+ elt_ty = case tcTyConAppArgs res_ty of
+ [elt_ty] -> elt_ty
+ _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
-- Either rules are switched off, or we are ignoring what there are;
@@ -60,8 +64,8 @@ dsListComp lquals body elt_ty = do
-- Wadler-style desugaring
|| isParallelComp quals
-- Foldr-style desugaring can't handle parallel list comprehensions
- then deListComp quals body (mkNilExpr elt_ty)
- else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
+ then deListComp quals (mkNilExpr elt_ty)
+ else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
-- Foldr/build should be enabled, so desugar
-- into foldrs and builds
@@ -72,92 +76,69 @@ dsListComp lquals body elt_ty = do
-- mix of possibly a single element in length, so we do this to leave the possibility open
isParallelComp = any isParallelStmt
- isParallelStmt (ParStmt _) = True
- isParallelStmt _ = False
+ isParallelStmt (ParStmt _ _ _ _) = True
+ isParallelStmt _ = False
-- This function lets you desugar a inner list comprehension and a list of the binders
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
-dsInnerListComp (stmts, bndrs) = do
- expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
- return (expr, bndrs_tuple_type)
- where
- bndrs_types = map idType bndrs
- bndrs_tuple_type = mkBigCoreTupTy bndrs_types
-
+dsInnerListComp (stmts, bndrs)
+ = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
+ (mkListTy bndrs_tuple_type)
+ ; return (expr, bndrs_tuple_type) }
+ where
+ bndrs_tuple_type = mkBigCoreVarTupTy bndrs
--- This function factors out commonality between the desugaring strategies for TransformStmt.
--- Given such a statement it gives you back an expression representing how to compute the transformed
--- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
- = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
- ; usingExpr' <- dsLExpr usingExpr
-
- ; using_args <-
- case maybeByExpr of
- Nothing -> return [expr]
- Just byExpr -> do
- byExpr' <- dsLExpr byExpr
-
- us <- newUniqueSupply
- [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
- let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
-
- return [Lam tuple_binder byExprWrapper, expr]
-
- ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
- pat = mkBigLHsVarPatTup binders
- ; return (inner_list_expr, pat) }
-
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsGroupStmt (GroupStmt stmts binderMap by using) = do
- let (fromBinders, toBinders) = unzip binderMap
-
- fromBindersTypes = map idType fromBinders
- toBindersTypes = map idType toBinders
-
- toBindersTupleType = mkBigCoreTupTy toBindersTypes
+dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_using = using }) = do
+ let (from_bndrs, to_bndrs) = unzip binderMap
+ from_bndrs_tys = map idType from_bndrs
+ to_bndrs_tys = map idType to_bndrs
+ to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
+ (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
- usingExpr' <- dsLExpr (either id noLoc using)
+ usingExpr' <- dsLExpr using
usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
- ; us <- newUniqueSupply
- ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
- ; let by_wrap = mkTupleCase us fromBinders by_e'
- from_tup_id (Var from_tup_id)
- ; return [Lam from_tup_id by_wrap, expr] }
+ ; lam <- matchTuple from_bndrs by_e'
+ ; return [lam, expr] }
-- Create an unzip function for the appropriate arity and element types and find "map"
- (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
+ unzip_stuff <- mkUnzipBind form from_bndrs_tys
map_id <- dsLookupGlobalId mapName
-- Generate the expressions to build the grouped list
let -- First we apply the grouping function to the inner list
- inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
+ inner_list_expr = mkApps usingExpr' usingArgs
-- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
-- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
-- the "b" to be a tuple of "to" lists!
- unzipped_inner_list_expr = mkApps (Var map_id)
- [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
-- Then finally we bind the unzip function around that expression
- bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
-
- -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
- let pat = mkBigLHsVarPatTup toBinders
+ bound_unzipped_inner_list_expr
+ = case unzip_stuff of
+ Nothing -> inner_list_expr
+ Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $
+ mkApps (Var map_id) $
+ [ Type (mkListTy from_tup_ty)
+ , Type to_bndrs_tup_ty
+ , Var unzip_fn
+ , inner_list_expr]
+
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold lists rather than single values
+ let pat = mkBigLHsVarPatTup to_bndrs
return (bound_unzipped_inner_list_expr, pat)
-
\end{code}
%************************************************************************
@@ -226,53 +207,50 @@ with the Unboxed variety.
\begin{code}
-deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
-
-deListComp (ParStmt stmtss_w_bndrs : quals) body list
- = do
- exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
- let (exps, qual_tys) = unzip exps_and_qual_tys
-
- (zip_fn, zip_rhs) <- mkZipBind qual_tys
+deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
- -- Deal with [e | pat <- zip l1 .. ln] in example above
- deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
- quals body list
+deListComp [] _ = panic "deListComp"
- where
- bndrs_s = map snd stmtss_w_bndrs
-
- -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
- pat = mkBigLHsPatTup pats
- pats = map mkBigLHsVarPatTup bndrs_s
-
- -- Last: the one to return
-deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above
- core_body <- dsLExpr body
- return (mkConsExpr (exprType core_body) core_body list)
+deListComp (LastStmt body _ : quals) list
+ = -- Figure 7.4, SLPJ, p 135, rule C above
+ ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ : quals) body list = do -- rule B above
+deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
- core_rest <- deListComp quals body list
+ core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) body list = do
- core_rest <- deListComp quals body list
+deListComp (LetStmt binds : quals) list = do
+ core_rest <- deListComp quals list
dsLocalBinds binds core_rest
-deListComp (stmt@(TransformStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsTransformStmt stmt
- deBindComp pat inner_list_expr quals body list
+deListComp (stmt@(TransStmt {}) : quals) list = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
+ deBindComp pat inner_list_expr quals list
-deListComp (stmt@(GroupStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsGroupStmt stmt
- deBindComp pat inner_list_expr quals body list
-
-deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
+deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExpr list1
- deBindComp pat core_list1 quals body core_list2
+ deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+ = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+ ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+ ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+ -- Deal with [e | pat <- zip l1 .. ln] in example above
+ ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+ quals list }
+ where
+ bndrs_s = map snd stmtss_w_bndrs
+
+ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+ pat = mkBigLHsPatTup pats
+ pats = map mkBigLHsVarPatTup bndrs_s
\end{code}
@@ -280,10 +258,9 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
- -> LHsExpr Id
-> CoreExpr
-> DsM (Expr Id)
-deBindComp pat core_list1 quals body core_list2 = do
+deBindComp pat core_list1 quals core_list2 = do
let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
@@ -300,7 +277,7 @@ deBindComp pat core_list1 quals body core_list2 = do
core_fail = App (Var h) (Var u3)
letrec_body = App (Var h) core_list1
- rest_expr <- deListComp quals body core_fail
+ rest_expr <- deListComp quals core_fail
core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
let
@@ -335,48 +312,43 @@ TE[ e | p <- l , q ] c n = let
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
- -- Last: the one to return
-dfListComp c_id n_id [] body = do
- core_body <- dsLExpr body
- return (mkApps (Var c_id) [core_body, Var n_id])
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt body _ : quals)
+ = ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _ : quals) body = do
+dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_id n_id (LetStmt binds : quals) body = do
+dfListComp c_id n_id (LetStmt binds : quals) = do
-- new in 1.3, local bindings
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
-dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
- (inner_list_expr, pat) <- dsTransformStmt stmt
- -- Anyway, we bind the newly transformed list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
-
-dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
- (inner_list_expr, pat) <- dsGroupStmt stmt
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
-- Anyway, we bind the newly grouped list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
+ dfBindComp c_id n_id (pat, inner_list_expr) quals
-dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
-- Do the rest of the work in the generic binding builder
- dfBindComp c_id n_id (pat, core_list1) quals body
+ dfBindComp c_id n_id (pat, core_list1) quals
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals body = do
+dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
b_ty = idType n_id
@@ -385,7 +357,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do
[b, x] <- newSysLocalsDs [b_ty, x_ty]
-- build rest of the comprehesion
- core_rest <- dfListComp c_id b quals body
+ core_rest <- dfListComp c_id b quals
-- build the pattern match
core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
@@ -439,7 +411,7 @@ mkZipBind elt_tys = do
-- Increasing order of tag
-mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
-- mkUnzipBind [t1, t2]
-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
-- -> case ax of
@@ -449,28 +421,29 @@ mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
-- ys)
--
-- We use foldr here in all cases, even if rules are turned off, because we may as well!
-mkUnzipBind elt_tys = do
- ax <- newSysLocalDs elt_tuple_ty
- axs <- newSysLocalDs elt_list_tuple_ty
- ys <- newSysLocalDs elt_tuple_list_ty
- xs <- mapM newSysLocalDs elt_tys
- xss <- mapM newSysLocalDs elt_list_tys
+mkUnzipBind ThenForm _
+ = return Nothing -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+ = do { ax <- newSysLocalDs elt_tuple_ty
+ ; axs <- newSysLocalDs elt_list_tuple_ty
+ ; ys <- newSysLocalDs elt_tuple_list_ty
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; xss <- mapM newSysLocalDs elt_list_tys
- unzip_fn <- newSysLocalDs unzip_fn_ty
-
- [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
- let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
-
- concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
- tupled_concat_expression = mkBigCoreTup concat_expressions
-
- folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
- folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
- folder_body = mkLams [ax, axs] folder_body_outer_case
-
- unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
- return (unzip_fn, mkLams [ys] unzip_body)
+ ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+ ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+ ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+ concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+ tupled_concat_expression = mkBigCoreTup concat_expressions
+
+ folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+ folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+ folder_body = mkLams [ax, axs] folder_body_outer_case
+
+ ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+ ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
where
elt_tuple_ty = mkBigCoreTupTy elt_tys
elt_tuple_list_ty = mkListTy elt_tuple_ty
@@ -480,9 +453,6 @@ mkUnzipBind elt_tys = do
unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-
-
-
\end{code}
%************************************************************************
@@ -498,11 +468,10 @@ mkUnzipBind elt_tys = do
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
- -> LHsExpr Id
- -> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
-dsPArrComp [ParStmt qss] body _ = -- parallel comprehension
- dePArrParComp qss body
+
+-- Special case for parallel comprehension
+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
@@ -513,7 +482,7 @@ dsPArrComp [ParStmt qss] body _ = -- parallel comprehension
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
-dsPArrComp (BindStmt p e _ _ : qs) body _ = do
+dsPArrComp (BindStmt p e _ _ : qs) = do
filterP <- dsLookupDPHId filterPName
ce <- dsLExpr e
let ety'ce = parrElemType ce
@@ -523,38 +492,41 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do
pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
let gen | isIrrefutableHsPat p = ce
| otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
- dePArrComp qs body p gen
+ dePArrComp qs p gen
-dsPArrComp qs body _ = do -- no ParStmt in `qs'
+dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsLookupDPHId singletonPName
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
- dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
+ dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-- the work horse
--
dePArrComp :: [Stmt Id]
- -> LHsExpr Id
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
+
+dePArrComp [] _ _ = panic "dePArrComp"
+
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
-dePArrComp [] e' pa cea = do
- mapP <- dsLookupDPHId mapPName
- let ty = parrElemType cea
- (clam, ty'e') <- deLambda ty pa e'
- return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+dePArrComp (LastStmt e' _ : quals) pa cea
+ = ASSERT( null quals )
+ do { mapP <- dsLookupDPHId mapPName
+ ; let ty = parrElemType cea
+ ; (clam, ty'e') <- deLambda ty pa e'
+ ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
-dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
+dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
- dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+ dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
@@ -569,7 +541,7 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
-dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
+dePArrComp (BindStmt p e _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
crossMapP <- dsLookupDPHId crossMapPName
ce <- dsLExpr e
@@ -585,7 +557,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
let ety'cef = ety'ce -- filter doesn't change the element type
pa' = mkLHsPatTup [pa, p]
- dePArrComp qs body pa' (mkApps (Var crossMapP)
+ dePArrComp qs pa' (mkApps (Var crossMapP)
[Type ety'cea, Type ety'cef, cea, clam])
--
-- <<[:e' | let ds, qs:]>> pa ea =
@@ -594,7 +566,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
-dePArrComp (LetStmt ds : qs) body pa cea = do
+dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsLookupDPHId mapPName
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
@@ -609,14 +581,14 @@ dePArrComp (LetStmt ds : qs) body pa cea = do
ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
proj = mkLams [v] ccase
- dePArrComp qs body pa' (mkApps (Var mapP)
+ dePArrComp qs pa' (mkApps (Var mapP)
[Type ty'cea, Type errTy, proj, cea])
--
-- The parser guarantees that parallel comprehensions can only appear as
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
-dePArrComp (ParStmt _ : _) _ _ _ =
+dePArrComp (ParStmt _ _ _ _ : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST"
-- <<[:e' | qs | qss:]>> pa ea =
@@ -625,17 +597,17 @@ dePArrComp (ParStmt _ : _) _ _ _ =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
-dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
-dePArrParComp qss body = do
+dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
- dePArrComp [] body pQss ceQss
+ dePArrComp quals pQss ceQss
where
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
---
parStmts [] pa cea = return (pa, cea)
@@ -644,7 +616,7 @@ dePArrParComp qss body = do
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
@@ -682,3 +654,222 @@ parrElemType e =
_ -> panic
"DsListComp.parrElemType: not a parallel array type"
\end{code}
+
+Translation for monad comprehensions
+
+\begin{code}
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [LStmt Id] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [LStmt Id] -> DsM CoreExpr
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
+
+dsMcStmt (LastStmt body ret_op) stmts
+ = ASSERT( null stmts )
+ do { body' <- dsLExpr body
+ ; ret_op' <- dsExpr ret_op
+ ; return (App ret_op' body') }
+
+-- [ .. | let binds, stmts ]
+dsMcStmt (LetStmt binds) stmts
+ = do { rest <- dsMcStmts stmts
+ ; dsLocalBinds binds rest }
+
+-- [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
+ = do { rhs' <- dsLExpr rhs
+ ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+-- [ .. | exp, stmts ]
+--
+dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts
+ = do { exp' <- dsLExpr exp
+ ; guard_exp' <- dsExpr guard_exp
+ ; then_exp' <- dsExpr then_exp
+ ; rest <- dsMcStmts stmts
+ ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
+ , rest ] }
+
+-- Group statements desugar like this:
+--
+-- [| (q, then group by e using f); rest |]
+-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+-- case unzip n_tup of qv' -> [| rest |]
+--
+-- where variables (v1:t1, ..., vk:tk) are bound by q
+-- qv = (v1, ..., vk)
+-- qt = (t1, ..., tk)
+-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+-- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+-- n_tup :: n qt
+-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+ , trS_by = by, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+ = do { let (from_bndrs, to_bndrs) = unzip bndrs
+ from_bndr_tys = map idType from_bndrs -- Types ty
+
+ -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+ ; expr <- dsInnerMonadComp stmts from_bndrs return_op
+
+ -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+ -- function required? If so, create that desugared function and add to arguments
+ ; usingExpr' <- dsLExpr using
+ ; usingArgs <- case by of
+ Nothing -> return [expr]
+ Just by_e -> do { by_e' <- dsLExpr by_e
+ ; lam <- matchTuple from_bndrs by_e'
+ ; return [lam, expr] }
+
+ -- Generate the expressions to build the grouped list
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold monads rather than single values
+ ; bind_op' <- dsExpr bind_op
+ ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
+ n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c)
+ tup_n_ty = mkBigCoreVarTupTy to_bndrs
+
+ ; body <- dsMcStmts stmts_rest
+ ; n_tup_var <- newSysLocalDs n_tup_ty
+ ; tup_n_var <- newSysLocalDs tup_n_ty
+ ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys
+ ; us <- newUniqueSupply
+ ; let rhs' = mkApps usingExpr' usingArgs
+ body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
+
+ ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+-- [ body | qs1 | qs2 | qs3 ]
+-- -> [ body | (bndrs1, (bndrs2, bndrs3))
+-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+-- mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
+ = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty)
+ ; mzip_op' <- dsExpr mzip_op
+
+ ; let -- The pattern variables
+ pats = map (mkBigLHsVarPatTup . snd) pairs
+ -- Pattern with tuples of variables
+ -- [v1,v2,v3] => (v1, (v2, v3))
+ pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+ (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+ (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+ mkBoxedTupleTy [t1,t2]))
+ exps_w_tys
+
+ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
+ where
+ ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
+ ; return (exp, tup_ty) }
+ where
+ mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
+ tup_ty = mkBigCoreVarTupTy bndrs
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+-- returns the Core term
+-- \x. case x of (a,b,c) -> body
+matchTuple ids body
+ = do { us <- newUniqueSupply
+ ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+ ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat Id
+ -> CoreExpr -- ^ the desugared rhs of the bind statement
+ -> SyntaxExpr Id
+ -> SyntaxExpr Id
+ -> [LStmt Id]
+ -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op stmts
+ = do { body <- dsMcStmts stmts
+ ; bind_op' <- dsExpr bind_op
+ ; var <- selectSimpleMatchVarL pat
+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ res1_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+
+ where
+ -- In a monad comprehension expression, pattern-match failure just calls
+ -- the monadic `fail` rather than throwing an exception
+ handle_failure pat match fail_op
+ | matchCanFail match
+ = do { fail_op' <- dsExpr fail_op
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; extractMatchResult match (App fail_op' fail_msg) }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
+
+ mk_fail_msg :: Located e -> String
+ mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++
+ showSDoc (ppr (getLoc pat))
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+-- dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+-- [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [LStmt Id]
+ -> [Id] -- Return a tuple of these variables
+ -> HsExpr Id -- The monomorphic "return" operator
+ -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+ = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+-- unzip :: m (a,b,..) -> (m a,m b,..)
+-- unzip m_tuple = ( liftM selN1 m_tuple
+-- , liftM selN2 m_tuple
+-- , .. )
+--
+-- mkMcUnzipM fmap ys [t1, t2]
+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys
+-- , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+ -> SyntaxExpr TcId -- fmap
+ -> Id -- Of type n (a,b,c)
+ -> [Type] -- [a,b,c]
+ -> DsM CoreExpr -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+ = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+ = do { fmap_op' <- dsExpr fmap_op
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; let tup_ty = mkBigCoreTupTy elt_tys
+ ; tup_xs <- newSysLocalDs tup_ty
+
+ ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
+ [ Type tup_ty, Type (elt_tys !! i)
+ , mk_sel i, Var ys]
+
+ mk_sel n = Lam tup_xs $
+ mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
+
+ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index e34c6960d7cfe178ef2aa166fea1275b6660f693..a4b47ee504f6948aff583fc84362b77796d5d9d6 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -420,6 +420,10 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig (L _ (GenericSig nm _)) = failWithDs msg
+ where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
+ , ptext (sLit "Default signatures are not supported by Template Haskell") ]
+
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig _ = return []
@@ -631,7 +635,6 @@ repTy (HsKindSig t k) = do
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice _ _) = repSplice splice
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
@@ -721,23 +724,19 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt sts body _)
+repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| ListComp <- ctxt
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
- = notHandled "mdo and [: :]" (ppr e)
+ = notHandled "mdo, monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
@@ -817,7 +816,7 @@ repGuards other
wrapGenSyms (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
- process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+ process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
process (L _ (GRHS ss rhs))
@@ -876,7 +875,7 @@ repSts (LetStmt bs : ss) =
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
-repSts (ExprStmt e _ _ : ss) =
+repSts (ExprStmt e _ _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
@@ -1584,7 +1583,7 @@ repLiteral lit
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
-mk_rational :: Rational -> DsM HsLit
+mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 3a976878e3ead7625a96703c5621a5ae8bec3f0a..8b5c0a95bd99b040d0f93da1963d6275e36e0d40 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -53,7 +53,6 @@ import CoreUtils
import MkCore
import MkId
import Id
-import Var
import Name
import Literal
import TyCon
@@ -75,7 +74,6 @@ import StaticFlags
\end{code}
-
%************************************************************************
%* *
Rebindable syntax
@@ -256,10 +254,9 @@ wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body -- Can deal with term variables *or* type variables
- | new==old = body
- | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
- | otherwise = Let (NonRec new (Var old)) body
+wrapBind new old body -- NB: this function must deal with term
+ | new==old = body -- variables, type variables or coercion variables
+ | otherwise = Let (NonRec new (varToCoreExpr old)) body
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
@@ -299,10 +296,11 @@ mkCoPrimCaseMatchResult var ty match_alts
return (LitAlt lit, [], body)
-mkCoAlgCaseMatchResult :: Id -- Scrutinee
- -> Type -- Type of exp
- -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
- -> MatchResult
+mkCoAlgCaseMatchResult
+ :: Id -- Scrutinee
+ -> Type -- Type of exp
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts)
+ -> MatchResult
mkCoAlgCaseMatchResult var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
@@ -605,7 +603,7 @@ mkSelectorBinds pat val_expr
return (bndr_var, rhs_expr)
where
error_expr = mkCoerce co (Var err_var)
- co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
+ co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 5c6b2244661b20aa50fa7003e8b86287c6c171cd..1a044d3471be686c021f38bd10d5b2dcefa9400a 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -29,6 +29,7 @@ import DataCon
import MatchCon
import MatchLit
import Type
+import Coercion
import TysWiredIn
import ListSetOps
import SrcLoc
@@ -522,7 +523,7 @@ tidy1 _ (LitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat lit mb_neg eq)
- = return (idDsWrapper, tidyNPat lit mb_neg eq)
+ = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
-- BangPatterns: Pattern matching is already strict in constructors,
-- tuples etc, so the last case strips off the bang for thoses patterns.
@@ -825,7 +826,7 @@ sameGroup (PgCon _) (PgCon _) = True -- One case expression
sameGroup (PgLit _) (PgLit _) = True -- One case expression
sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
+sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
-- CoPats are in the same goup only if the type of the
-- enclosed pattern is the same. The patterns outside the CoPat
-- always have the same type, so this boils down to saying that
@@ -873,7 +874,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- which resolve the overloading (e.g., fromInteger 1),
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
- tcEqType (overLitType l) (overLitType l') && l == l'
+ eqType (overLitType l) (overLitType l') && l == l'
exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
@@ -897,7 +898,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
tup_arg (Present e1) (Present e2) = lexp e1 e2
- tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+ tup_arg (Missing t1) (Missing t2) = eqType t1 t2
tup_arg _ _ = False
---------
@@ -910,9 +911,9 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
- wrap (WpCast c) (WpCast c') = tcEqType c c'
+ wrap (WpCast c) (WpCast c') = coreEqCoercion c c'
wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
- wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
+ wrap (WpTyApp t) (WpTyApp t') = eqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
wrap _ _ = False
@@ -920,7 +921,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvId a) (EvId b) = a==b
- ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+ ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
ev_term _ _ = False
---------
@@ -959,3 +960,4 @@ If the first arg matches '1' but the second does not match 'True', we
cannot jump to the third equation! Because the same argument might
match '2'!
Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 03fa3256511126cad83ccd43b3c204ee8ca35a8a..d84b9013ccf728990f9c2dd3f60b812c79d209de 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -28,7 +28,6 @@ import DsUtils
import Util ( all2, takeList, zipEqual )
import ListSetOps ( runs )
import Id
-import Var ( Var )
import NameEnv
import SrcLoc
import Outputable
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 5e5e81d2ba97d6e48d2483c7154666c378a9c908..0bd25389376c8a77ecd5e7961239fce2aa47dcc2 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -33,6 +33,7 @@ import Literal
import SrcLoc
import Data.Ratio
import Outputable
+import BasicTypes
import Util
import FastString
\end{code}
@@ -64,8 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s))
dsLit (HsCharPrim c) = return (Lit (MachChar c))
dsLit (HsIntPrim i) = return (Lit (MachInt i))
dsLit (HsWordPrim w) = return (Lit (MachWord w))
-dsLit (HsFloatPrim f) = return (Lit (MachFloat f))
-dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
+dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
+dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
@@ -73,8 +74,8 @@ dsLit (HsInteger i _) = mkIntegerExpr i
dsLit (HsInt i) = return (mkIntExpr i)
dsLit (HsRat r ty) = do
- num <- mkIntegerExpr (numerator r)
- denom <- mkIntegerExpr (denominator r)
+ num <- mkIntegerExpr (numerator (fl_value r))
+ denom <- mkIntegerExpr (denominator (fl_value r))
return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
@@ -112,8 +113,8 @@ hsLitKey (HsIntPrim i) = mkMachInt i
hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr s
-hsLitKey (HsFloatPrim f) = MachFloat f
-hsLitKey (HsDoublePrim d) = MachDouble d
+hsLitKey (HsFloatPrim f) = MachFloat (fl_value f)
+hsLitKey (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey (HsString s) = MachStr s
hsLitKey l = pprPanic "hsLitKey" (ppr l)
@@ -124,8 +125,8 @@ hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral i) False = MachInt i
litValKey (HsIntegral i) True = MachInt (-i)
-litValKey (HsFractional r) False = MachFloat r
-litValKey (HsFractional r) True = MachFloat (-r)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code}
@@ -152,8 +153,14 @@ tidyLitPat (HsString s)
tidyLitPat lit = LitPat lit
----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
-tidyNPat (OverLit val False _ ty) mb_neg _
+tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
+ -- We need this argument because tidyNPat is called
+ -- both by Match and by Check, but they tidy LitPats
+ -- slightly differently; and we must desugar
+ -- literals consistently (see Trac #5117)
+ -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
+ -> Pat Id
+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
@@ -169,7 +176,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
| isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
| isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
| isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
- | isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit)
+ | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
@@ -180,12 +187,12 @@ tidyNPat (OverLit val False _ ty) mb_neg _
(Just _, HsIntegral i) -> Just (-i)
_ -> Nothing
- mb_rat_lit :: Maybe Rational
+ mb_rat_lit :: Maybe FractionalLit
mb_rat_lit = case (mb_neg, val) of
- (Nothing, HsIntegral i) -> Just (fromInteger i)
- (Just _, HsIntegral i) -> Just (fromInteger (-i))
+ (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
+ (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
- (Just _, HsFractional f) -> Just (-f)
+ (Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
mb_str_lit :: Maybe FastString
@@ -193,7 +200,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
(Nothing, HsIsString s) -> Just s
_ -> Nothing
-tidyNPat over_lit mb_neg eq
+tidyNPat _ over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code}
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index c509eb625530ec174c9c1d8bf53e3d2ba63a87ef..b3d9f0cd2a442716d4a7d7729f85e15ec4da2df7 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -36,11 +36,6 @@ Flag ghci
Default: False
Manual: True
-Flag ncg
- Description: Build the NCG.
- Default: False
- Manual: True
-
Flag stage1
Description: Is this stage 1?
Default: False
@@ -88,9 +83,6 @@ Library
CPP-Options: -DGHCI
Include-Dirs: ../libffi/build/include
- if !flag(ncg)
- CPP-Options: -DOMIT_NATIVE_CODEGEN
-
Build-Depends: bin-package-db
Build-Depends: hoopl
@@ -424,6 +416,7 @@ Library
Generics
InstEnv
TyCon
+ Kind
Type
TypeRep
Unify
@@ -450,6 +443,7 @@ Library
MonadUtils
OrdList
Outputable
+ Pair
Panic
Pretty
Serialized
@@ -490,10 +484,7 @@ Library
Vectorise.Exp
Vectorise
- -- We only need to expose more modules as some of the ncg code is used
- -- by the LLVM backend so its always included
- if flag(ncg)
- Exposed-Modules:
+ Exposed-Modules:
AsmCodeGen
TargetReg
NCGMonad
@@ -503,10 +494,6 @@ Library
RegClass
PIC
Platform
- Alpha.Regs
- Alpha.RegInfo
- Alpha.Instr
- Alpha.CodeGen
X86.Regs
X86.RegInfo
X86.Instr
@@ -565,7 +552,6 @@ Library
TcSplice
Convert
ByteCodeAsm
- ByteCodeFFI
ByteCodeGen
ByteCodeInstr
ByteCodeItbls
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index a7a353d66e618f3ca3b4a25df791eff659a0a348..8ed34c31360ef5a5ac74ef462e5c3c4927604bf1 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -49,8 +49,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo '{-# LANGUAGE CPP #-}' >> $@
@echo 'module Config where' >> $@
@echo >> $@
- @echo 'import Distribution.System' >> $@
- @echo >> $@
@echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@
@@ -60,42 +58,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cTargetPlatformString :: String' >> $@
@echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@
@echo >> $@
-# Sync this with checkArch in configure.ac
- @echo 'cTargetArch :: Arch' >> $@
- @echo '#if i386_TARGET_ARCH' >> $@
- @echo 'cTargetArch = I386' >> $@
- @echo '#elif x86_64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = X86_64' >> $@
- @echo '#elif powerpc_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC' >> $@
- @echo '#elif powerpc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC64' >> $@
- @echo '#elif sparc_TARGET_ARCH || sparc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Sparc' >> $@
- @echo '#elif arm_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Arm' >> $@
- @echo '#elif mips_TARGET_ARCH || mipseb_TARGET_ARCH || mipsel_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Mips' >> $@
- @echo '#elif 0' >> $@
- @echo 'cTargetArch = SH' >> $@
- @echo '#elif ia64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = IA64' >> $@
- @echo '#elif s390_TARGET_ARCH' >> $@
- @echo 'cTargetArch = S390' >> $@
- @echo '#elif alpha_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Alpha' >> $@
- @echo '#elif hppa_TARGET_ARCH || hppa1_1_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Hppa' >> $@
- @echo '#elif rs6000_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Rs6000' >> $@
- @echo '#elif m68k_TARGET_ARCH' >> $@
- @echo 'cTargetArch = M68k' >> $@
- @echo '#elif vax_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Vax' >> $@
- @echo '#else' >> $@
- @echo '#error Unknown target arch' >> $@
- @echo '#endif' >> $@
- @echo >> $@
@echo 'cProjectName :: String' >> $@
@echo 'cProjectName = "$(ProjectName)"' >> $@
@echo 'cProjectVersion :: String' >> $@
@@ -108,8 +70,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cBooterVersion = "$(GhcVersion)"' >> $@
@echo 'cStage :: String' >> $@
@echo 'cStage = show (STAGE :: Int)' >> $@
- @echo 'cCcOpts :: [String]' >> $@
- @echo 'cCcOpts = words "$(CONF_CC_OPTS_STAGE$*)"' >> $@
@echo 'cGccLinkerOpts :: [String]' >> $@
@echo 'cGccLinkerOpts = words "$(CONF_GCC_LINKER_OPTS_STAGE$*)"' >> $@
@echo 'cLdLinkerOpts :: [String]' >> $@
@@ -134,8 +94,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@
@echo 'cRAWCPP_FLAGS :: String' >> $@
@echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@
- @echo 'cGCC :: String' >> $@
- @echo 'cGCC = "$(WhatGccIsCalled)"' >> $@
@echo 'cMKDLL :: String' >> $@
@echo 'cMKDLL = "$(BLD_DLL)"' >> $@
@echo 'cLdIsGNULd :: String' >> $@
@@ -162,8 +120,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cGHC_SYSMAN_PGM = "$(GHC_SYSMAN)"' >> $@
@echo 'cGHC_SYSMAN_DIR :: String' >> $@
@echo 'cGHC_SYSMAN_DIR = "$(GHC_SYSMAN_DIR)"' >> $@
- @echo 'cGHC_PERL :: String' >> $@
- @echo 'cGHC_PERL = "$(GHC_PERL)"' >> $@
@echo 'cDEFAULT_TMPDIR :: String' >> $@
@echo 'cDEFAULT_TMPDIR = "$(DEFAULT_TMPDIR)"' >> $@
@echo 'cRelocatableBuild :: Bool' >> $@
@@ -296,7 +252,7 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl \
compiler/primop-has-side-effects.hs-incl \
compiler/primop-out-of-line.hs-incl \
compiler/primop-commutable.hs-incl \
- compiler/primop-needs-wrapper.hs-incl \
+ compiler/primop-code-size.hs-incl \
compiler/primop-can-fail.hs-incl \
compiler/primop-strictness.hs-incl \
compiler/primop-primop-info.hs-incl
@@ -322,8 +278,8 @@ compiler/primop-out-of-line.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --out-of-line < $< > $@
compiler/primop-commutable.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --commutable < $< > $@
-compiler/primop-needs-wrapper.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
- "$(GENPRIMOP_INPLACE)" --needs-wrapper < $< > $@
+compiler/primop-code-size.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
+ "$(GENPRIMOP_INPLACE)" --code-size < $< > $@
compiler/primop-can-fail.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --can-fail < $< > $@
compiler/primop-strictness.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
@@ -377,12 +333,6 @@ endif
endif
-ifeq "$(GhcWithNativeCodeGen)" "NO"
-# XXX This should logically be a CPP option, but there doesn't seem to
-# be a flag for that
-compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN
-endif
-
ifeq "$(TargetOS_CPP)" "openbsd"
compiler_CONFIGURE_OPTS += --ld-options=-E
endif
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index dfc77e51b20b02698cf14f940431f8e8bc1ef8cf..af9fbe90494acc6e898029728b5a52f9155d437e 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -30,7 +30,9 @@ import PrimOp
import Constants
import FastString
import SMRep
+import DynFlags
import Outputable
+import Platform
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
@@ -113,14 +115,14 @@ instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
-assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs proto_bcos tycons
+assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls tycons
- bcos <- mapM assembleBCO proto_bcos
+ bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset
@@ -152,7 +154,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
let init_asm_state = (insns,lits,ptrs)
(final_insns, final_lits, final_ptrs)
- <- mkBits findLabel init_asm_state instrs
+ <- mkBits dflags findLabel init_asm_state instrs
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
@@ -228,12 +230,13 @@ largeArg w
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word) -- label finder
+mkBits :: DynFlags
+ -> (Word16 -> Word) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
-mkBits findLabel st proto_insns
+mkBits dflags findLabel st proto_insns
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
@@ -247,14 +250,14 @@ mkBits findLabel st proto_insns
instr2 st2 bci_PUSH_G p
PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
instr2 st2 bci_PUSH_G p
- PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_G p
- PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_ALTS p
PUSH_ALTS_UNLIFTED proto pk -> do
- ul_bco <- assembleBCO proto
+ ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
@@ -395,12 +398,11 @@ mkBits findLabel st proto_insns
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
-#ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _)
+ | platformOS (targetPlatform dflags) == OSMinGW32
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
-#endif
literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
diff --git a/compiler/ghci/ByteCodeFFI.lhs b/compiler/ghci/ByteCodeFFI.lhs
deleted file mode 100644
index 1589fe1bed01f11e64dcef3ee3df27397c0f5b07..0000000000000000000000000000000000000000
--- a/compiler/ghci/ByteCodeFFI.lhs
+++ /dev/null
@@ -1,28 +0,0 @@
-%
-% (c) The University of Glasgow 2001-2008
-%
-
-ByteCodeGen: Generate machine-code sequences for foreign import
-
-\begin{code}
-module ByteCodeFFI ( moan64 ) where
-
-import Outputable
-import System.IO
-import System.IO.Unsafe
-
-moan64 :: String -> SDoc -> a
-moan64 msg pp_rep
- = unsafePerformIO (
- hPutStrLn stderr (
- "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++
- "code properly yet. You can work around this for the time being\n" ++
- "by compiling this module and all those it imports to object code,\n" ++
- "and re-starting your GHCi session. The panic below contains information,\n" ++
- "intended for the GHC implementors, about the exact place where GHC gave up.\n"
- )
- )
- `seq`
- pprPanic msg pp_rep
-\end{code}
-
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index f34ac9c1726f47a3c77e10458f5a135b4397f707..426f4f251b3d1ee0d6008c5f19267e53efb1e0bc 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -30,10 +30,7 @@ import CoreFVs
import Type
import DataCon
import TyCon
--- import Type
import Util
--- import DataCon
-import Var
import VarSet
import TysPrim
import DynFlags
@@ -50,38 +47,36 @@ import Data.List
import Foreign
import Foreign.C
--- import GHC.Exts ( Int(..) )
-
-import Control.Monad ( when )
+import Control.Monad
import Data.Char
import UniqSupply
import BreakArray
import Data.Maybe
-import Module
-import IdInfo
+import Module
+import IdInfo
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
-- -----------------------------------------------------------------------------
--- Generating byte code for a complete module
+-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
- -> [TyCon]
- -> ModBreaks
+ -> [TyCon]
+ -> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags binds tycs modBreaks
+byteCodeGen dflags binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
- let flatBinds = [ (bndr, freeVars rhs)
- | (bndr, rhs) <- flattenBinds binds]
+ let flatBinds = [ (bndr, freeVars rhs)
+ | (bndr, rhs) <- flattenBinds binds]
- us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _, proto_bcos)
- <- runBc us modBreaks (mapM schemeTopBind flatBinds)
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us _final_ctr mallocd _, proto_bcos)
+ <- runBc us modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -89,15 +84,15 @@ byteCodeGen dflags binds tycs modBreaks
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- assembleBCOs proto_bcos tycs
-
+ assembleBCOs dflags proto_bcos tycs
+
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
--- Returns: (the root BCO for this expression,
+-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
- -> CoreExpr
+ -> CoreExpr
-> IO UnlinkedBCO
coreExprToBCOs dflags expr
= do showPass dflags "ByteCodeGen"
@@ -106,11 +101,11 @@ coreExprToBCOs dflags expr
-- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
-
+
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _ , proto_bco)
+ (BcM_State _us _final_ctr mallocd _ , proto_bco)
<- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
@@ -118,7 +113,7 @@ coreExprToBCOs dflags expr
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
- assembleBCO proto_bco
+ assembleBCO dflags proto_bco
-- -----------------------------------------------------------------------------
@@ -152,18 +147,18 @@ mkProtoBCO
-> Int
-> Word16
-> [StgWord]
- -> Bool -- True <=> is a return point, rather than a function
+ -> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
- protoBCOName = nm,
- protoBCOInstrs = maybe_with_stack_check,
- protoBCOBitmap = bitmap,
- protoBCOBitmapSize = bitmap_size,
- protoBCOArity = arity,
- protoBCOExpr = origin,
- protoBCOPtrs = mallocd_blocks
+ protoBCOName = nm,
+ protoBCOInstrs = maybe_with_stack_check,
+ protoBCOBitmap = bitmap,
+ protoBCOBitmapSize = bitmap_size,
+ protoBCOArity = arity,
+ protoBCOExpr = origin,
+ protoBCOPtrs = mallocd_blocks
}
where
-- Overestimate the stack usage (in words) of this BCO,
@@ -174,17 +169,17 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
- | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
- -- don't do stack checks at return points,
- -- everything is aggregated up to the top BCO
- -- (which must be a function).
+ | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+ -- don't do stack checks at return points,
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function).
-- That is, unless the stack usage is >= AP_STACK_SPLIM,
-- see bug #1466.
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_usage : peep_d
| otherwise
- = peep_d -- the supposedly common case
-
+ = peep_d -- the supposedly common case
+
-- We assume that this sum doesn't wrap
stack_usage = sum (map bciStackUse peep_d)
@@ -214,19 +209,19 @@ argBits (rep : args)
schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
- -- Special case for the worker of a nullary data con.
- -- It'll look like this: Nil = /\a -> Nil a
- -- If we feed it into schemeR, we'll get
- -- Nil = Nil
- -- because mkConAppCode treats nullary constructor applications
- -- by just re-using the single top-level definition. So
- -- for the worker itself, we must allocate it directly.
+ -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
+ -- If we feed it into schemeR, we'll get
+ -- Nil = Nil
+ -- because mkConAppCode treats nullary constructor applications
+ -- by just re-using the single top-level definition. So
+ -- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
@@ -242,18 +237,18 @@ schemeTopBind (id, rhs)
--
-- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the
--- resulting BCO a name.
+-- resulting BCO a name.
-schemeR :: [Id] -- Free vars of the RHS, ordered as they
- -- will appear in the thunk. Empty for
- -- top-level things, which have no free vars.
- -> (Id, AnnExpr Id VarSet)
- -> BcM (ProtoBCO Name)
+schemeR :: [Id] -- Free vars of the RHS, ordered as they
+ -- will appear in the thunk. Empty for
+ -- top-level things, which have no free vars.
+ -> (Id, AnnExpr Id VarSet)
+ -> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
- $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
@@ -269,40 +264,40 @@ collect (_, e) = go [] e
go xs (AnnLam x (_,e)) = go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
- = let
- all_args = reverse args ++ fvs
- arity = length all_args
- -- all_args are the args in reverse order. We're compiling a function
- -- \fv1..fvn x1..xn -> e
- -- i.e. the fvs come first
+ = let
+ all_args = reverse args ++ fvs
+ arity = length all_args
+ -- all_args are the args in reverse order. We're compiling a function
+ -- \fv1..fvn x1..xn -> e
+ -- i.e. the fvs come first
szsw_args = map (fromIntegral . idSizeW) all_args
szw_args = sum szsw_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
- -- make the arg bitmap
- bits = argBits (reverse (map idCgRep all_args))
- bitmap_size = genericLength bits
- bitmap = mkBitmap bits
+ -- make the arg bitmap
+ bits = argBits (reverse (map idCgRep all_args))
+ bitmap_size = genericLength bits
+ bitmap = mkBitmap bits
in do
- body_code <- schemeER_wrk szw_args p_init body
-
+ body_code <- schemeER_wrk szw_args p_init body
+
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
- arity bitmap_size bitmap False{-not alts-})
+ arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk d p rhs
- | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
- code <- schemeE d 0 p newRhs
- arr <- getBreakArray
+ | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+ code <- schemeE d 0 p newRhs
+ arr <- getBreakArray
let idOffSets = getVarOffSets d p tickInfo
let tickNumber = tickInfo_number tickInfo
- let breakInfo = BreakInfo
+ let breakInfo = BreakInfo
{ breakInfo_module = tickInfo_module tickInfo
- , breakInfo_number = tickNumber
+ , breakInfo_number = tickNumber
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
@@ -310,15 +305,15 @@ schemeER_wrk d p rhs
BA arr# ->
BRK_FUN arr# (fromIntegral tickNumber) breakInfo
return $ breakInstr `consOL` code
- | otherwise = schemeE d 0 p rhs
+ | otherwise = schemeE d 0 p rhs
getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
-getOffSet d env id
+getOffSet d env id
= case lookupBCEnv_maybe id env of
- Nothing -> Nothing
+ Nothing -> Nothing
Just offset -> Just (id, d - offset)
fvsToEnv :: BCEnv -> VarSet -> [Id]
@@ -330,22 +325,22 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs,
- isId v, -- Could be a type variable
- v `Map.member` p]
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+ isId v, -- Could be a type variable
+ v `Map.member` p]
-- -----------------------------------------------------------------------------
-- schemeE
-data TickInfo
- = TickInfo
+data TickInfo
+ = TickInfo
{ tickInfo_number :: Int -- the (module) unique number of the tick
- , tickInfo_module :: Module -- the origin of the ticked expression
+ , tickInfo_module :: Module -- the origin of the ticked expression
, tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
- }
+ }
instance Outputable TickInfo where
- ppr info = text "TickInfo" <+>
+ ppr info = text "TickInfo" <+>
parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
ppr (tickInfo_locals info))
@@ -358,7 +353,7 @@ schemeE d s p e
= schemeE d s p e'
-- Delegate tail-calls to schemeT.
-schemeE d s p e@(AnnApp _ _)
+schemeE d s p e@(AnnApp _ _)
= schemeT d s p e
schemeE d s p e@(AnnVar v)
@@ -367,12 +362,12 @@ schemeE d s p e@(AnnVar v)
schemeT d s p e
| otherwise
- = do -- Returning an unlifted value.
+ = do -- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
(push, szw) <- pushAtom d p (AnnVar v)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX v_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
v_rep = typeCgRep v_type
@@ -380,17 +375,17 @@ schemeE d s p e@(AnnVar v)
schemeE d s p (AnnLit literal)
= do (push, szw) <- pushAtom d p (AnnLit literal)
let l_rep = typeCgRep (literalType literal)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX l_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX l_rep) -- go
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
- = do -- Special case for a non-recursive let whose RHS is a
- -- saturatred constructor application.
- -- Just allocate the constructor and carry on
+ = do -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
body_code <- schemeE (d+1) s (Map.insert x d p) body
return (alloc_code `appOL` body_code)
@@ -407,8 +402,8 @@ schemeE d s p (AnnLet binds (_,body))
-- Sizes of free vars
sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
- -- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ -- the arity of each rhs
+ arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1. d' and p' reflect the stack
@@ -421,33 +416,33 @@ schemeE d s p (AnnLet binds (_,body))
-- ToDo: don't build thunks for things with no free variables
build_thunk _ [] size bco off arity
= return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
- where
- mkap | arity == 0 = MKAP
- | otherwise = MKPAP
+ where
+ mkap | arity == 0 = MKAP
+ | otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
- (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
+ (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
- where mkAlloc sz 0
+ where mkAlloc sz 0
| is_tick = ALLOC_AP_NOUPD sz
| otherwise = ALLOC_AP sz
- mkAlloc sz arity = ALLOC_PAP arity sz
+ mkAlloc sz arity = ALLOC_PAP arity sz
- is_tick = case binds of
+ is_tick = case binds of
AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
- compile_bind d' fvs x rhs size arity off = do
- bco <- schemeR fvs (x,rhs)
- build_thunk d' fvs size bco off arity
+ compile_bind d' fvs x rhs size arity off = do
+ bco <- schemeR fvs (x,rhs)
+ build_thunk d' fvs size bco off arity
- compile_binds =
- [ compile_bind d' fvs x rhs size arity n
- | (fvs, x, rhs, size, arity, n) <-
- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
- ]
+ compile_binds =
+ [ compile_bind d' fvs x rhs size arity n
+ | (fvs, x, rhs, size, arity, n) <-
+ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+ ]
in do
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
@@ -464,7 +459,7 @@ schemeE d s p exp@(AnnCase {})
= if isUnLiftedType ty
then do
-- If the result type is unlifted, then we must generate
- -- let f = \s . case tick# of _ -> e
+ -- let f = \s . case tick# of _ -> e
-- in f realWorld#
-- When we stop at the breakpoint, _result will have an unlifted
-- type and hence won't be bound in the environment, but the
@@ -472,7 +467,7 @@ schemeE d s p exp@(AnnCase {})
id <- newId (mkFunTy realWorldStatePrimTy ty)
st <- newId realWorldStatePrimTy
let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
- (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
+ (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
(emptyVarSet, AnnVar realWorldPrimId)))
schemeE d s p letExp
else do
@@ -486,42 +481,42 @@ schemeE d s p exp@(AnnCase {})
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
- -- Convert
- -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
- -- becuse the return convention for both are identical.
- --
- -- Note that it does not matter losing the void-rep thing from the
- -- envt (it won't be bound now) because we never look such things up.
+ -- Convert
+ -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- becuse the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
- doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
- -- Similarly, convert
- -- case .... of x { (# a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
+ -- Similarly, convert
+ -- case .... of x { (# a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE _ _ _ expr
- = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' expr))
-{-
+{-
Ticked Expressions
------------------
-
+
A ticked expression looks like this:
case tick<n> var1 ... varN of DEFAULT -> e
@@ -535,7 +530,7 @@ schemeE _ _ _ expr
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".
@@ -544,10 +539,10 @@ schemeE _ _ _ expr
isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
isTickedExp' (AnnCase scrut _bndr _type alts)
| Just tickInfo <- isTickedScrut scrut,
- [(DEFAULT, _bndr, rhs)] <- alts
+ [(DEFAULT, _bndr, rhs)] <- alts
= Just (tickInfo, rhs)
where
- isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
+ isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
isTickedScrut expr
| Var id <- f,
Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
@@ -559,7 +554,7 @@ isTickedExp' (AnnCase scrut _bndr _type alts)
where
(f, args) = collectArgs $ deAnnotate expr
idsOfArgs :: [Expr Id] -> [Id]
- idsOfArgs = catMaybes . map exprId
+ idsOfArgs = catMaybes . map exprId
exprId :: Expr Id -> Maybe Id
exprId (Var id) = Just id
exprId _ = Nothing
@@ -583,16 +578,16 @@ isTickedExp' _ = Nothing
-- (# b #) and treat it as b.
--
-- 3. Application of a constructor, by defn saturated.
--- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Word16 -- Stack depth
- -> Sequel -- Sequel depth
- -> BCEnv -- stack env
- -> AnnExpr' Id VarSet
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr' Id VarSet
-> BcM BCInstrList
schemeT d s p app
@@ -601,13 +596,13 @@ schemeT d s p app
-- = panic "schemeT ?!?!"
-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
--- = error "?!?!"
+-- = error "?!?!"
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= do (push, arg_words) <- pushAtom d p arg
tagToId_sequence <- implement_tagToId constr_names
- return (push `appOL` tagToId_sequence
+ return (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
@@ -619,20 +614,20 @@ schemeT d s p app
| Just con <- maybe_saturated_dcon,
isUnboxedTupleCon con
= case args_r_to_l of
- [arg1,arg2] | isVoidArgAtom arg1 ->
- unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVoidArgAtom arg2 ->
- unboxedTupleReturn d s p arg1
- _other -> unboxedTupleException
+ [arg1,arg2] | isVoidArgAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidArgAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
- return (alloc_con `appOL`
- mkSLIDE 1 (d - s) `snocOL`
- ENTER)
+ return (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
- -- Case 4: Tail call of function
+ -- Case 4: Tail call of function
| otherwise
= doTailCall d s p fn args_r_to_l
@@ -641,54 +636,54 @@ schemeT d s p app
maybe_is_tagToEnum_call
= let extract_constr_Names ty
| Just (tyc, _) <- splitTyConApp_maybe (repType ty),
- isDataTyCon tyc
- = map (getName . dataConWorkId) (tyConDataCons tyc)
- -- NOTE: use the worker name, not the source name of
- -- the DataCon. See DataCon.lhs for details.
- | otherwise
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
= pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
in
case app of
(AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
- _ -> Nothing
+ _ -> Nothing
_ -> Nothing
- -- Extract the args (R->L) and fn
- -- The function will necessarily be a variable,
- -- because we are compiling a tail call
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
(AnnVar fn, args_r_to_l) = splitApp app
-- Only consider this to be a constructor application iff it is
-- saturated. Otherwise, we'll call the constructor wrapper.
n_args = length args_r_to_l
- maybe_saturated_dcon
- = case isDataConWorkId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
-- -----------------------------------------------------------------------------
--- Generate code to build a constructor application,
+-- Generate code to build a constructor application,
-- leaving it on top of the stack
mkConAppCode :: Word16 -> Sequel -> BCEnv
- -> DataCon -- The data constructor
- -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
- -> BcM BCInstrList
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
-mkConAppCode _ _ _ con [] -- Nullary constructor
+mkConAppCode _ _ _ con [] -- Nullary constructor
= ASSERT( isNullaryRepDataCon con )
return (unitOL (PUSH_G (getName (dataConWorkId con))))
- -- Instead of doing a PACK, which would allocate a fresh
- -- copy of this constructor, use the single shared version.
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
-mkConAppCode orig_d _ p con args_r_to_l
+mkConAppCode orig_d _ p con args_r_to_l
= ASSERT( dataConRepArity con == length args_r_to_l )
do_pushery orig_d (non_ptr_args ++ ptr_args)
where
- -- The args are already in reverse order, which is the way PACK
- -- expects them to be. We must push the non-ptrs after the ptrs.
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
(ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
do_pushery d (arg:args)
@@ -697,8 +692,8 @@ mkConAppCode orig_d _ p con args_r_to_l
return (push `appOL` more_push_code)
do_pushery d []
= return (unitOL (PACK con n_arg_words))
- where
- n_arg_words = d - orig_d
+ where
+ n_arg_words = d - orig_d
-- -----------------------------------------------------------------------------
@@ -709,42 +704,42 @@ mkConAppCode orig_d _ p con args_r_to_l
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
- :: Word16 -> Sequel -> BCEnv
- -> AnnExpr' Id VarSet -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
- return (push `appOL`
- mkSLIDE sz (d-s) `snocOL`
- RETURN_UBX (atomRep arg))
+ return (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
doTailCall
- :: Word16 -> Sequel -> BCEnv
- -> Id -> [AnnExpr' Id VarSet]
- -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
doTailCall init_d s p fn args
= do_pushes init_d args (map atomRep args)
where
do_pushes d [] reps = do
- ASSERT( null reps ) return ()
+ ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- ASSERT( sz == 1 ) return ()
- return (push_fn `appOL` (
- mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
- unitOL ENTER))
+ ASSERT( sz == 1 ) return ()
+ return (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
do_pushes d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
- (these_args, rest_of_args) = splitAt n args
+ (these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
- instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
- -- ^^^ for the PUSH_APPLY_ instruction
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
- (push_code, sz) <- pushAtom d p arg
+ (push_code, sz) <- pushAtom d p arg
(final_d, more_push_code) <- push_seq (d+sz) args
return (final_d, push_code `appOL` more_push_code)
@@ -779,10 +774,10 @@ findPushSeq _
-- Case expressions
doCase :: Word16 -> Sequel -> BCEnv
- -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
- -> Bool -- True <=> is an unboxed tuple case, don't enter the result
- -> BcM BCInstrList
-doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
@@ -790,58 +785,58 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- on top of the itbl.
ret_frame_sizeW = 2
- -- An unlifted value gets an extra info table pushed on top
- -- when it is returned.
- unlifted_itbl_sizeW | isAlgCase = 0
- | otherwise = 1
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
- -- depth of stack after the return value has been pushed
- d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
- -- depth of stack after the extra info table for an unboxed return
- -- has been pushed, if any. This is the stack depth at the
- -- continuation.
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
d_alts = d_bndr + unlifted_itbl_sizeW
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
p_alts = Map.insert bndr (d_bndr - 1) p
- bndr_ty = idType bndr
+ bndr_ty = idType bndr
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeAlt (DEFAULT, _, (_,rhs))
- = do rhs_code <- schemeE d_alts s p_alts rhs
- return (NoDiscr, rhs_code)
+ codeAlt (DEFAULT, _, (_,rhs))
+ = do rhs_code <- schemeE d_alts s p_alts rhs
+ return (NoDiscr, rhs_code)
codeAlt alt@(_, bndrs, (_,rhs))
- -- primitive or nullary constructor alt: no need to UNPACK
- | null real_bndrs = do
- rhs_code <- schemeE d_alts s p_alts rhs
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
- -- algebraic alt with some binders
+ -- algebraic alt with some binders
| otherwise =
let
- (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
- ptr_sizes = map (fromIntegral . idSizeW) ptrs
- nptrs_sizes = map (fromIntegral . idSizeW) nptrs
- bind_sizes = ptr_sizes ++ nptrs_sizes
- size = sum ptr_sizes + sum nptrs_sizes
- -- the UNPACK instruction unpacks in reverse order...
- p' = Map.insertList
- (zip (reverse (ptrs ++ nptrs))
- (mkStackOffsets d_alts (reverse bind_sizes)))
- p_alts
- in do
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+ ptr_sizes = map (fromIntegral . idSizeW) ptrs
+ nptrs_sizes = map (fromIntegral . idSizeW) nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = Map.insertList
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ p_alts
+ in do
MASSERT(isAlgCase)
- rhs_code <- schemeE (d_alts+size) s p' rhs
+ rhs_code <- schemeE (d_alts+size) s p' rhs
return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
where
- real_bndrs = filter (not.isTyCoVar) bndrs
+ real_bndrs = filterOut isTyVar bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
- my_discr (DataAlt dc, _, _)
+ my_discr (DataAlt dc, _, _)
| isUnboxedTupleCon dc
= unboxedTupleException
| otherwise
@@ -854,20 +849,20 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
- maybe_ncons
+ maybe_ncons
| not isAlgCase = Nothing
- | otherwise
+ | otherwise
= case [dc | (DataAlt dc, _, _) <- alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
- -- the bitmap is relative to stack depth d, i.e. before the
- -- BCO, info table and return value are pushed on.
- -- This bit of code is v. similar to buildLivenessMask in CgBindery,
- -- except that here we build the bitmap from the known bindings of
- -- things that are pointers, whereas in CgBindery the code builds the
- -- bitmap from the free slots and unboxed bindings.
- -- (ToDo: merge?)
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
--
-- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
-- The bitmap must cover the portion of the stack up to the sequel only.
@@ -878,32 +873,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
bitmap_size = d-s
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap bitmap_size'{-size-}
+ bitmap = intsToReverseBitmap bitmap_size'{-size-}
(sortLe (<=) (filter (< bitmap_size') rel_slots))
- where
- binds = Map.toList p
- rel_slots = map fromIntegral $ concat (map spread binds)
- spread (id, offset)
- | isFollowableArg (idCgRep id) = [ rel_offset ]
- | otherwise = []
- where rel_offset = d - offset - 1
+ where
+ binds = Map.toList p
+ rel_slots = map fromIntegral $ concat (map spread binds)
+ spread (id, offset)
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
- let
+ let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} bitmap_size bitmap True{-is alts-}
+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--- "\n bitmap = " ++ show bitmap) $ do
+-- "\n bitmap = " ++ show bitmap) $ do
scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
alt_bco' <- emitBc alt_bco
let push_alts
- | isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
return (push_alts `consOL` scrut_code)
@@ -914,17 +909,17 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- deferencing ForeignObj#s and adjusting addrs to point to
-- payloads in Ptr/Byte arrays. Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
--- then return in the right way.
+-- then return in the right way.
-generateCCall :: Word16 -> Sequel -- stack and sequel depths
+generateCCall :: Word16 -> Sequel -- stack and sequel depths
-> BCEnv
- -> CCallSpec -- where to call
- -> Id -- of target, for type info
- -> [AnnExpr' Id VarSet] -- args (atoms)
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
- = let
+ = let
-- useful constants
addr_sizeW :: Word16
addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
@@ -935,19 +930,19 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- CgRep of what was actually pushed.
pargs _ [] = return []
- pargs d (a:az)
+ pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
in case splitTyConApp_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
- Just (t, _)
- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ Just (t, _)
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
return ((code,AddrRep):rest)
- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
return ((code,AddrRep):rest)
@@ -991,18 +986,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
(returns_void, r_rep)
= case maybe_getCCallReturnRep (idType fn) of
Nothing -> (True, VoidRep)
- Just rr -> (False, rr)
+ Just rr -> (False, rr)
{-
- Because the Haskell stack grows down, the a_reps refer to
+ Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
are on the stack. Now push an unboxed Addr# indicating
- the C function to call. Then push a dummy placeholder for the
- result. Finally, emit a CCALL insn with an offset pointing to the
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
address of the piece of marshalling code we generate.
- So, just prior to the CCALL insn, the stack looks like this
+ So, just prior to the CCALL insn, the stack looks like this
(growing down, as usual):
-
+
<arg_n>
...
<arg_1>
@@ -1010,7 +1005,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
<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
@@ -1053,7 +1048,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
| is_static = a_reps_pushed_RAW
- | otherwise = if null a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
else tail a_reps_pushed_RAW
@@ -1062,7 +1057,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
d_after_args + addr_sizeW)
- | otherwise -- is already on the stack
+ | otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
@@ -1070,17 +1065,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
r_sizeW = fromIntegral (primRepSizeW r_rep)
d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
- push_r = (if returns_void
- then nilOL
+ push_r = (if returns_void
+ then nilOL
else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
-- generate the marshalling code we're going to call
- -- Offset of the next stack frame down the stack. The CCALL
- -- instruction needs to describe the chunk of stack containing
- -- the ccall args to the GC, so it needs to know how large it
- -- is. See comment in Interpreter.c with the CCALL instruction.
- stk_offset = d_after_r - s
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
+ stk_offset = d_after_r - s
-- in
-- the only difference in libffi mode is that we prepare a cif
@@ -1119,7 +1114,7 @@ mkDummyLiteral pr
_ -> panic "mkDummyLiteral"
--- Convert (eg)
+-- Convert (eg)
-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
@@ -1136,9 +1131,9 @@ mkDummyLiteral pr
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
= let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
- maybe_r_rep_to_go
+ maybe_r_rep_to_go
= if isSingleton r_reps then Nothing else Just (r_reps !! 1)
- (r_tycon, r_reps)
+ (r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
@@ -1148,19 +1143,19 @@ maybe_getCCallReturnRep fn_ty
&& case maybe_r_rep_to_go of
Nothing -> True
Just r_rep -> r_rep /= PtrRep
- -- if it was, it would be impossible
- -- to create a valid return value
+ -- if it was, it would be impossible
+ -- to create a valid return value
-- placeholder on the stack
blargh :: a -- Used at more than one type
- blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
- in
+ in
--trace (showSDoc (ppr (a_reps, r_reps))) $
if ok then maybe_r_rep_to_go else blargh
-- Compile code which expects an unboxed Int on the top of stack,
--- (call it i), and pushes the i'th closure in the supplied list
+-- (call it i), and pushes the i'th closure in the supplied list
-- as a consequence.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
@@ -1172,13 +1167,13 @@ implement_tagToId names
[0 ..] names
steps = map (mkStep label_exit) infos
return (concatOL steps
- `appOL`
+ `appOL`
toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
where
mkStep l_exit (my_label, next_label, n, name_for_n)
- = toOL [LABEL my_label,
- TESTEQ_I n next_label,
- PUSH_G name_for_n,
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G name_for_n,
JMP l_exit]
@@ -1197,10 +1192,13 @@ implement_tagToId names
pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
-pushAtom d p e
- | Just e' <- bcView e
+pushAtom d p e
+ | Just e' <- bcView e
= pushAtom d p e'
+pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
+ = return (nilOL, 0) -- treated just like a variable VoidArg
+
pushAtom d p (AnnVar v)
| idCgRep v == VoidArg
= return (nilOL, 0)
@@ -1214,19 +1212,19 @@ pushAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
= let l = d - d_v + sz - 2
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
- -- d - d_v the number of words between the TOS
- -- and the 1st slot of the object
- --
- -- d - d_v - 1 the offset from the TOS of the 1st slot
- --
- -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
- -- of the object.
- --
- -- Having found the last slot, we proceed to copy the right number of
- -- slots on to the top of the stack.
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
| otherwise -- v must be a global variable
- = ASSERT(sz == 1)
+ = ASSERT(sz == 1)
return (unitOL (PUSH_G (getName v)), sz)
where
@@ -1242,31 +1240,31 @@ pushAtom _ _ (AnnLit lit)
MachFloat _ -> code FloatArg
MachDouble _ -> code DoubleArg
MachChar _ -> code NonPtrArg
- MachNullAddr -> code NonPtrArg
+ MachNullAddr -> code NonPtrArg
MachStr s -> pushStr s
l -> pprPanic "pushAtom" (ppr l)
where
code rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
- in return (unitOL (PUSH_UBX (Left lit) size_host_words),
+ in return (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
- pushStr s
+ pushStr s
= let getMallocvilleAddr
= case s of
- FastString _ n _ fp _ ->
- -- we could grab the Ptr from the ForeignPtr,
- -- but then we have no way to control its lifetime.
- -- In reality it'll probably stay alive long enoungh
- -- by virtue of the global FastString table, but
- -- to be on the safe side we copy the string into
- -- a malloc'd area of memory.
+ FastString _ n _ fp _ ->
+ -- we could grab the Ptr from the ForeignPtr,
+ -- but then we have no way to control its lifetime.
+ -- In reality it'll probably stay alive long enoungh
+ -- by virtue of the global FastString table, but
+ -- to be on the safe side we copy the string into
+ -- a malloc'd area of memory.
do ptr <- ioToBc (mallocBytes (n+1))
recordMallocBc ptr
ioToBc (
withForeignPtr fp $ \p -> do
- memcpy ptr p (fromIntegral n)
- pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ memcpy ptr p (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
return ptr
)
in do
@@ -1274,11 +1272,8 @@ pushAtom _ _ (AnnLit lit)
-- Get the addr on the stack, untaggedly
return (unitOL (PUSH_UBX (Right addr) 1), 1)
-pushAtom d p (AnnCast e _)
- = pushAtom d p (snd e)
-
pushAtom _ _ expr
- = pprPanic "ByteCodeGen.pushAtom"
+ = pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
foreign import ccall unsafe "memcpy"
@@ -1290,14 +1285,14 @@ foreign import ccall unsafe "memcpy"
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
-mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
- -- a hint; generates better code
- -- Nothing is always safe
- -> [(Discr, BCInstrList)]
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+ -- a hint; generates better code
+ -- Nothing is always safe
+ -> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways
= let d_way = filter (isNoDiscr.fst) raw_ways
- notd_ways = sortLe
+ notd_ways = sortLe
(\w1 w2 -> leAlt (fst w1) (fst w2))
(filter (not.isNoDiscr.fst) raw_ways)
@@ -1305,14 +1300,14 @@ mkMultiBranch maybe_ncons raw_ways
mkTree [] _range_lo _range_hi = return the_default
mkTree [val] range_lo range_hi
- | range_lo `eqAlt` range_hi
+ | range_lo `eqAlt` range_hi
= return (snd val)
| otherwise
= do label_neq <- getLabelBc
- return (testEQ (fst val) label_neq
- `consOL` (snd val
- `appOL` unitOL (LABEL label_neq)
- `appOL` the_default))
+ return (testEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
mkTree vals range_lo range_hi
= let n = length vals `div` 2
@@ -1324,11 +1319,11 @@ mkMultiBranch maybe_ncons raw_ways
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
return (testLT v_mid label_geq
- `consOL` (code_lo
- `appOL` unitOL (LABEL label_geq)
- `appOL` code_hi))
-
- the_default
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
= case d_way of [] -> unitOL CASEFAIL
[(_, def)] -> def
_ -> panic "mkMultiBranch/the_default"
@@ -1353,12 +1348,12 @@ mkMultiBranch maybe_ncons raw_ways
= panic "mkMultiBranch: awesome foursome"
| otherwise
= case fst (head notd_ways) of
- DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
- DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
- DiscrF _ -> ( DiscrF minF, DiscrF maxF )
- DiscrD _ -> ( DiscrD minD, DiscrD maxD )
- DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
- NoDiscr -> panic "mkMultiBranch NoDiscr"
+ DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrF _ -> ( DiscrF minF, DiscrF maxF )
+ DiscrD _ -> ( DiscrD minD, DiscrD maxD )
+ DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+ NoDiscr -> panic "mkMultiBranch NoDiscr"
(algMinBound, algMaxBound)
= case maybe_ncons of
@@ -1388,8 +1383,8 @@ mkMultiBranch maybe_ncons raw_ways
dec (DiscrI i) = DiscrI (i-1)
dec (DiscrW w) = DiscrW (w-1)
dec (DiscrP i) = DiscrP (i-1)
- dec other = other -- not really right, but if you
- -- do cases on floating values, you'll get what you deserve
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
-- same snotty comment applies to the following
minF, maxF :: Float
@@ -1406,7 +1401,7 @@ mkMultiBranch maybe_ncons raw_ways
-- Supporting junk for the compilation schemes
-- Describes case alts
-data Discr
+data Discr
= DiscrI Int
| DiscrW Word
| DiscrF Float
@@ -1431,9 +1426,9 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id))
-- See bug #1257
unboxedTupleException :: a
-unboxedTupleException
- = ghcError
- (ProgramError
+unboxedTupleException
+ = ghcError
+ (ProgramError
("Error: bytecode compiler can't handle unboxed tuples.\n"++
" Possibly due to foreign import/export decls in source.\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
@@ -1443,11 +1438,11 @@ mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
- -- The arguments are returned in *right-to-left* order
+ -- The arguments are returned in *right-to-left* order
splitApp e | Just e' <- bcView e = splitApp e'
-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
- (f', as) -> (f', a:as)
-splitApp e = (e, [])
+splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp e = (e, [])
bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
@@ -1456,23 +1451,25 @@ 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 (AnnLam v (_,e)) | isTyCoVar v = Just e
+bcView (AnnLam v (_,e)) | isTyVar v = Just e
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 (AnnCoercion {}) = True
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 (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
atomRep :: AnnExpr' Id ann -> CgRep
@@ -1493,32 +1490,32 @@ mkStackOffsets original_depth szsw
type BcPtr = Either ItblPtr (Ptr ())
-data BcM_State
- = BcM_State {
+data BcM_State
+ = BcM_State {
uniqSupply :: UniqSupply, -- for generating fresh variable names
- nextlabel :: Word16, -- for generating local labels
- malloced :: [BcPtr], -- thunks malloced for current BCO
- -- Should be free()d when it is GCd
- breakArray :: BreakArray -- array of breakpoint flags
+ nextlabel :: Word16, -- for generating local labels
+ malloced :: [BcPtr], -- thunks malloced for current BCO
+ -- Should be free()d when it is GCd
+ breakArray :: BreakArray -- array of breakpoint flags
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
ioToBc :: IO a -> BcM a
-ioToBc io = BcM $ \st -> do
- x <- io
+ioToBc io = BcM $ \st -> do
+ x <- io
return (st, x)
runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us modBreaks (BcM m)
- = m (BcM_State us 0 [] breakArray)
+runBc us modBreaks (BcM m)
+ = m (BcM_State us 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
(st1, q) <- expr st0
- let BcM k = cont q
+ let BcM k = cont q
(st2, r) <- k st1
return (st2, r)
@@ -1557,10 +1554,10 @@ getLabelBc
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
- = BcM $ \st -> let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
-getBreakArray :: BcM BreakArray
+getBreakArray :: BcM BreakArray
getBreakArray = BcM $ \st -> return (st, breakArray st)
newUnique :: BcM Unique
@@ -1570,7 +1567,7 @@ newUnique = BcM $
in return (newState, uniq)
newId :: Type -> BcM Id
-newId ty = do
+newId ty = do
uniq <- newUnique
return $ mkSysLocal tickFS uniq ty
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index d44a00bc1415971888c7944c11c200ade791ddc3..49c5488efad9f93e03da5ef81c7842baaa1d8a09 100644
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -124,7 +124,7 @@ data BCInstr
| CASEFAIL
| JMP LocalLabel
- -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
+ -- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
Word16 -- whether or not the call is interruptible
diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs
index 310ddb5e9b70ad33978c8f0776f27919137a5825..cd593f7b45027acd4c167bec8a67ae2bb76c1b97 100644
--- a/compiler/ghci/ObjLink.lhs
+++ b/compiler/ghci/ObjLink.lhs
@@ -28,6 +28,8 @@ import Control.Monad ( when )
import Foreign.C
import Foreign ( nullPtr )
import GHC.Exts ( Ptr(..) )
+import GHC.IO.Encoding ( fileSystemEncoding )
+import qualified GHC.Foreign as GHC
@@ -35,17 +37,21 @@ import GHC.Exts ( Ptr(..) )
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
+-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
+withFileCString :: FilePath -> (CString -> IO a) -> IO a
+withFileCString = GHC.withCString fileSystemEncoding
+
insertSymbol :: String -> String -> Ptr a -> IO ()
insertSymbol obj_name key symbol
= let str = prefixUnderscore key
- in withCString obj_name $ \c_obj_name ->
- withCString str $ \c_str ->
+ in withFileCString obj_name $ \c_obj_name ->
+ withCAString str $ \c_str ->
c_insertSymbol c_obj_name c_str symbol
lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCString str $ \c_str -> do
+ withCAString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
@@ -60,7 +66,7 @@ loadDLL :: String -> IO (Maybe String)
-- Nothing => success
-- Just err_msg => failure
loadDLL str = do
- maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+ maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr
then return Nothing
else do str <- peekCString maybe_errmsg
@@ -68,19 +74,19 @@ loadDLL str = do
loadArchive :: String -> IO ()
loadArchive str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadArchive c_str
when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
loadObj :: String -> IO ()
loadObj str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadObj c_str
when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
unloadObj :: String -> IO ()
unloadObj str =
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_unloadObj c_str
when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 9f5b52d9a17556b697755c01b0e932057c3cb4f0..2ac5b5d5c29ae1c211a5295b9602cc659573d768 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -45,22 +45,19 @@ import TyCon
import Name
import VarEnv
import Util
-import ListSetOps
import VarSet
import TysPrim
import PrelNames
import TysWiredIn
import DynFlags
-import Outputable
+import Outputable as Ppr
import FastString
--- import Panic
-
import Constants ( wORD_SIZE )
-
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO ( IO(..) )
+import StaticFlags( opt_PprStyle_Debug )
import Control.Monad
import Data.Maybe
import Data.Array.Base
@@ -186,7 +183,7 @@ getClosureData a =
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
nptrs_data = [W# (indexWordArray# nptrs i)
- | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+ | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
ASSERT(elems >= 0) return ()
ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
@@ -346,10 +343,17 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt}
= parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
<+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
- | null tt = return$ ppr dc
- | otherwise = do
- tt_docs <- mapM (y app_prec) tt
- return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+ | null sub_terms_to_show
+ = return (ppr dc)
+ | otherwise
+ = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
+ ; return $ cparen (p >= app_prec) $
+ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
+ where
+ sub_terms_to_show -- Don't show the dictionary arguments to
+ -- constructors unless -dppr-debug is on
+ | opt_PprStyle_Debug = tt
+ | otherwise = dropList (dataConTheta dc) tt
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do
@@ -414,55 +418,70 @@ cPprTerm printers_ = go 0 where
firstJustM [] = return Nothing
-- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase y =
[ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
. mapM (y (-1))
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
- (\ p t -> doList p t)
- , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
- , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
- , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
- , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
- , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
+ ppr_list
+ , ifTerm (isTyCon intTyCon . ty) ppr_int
+ , ifTerm (isTyCon charTyCon . ty) ppr_char
+ , ifTerm (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+ , ifTerm (isIntegerTy . ty) ppr_integer
]
- where ifTerm pred f prec t@Term{}
- | pred t = Just `liftM` f prec t
- ifTerm _ _ _ _ = return Nothing
-
- isTupleTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (isBoxedTupleTyCon tc)
-
- isTyCon a_tc ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (a_tc == tc)
-
- isIntegerTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (tyConName tc == integerTyConName)
-
- coerceShow f _p = return . text . show . f . unsafeCoerce# . val
-
- --Note pprinting of list terms is not lazy
- doList p (Term{subTerms=[h,t]}) = do
- let elems = h : getListTerms t
- isConsLast = not(termType(last elems) `coreEqType` termType h)
- print_elems <- mapM (y cons_prec) elems
- return$ if isConsLast
- then cparen (p >= cons_prec)
- . pprDeeperList fsep
- . punctuate (space<>colon)
- $ print_elems
- else brackets (pprDeeperList fcat$
- punctuate comma print_elems)
-
- where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
- getListTerms Term{subTerms=[]} = []
- getListTerms t@Suspension{} = [t]
- getListTerms t = pprPanic "getListTerms" (ppr t)
- doList _ _ = panic "doList"
+ where
+ ifTerm :: (Term -> Bool)
+ -> (Precedence -> Term -> m SDoc)
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (isBoxedTupleTyCon tc)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
+ :: Precedence -> Term -> m SDoc
+ ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
+ ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+ ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
+ ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
+ ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+ --Note pprinting of list terms is not lazy
+ ppr_list :: Precedence -> Term -> m SDoc
+ ppr_list p (Term{subTerms=[h,t]}) = do
+ let elems = h : getListTerms t
+ isConsLast = not(termType(last elems) `eqType` termType h)
+ is_string = all (isCharTy . ty) elems
+
+ print_elems <- mapM (y cons_prec) elems
+ if is_string
+ then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ else if isConsLast
+ then return $ cparen (p >= cons_prec)
+ $ pprDeeperList fsep
+ $ punctuate (space<>colon) print_elems
+ else return $ brackets
+ $ pprDeeperList fcat
+ $ punctuate comma print_elems
+
+ where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+ getListTerms Term{subTerms=[]} = []
+ getListTerms t@Suspension{} = [t]
+ getListTerms t = pprPanic "getListTerms" (ppr t)
+ ppr_list _ _ = panic "doList"
repPrim :: TyCon -> [Word] -> String
@@ -566,13 +585,18 @@ liftTcM = id
newVar :: Kind -> TR TcType
newVar = liftTcM . newFlexiTyVarTy
+instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars = liftTcM . tcInstTyVars
+
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
@@ -658,7 +682,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Type obtained: " <> ppr (termType term))
return term
where
+
go :: Int -> Type -> Type -> HValue -> TcM Term
+ -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
go max_depth _ _ _ | seq max_depth False = undefined
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
@@ -704,7 +731,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
traceTR (text "entering a constructor " <>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
- else Outputable.empty)
+ else Ppr.empty)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
@@ -713,59 +740,34 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- In such case, we return a best approximation:
-- ignore the unpointed args, and recover the pointeds
-- This preserves laziness, and should be safe.
+ traceTR (text "Nothing" <+> ppr dcname)
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
- (newVar (liftedTypeKind))
+ (newVar liftedTypeKind)
subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
- let subTtypes = matchSubTypes dc old_ty
- subTermTvs <- mapMif (not . isMonomorphic)
- (\t -> newVar (typeKind t))
- subTtypes
- let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
- || isRefType ty)
- (zip subTtypes subTermTvs)
- (subTtypesP, subTermTvsP ) = unzip subTermsP
- (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
-
- -- When we already have all the information, avoid solving
- -- unnecessary constraints. Propagation of type information
- -- to subterms is already being done via matching.
- when (not monomorphic) $ do
- let myType = mkFunTys subTermTvs my_ty
- (signatureType,_) <- instScheme (mydataConType dc)
- -- It is vital for newtype reconstruction that the unification step
- -- is done right here, _before_ the subterms are RTTI reconstructed
- addConstraint myType signatureType
+ traceTR (text "Just" <+> ppr dc)
+ subTtypes <- getDataConArgTys dc my_ty
+ let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
subTermsP <- sequence
- [ appArr (go (pred max_depth) tv t) (ptrs clos) i
- | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
+ [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
+ | (i,ty) <- zip [0..] subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
- subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+ subTermsNP = zipWith Prim subTtypesNP unboxeds
subTerms = reOrderTerms subTermsP subTermsNP subTtypes
return (Term my_ty (Right dc) a subTerms)
+
-- The otherwise case: can be a Thunk,AP,PAP,etc.
tipe_clos ->
return (Suspension tipe_clos my_ty a Nothing)
- matchSubTypes dc ty
- | ty' <- repType ty -- look through newtypes
- , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
- , dc `elem` tyConDataCons tc
- -- It is necessary to check that dc is actually a constructor for tycon tc,
- -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
- -- has not removed it. In that case, we happily give up and don't match
- = myDataConInstArgTys dc ty_args
- | otherwise = dataConRepArgTys dc
-
-- put together pointed and nonpointed subterms in the
-- correct order.
reOrderTerms _ _ [] = []
reOrderTerms pointed unpointed (ty:tys)
- | isLifted ty || isRefType ty
- = ASSERT2(not(null pointed)
+ | isPtrType ty = ASSERT2(not(null pointed)
, ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
@@ -835,6 +837,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
-- returns unification tasks,since we are going to want a breadth-first search
go :: Type -> HValue -> TR [(Type, HValue)]
go my_ty a = do
+ traceTR (text "go" <+> ppr my_ty)
clos <- trIO $ getClosureData a
case tipe clos of
Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
@@ -847,6 +850,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
return [(tv', contents)]
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ traceTR (text "Constr1" <+> ppr dcname)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
@@ -856,17 +860,10 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
return$ appArr (\e->(tv,e)) (ptrs clos) i
Just dc -> do
- subTtypes <- mapMif (not . isMonomorphic)
- (\t -> newVar (typeKind t))
- (dataConRepArgTys dc)
-
- -- It is vital for newtype reconstruction that the unification step
- -- is done right here, _before_ the subterms are RTTI reconstructed
- let myType = mkFunTys subTtypes my_ty
- (signatureType,_) <- instScheme (mydataConType dc)
- addConstraint myType signatureType
- return $ [ appArr (\e->(t,e)) (ptrs clos) i
- | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
+ arg_tys <- getDataConArgTys dc my_ty
+ traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+ return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
+ | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
_ -> return []
-- Compute the difference between a base type and the type found by RTTI
@@ -877,36 +874,36 @@ improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
improveRTTIType _ base_ty new_ty
= U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
-myDataConInstArgTys :: DataCon -> [Type] -> [Type]
-myDataConInstArgTys dc args
- | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
- | otherwise = dataConRepArgTys dc
-
-mydataConType :: DataCon -> QuantifiedType
--- ^ Custom version of DataCon.dataConUserType where we
--- - remove the equality constraints
--- - use the representation types for arguments, including dictionaries
--- - keep the original result type
-mydataConType dc
- = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
- , mkFunTys arg_tys res_ty )
- where univ_tvs = dataConUnivTyVars dc
- ex_tvs = dataConExTyVars dc
- eq_spec = dataConEqSpec dc
- arg_tys = [case a of
- PredTy p -> predTypeRep p
- _ -> a
- | a <- dataConRepArgTys dc]
- res_ty = dataConOrigResTy dc
-
-isRefType :: Type -> Bool
-isRefType ty
- | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
- | otherwise = False
- where ty'= repType ty
-
-isRefTyCon :: TyCon -> Bool
-isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty)
+-- return the types of the arguments. This is RTTI-land, so 'ty' might
+-- not be fully known. Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+getDataConArgTys dc con_app_ty
+ = do { (_, ex_tys, _) <- instTyVars ex_tvs
+ ; let rep_con_app_ty = repType con_app_ty
+ ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
+ Just (tc, ty_args) | dataConTyCon dc == tc
+ -> ASSERT( univ_tvs `equalLength` ty_args)
+ return ty_args
+ _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs
+ ; let res_ty = substTy subst (dataConOrigResTy dc)
+ ; addConstraint rep_con_app_ty res_ty
+ ; return ty_args }
+ -- It is necessary to check dataConTyCon dc == tc
+ -- because it may be the case that tc is a recursive
+ -- newtype and tcSplitTyConApp has not removed it. In
+ -- that case, we happily give up and don't match
+ ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+ ; return (substTys subst (dataConRepArgTys dc)) }
+ where
+ univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+
+isPtrType :: Type -> Bool
+isPtrType ty = case typePrimRep ty of
+ PtrRep -> True
+ _ -> False
-- Soundness checks
--------------------
@@ -1103,7 +1100,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
| otherwise = do
traceTR (text "(Upgrade) upgraded " <> ppr ty <>
text " in presence of newtype evidence " <> ppr new_tycon)
- vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+ (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon vars
_ <- liftTcM (unifyType ty (repType ty'))
-- assumes that reptype doesn't ^^^^ touch tyconApp args
@@ -1130,9 +1127,9 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
- -- This is where RuntimeUnkSkols are born:
+ -- This is where RuntimeUnks are born:
-- otherwise-unconstrained unification variables are
- -- turned into RuntimeUnkSkols as they leave the
+ -- turned into RuntimeUnks as they leave the
-- typechecker's monad
; return (mkTyVarTy tv') }
@@ -1183,12 +1180,6 @@ quantifyType :: Type -> QuantifiedType
-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
-mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
-mapMif pred f xx = sequence $ mapMif_ pred f xx
- where
- mapMif_ _ _ [] = []
- mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
-
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM condM acc = condM >>= \c -> unless c acc
@@ -1205,24 +1196,10 @@ amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
where g (I# i#) = case indexArray# arr# i# of
(# e #) -> f e
-
-isLifted :: Type -> Bool
-isLifted = not . isUnLiftedType
-
extractUnboxed :: [Type] -> Closure -> [[Word]]
extractUnboxed tt clos = go tt (nonPtrs clos)
- where sizeofType t
- | Just (tycon,_) <- tcSplitTyConApp_maybe t
- = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
- | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
+ where sizeofType t = primRepSizeW (typePrimRep t)
go [] _ = []
go (t:tt) xx
| (x, rest) <- splitAt (sizeofType t) xx
= x : go tt rest
-
-sizeofTyCon :: TyCon -> Int -- in *words*
-sizeofTyCon = primRepSizeW . tyConPrimRep
-
-
-(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
-(f |.| g) x = f x || g x
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b5e6c4129edfbeb077412802c5c6713c8aa9745a..492f2552cdb5a9074430ec235e2ffaf10b3df7ba 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts
| null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
| otherwise
= do { stmts' <- cvtStmts stmts
- ; body <- case last stmts' of
- L _ (ExprStmt body _ _) -> return body
- stmt' -> failWith (bad_last stmt')
- ; return $ HsDo do_or_lc (init stmts') body void }
+ ; let Just (stmts'', last') = snocView stmts'
+
+ ; last'' <- case last' of
+ L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
+ _ -> failWith (bad_last last')
+
+ ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
where
- bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
+ bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, ptext (sLit "(It should be an expression.)") ]
@@ -539,7 +542,7 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
; returnL $ LetStmt ds' }
-cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
+cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
@@ -565,7 +568,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional r placeHolderType}
+ = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
@@ -599,8 +602,8 @@ allCharLs xs
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
-cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
-cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
+cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
@@ -765,6 +768,9 @@ overloadedLit _ = False
void :: Type.Type
void = placeHolderType
+cvtFractionalLit :: Rational -> FractionalLit
+cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
+
--------------------------------------------------------------------
-- Turning Name back into RdrName
--------------------------------------------------------------------
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index e080bee8cf70b70482502fe2d373b0f89e627240..5871914ad864a4ec6152b8e8b8f89a35f0fecb1c 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -69,23 +69,23 @@ data HsLocalBindsLR idL idR -- Bindings in a 'let' expression
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
- = ValBindsIn -- Before renaming
+ = ValBindsIn -- Before renaming RHS; idR is always RdrName
(LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
-- Recursive by default
- | ValBindsOut -- After renaming
+ | ValBindsOut -- After renaming RHS; idR can be Name or Id
[(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
-- in the list may depend on earlier
-- ones.
[LSig Name]
deriving (Data, Typeable)
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind id = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBind id = LHsBindLR id id
+type LHsBinds id = LHsBindsLR id id
+type HsBind id = HsBindLR id id
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
+type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
= -- | FunBind is used for both functions @f x = e@
@@ -357,7 +357,7 @@ data IPBind id
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
- $$ ifPprDebug (ppr ds)
+ $$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -457,7 +457,7 @@ data EvTerm
deriving( Data, Typeable)
evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
| otherwise = EvId v
\end{code}
@@ -546,7 +546,7 @@ pprHsWrapper doc wrap
help it WpHole = it
help it (WpCompose f1 f2) = help (help it f2) f1
help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
- <+> pprParendType co)]
+ <+> pprParendCo co)]
help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
@@ -572,8 +572,8 @@ instance Outputable EvBind where
instance Outputable EvTerm where
ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
- ppr (EvCoercion co) = ppr co
+ ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
+ ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
\end{code}
@@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
+ -- A type signature for a default method inside a class
+ -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
+ | GenericSig (Located name) (LHsType name)
+
-- A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
@@ -666,29 +670,27 @@ okBindSig :: Sig a -> Bool
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig _ _) = True
-okHsBootSig (FixSig _) = True
-okHsBootSig _ = False
+okHsBootSig (TypeSig _ _) = True
+okHsBootSig (GenericSig _ _) = False
+okHsBootSig (FixSig _) = True
+okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
-okInstDclSig (TypeSig _ _) = False
-okInstDclSig (FixSig _) = False
-okInstDclSig _ = True
-
-sigForThisGroup :: NameSet -> LSig Name -> Bool
-sigForThisGroup ns sig
- = case sigName sig of
- Nothing -> False
- Just n -> n `elemNameSet` ns
+okInstDclSig (TypeSig _ _) = False
+okInstDclSig (GenericSig _ _) = False
+okInstDclSig (FixSig _) = False
+okInstDclSig _ = True
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)
@@ -706,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
-isTypeLSig (L _(TypeSig {})) = True
-isTypeLSig (L _(IdSig {})) = True
-isTypeLSig _ = False
+isTypeLSig (L _(TypeSig {})) = True
+isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(IdSig {})) = True
+isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
@@ -731,6 +734,7 @@ isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
+hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
@@ -745,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
+eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
@@ -758,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 345ec32ef31dbc3036c6ff1822bee38909818f05..c05f26a5fc85eb6e1844fabd705602d982eda3e3 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -3,15 +3,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-
-
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
-- | Abstract syntax of global declarations.
@@ -630,15 +622,15 @@ instance OutputableBndr name
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head (unLoc context) ltycon tyvars typats <+>
- ppr_sig mb_sig)
+ ppr_sigx mb_sig)
(pp_condecls condecls)
derivings
where
- ppr_sig Nothing = empty
- ppr_sig (Just kind) = dcolon <+> pprKind kind
+ ppr_sigx Nothing = empty
+ ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
- tcdFDs = fds,
+ tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
| null sigs && null ats -- No "where" part
= top_matter
@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
- = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
+ = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
- ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
- ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
- ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
+ ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
+ ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
+ ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
%************************************************************************
%* *
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
@@ -835,14 +827,14 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
%************************************************************************
%* *
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
-data DerivDecl name = DerivDecl (LHsType name)
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 06616f16d9041cf2c9965f76207eed98b1a60649..dd33cae373f5d836773c5bd94be8ea03728a038b 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -23,6 +23,8 @@ import Name
import BasicTypes
import DataCon
import SrcLoc
+import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
@@ -146,8 +148,6 @@ data HsExpr id
-- because in this context we never use
-- the PatGuard or ParStmt variant
[LStmt id] -- "do":one or more stmts
- (LHsExpr id) -- The body; the last expression in the
- -- 'do' of [ body | ... ] in a list comp
PostTcType -- Type of the whole expression
| ExplicitList -- syntactic list
@@ -439,7 +439,7 @@ ppr_expr (HsLet binds expr)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
+ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
@@ -575,7 +575,7 @@ pprParendExpr expr
HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was
- HsDo sc _ _ _
+ HsDo sc _ _
| isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was
@@ -830,51 +830,59 @@ type LStmtLR idL idR = Located (StmtLR idL idR)
type Stmt id = StmtLR id id
--- The SyntaxExprs in here are used *only* for do-notation, which
--- has rebindable syntax. Otherwise they are unused.
+-- The SyntaxExprs in here are used *only* for do-notation and monad
+-- comprehensions, which have rebindable syntax. Otherwise they are unused.
data StmtLR idL idR
- = BindStmt (LPat idL)
+ = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp,
+ -- and (after the renamer) DoExpr, MDoExpr
+ -- Not used for GhciStmt, PatGuard, which scope over other stuff
+ (LHsExpr idR)
+ (SyntaxExpr idR) -- The return operator, used only for MonadComp
+ -- For ListComp, PArrComp, we use the baked-in 'return'
+ -- For DoExpr, MDoExpr, we don't appply a 'return' at all
+ -- See Note [Monad Comprehensions]
+ | BindStmt (LPat idL)
(LHsExpr idR)
- (SyntaxExpr idR) -- The (>>=) operator
+ (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
| ExprStmt (LHsExpr idR) -- See Note [ExprStmt]
(SyntaxExpr idR) -- The (>>) operator
+ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
+ -- See notes [Monad Comprehensions]
PostTcType -- Element type of the RHS (used for arrows)
| LetStmt (HsLocalBindsLR idL idR)
- -- ParStmts only occur in a list comprehension
+ -- ParStmts only occur in a list/monad comprehension
| ParStmt [([LStmt idL], [idR])]
- -- After renaming, the ids are the binders bound by the stmts and used
- -- after them
-
- -- "qs, then f by e" ==> TransformStmt qs binders f (Just e)
- -- "qs, then f" ==> TransformStmt qs binders f Nothing
- | TransformStmt
- [LStmt idL] -- Stmts are the ones to the left of the 'then'
-
- [idR] -- After renaming, the IDs are the binders occurring
- -- within this transform statement that are used after it
-
- (LHsExpr idR) -- "then f"
-
- (Maybe (LHsExpr idR)) -- "by e" (optional)
-
- | GroupStmt
- [LStmt idL] -- Stmts to the *left* of the 'group'
- -- which generates the tuples to be grouped
-
- [(idR, idR)] -- See Note [GroupStmt binder map]
+ (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions
+ (SyntaxExpr idR) -- The `>>=` operator
+ (SyntaxExpr idR) -- Polymorphic `return` operator
+ -- with type (forall a. a -> m a)
+ -- See notes [Monad Comprehensions]
+ -- After renaming, the ids are the binders
+ -- bound by the stmts and used after themp
+
+ | TransStmt {
+ trS_form :: TransForm,
+ trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group'
+ -- which generates the tuples to be grouped
+
+ trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map]
- (Maybe (LHsExpr idR)) -- "by e" (optional)
+ trS_using :: LHsExpr idR,
+ trS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
+ -- Invariant: if trS_form = GroupBy, then grp_by = Just e
- (Either -- "using f"
- (LHsExpr idR) -- Left f => explicit "using f"
- (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith'
-
+ trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
+ -- the inner monad comprehensions
+ trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
+ trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring
+ -- Only for 'group' forms
+ } -- See Note [Monad Comprehensions]
-- Recursive statement (see Note [How RecStmt works] below)
| RecStmt
@@ -905,20 +913,44 @@ data StmtLR idL idR
-- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*,
-- so they may be type applications
+
+ , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) }
+ -- With rebindable syntax the type might not
+ -- be quite as simple as (m (tya, tyb, tyc)).
}
deriving (Data, Typeable)
+
+data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
+ = ThenForm -- then f or then f by e
+ | GroupFormU -- group using f or group using f by e
+ | GroupFormB -- group by e
+ -- In the GroupByFormB, trS_using is filled in with
+ -- 'groupWith' (list comprehensions) or
+ -- 'groupM' (monad comprehensions)
+ deriving (Data, Typeable)
\end{code}
-Note [GroupStmt binder map]
+Note [The type of bind in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Stmts, notably BindStmt, keep the (>>=) bind operator.
+We do NOT assume that it has type
+ (>>=) :: m a -> (a -> m b) -> m b
+In some cases (see Trac #303, #1537) it might have a more
+exotic type, such as
+ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+So we must be careful not to make assumptions about the type.
+In particular, the monad may not be uniform throughout.
+
+Note [TransStmt binder map]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The [(idR,idR)] in a GroupStmt behaves as follows:
+The [(idR,idR)] in a TransStmt behaves as follows:
* Before renaming: []
* After renaming:
[ (x27,x27), ..., (z35,z35) ]
These are the variables
- bound by the stmts to the left of the 'group'
+ bound by the stmts to the left of the 'group'
and used either in the 'by' clause,
or in the stmts following the 'group'
Each item is a pair of identical variables.
@@ -952,7 +984,13 @@ depends on the context. Consider the following contexts:
E :: Bool
Translation: if E then fail else ...
-Array comprehensions are handled like list comprehensions -=chak
+ A monad comprehension of type (m res_ty)
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * ExprStmt E Bool: [ .. | .... E ]
+ E :: Bool
+ Translation: guard E >> ...
+
+Array comprehensions are handled like list comprehensions.
Note [How RecStmt works]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -993,23 +1031,60 @@ A (RecStmt stmts) types as if you had written
where v1..vn are the later_ids
r1..rm are the rec_ids
+Note [Monad Comprehensions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Monad comprehensions require separate functions like 'return' and
+'>>=' for desugaring. These functions are stored in the statements
+used in monad comprehensions. For example, the 'return' of the 'LastStmt'
+expression is used to lift the body of the monad comprehension:
+
+ [ body | stmts ]
+ =>
+ stmts >>= \bndrs -> return body
+
+In transform and grouping statements ('then ..' and 'then group ..') the
+'return' function is required for nested monad comprehensions, for example:
+
+ [ body | stmts, then f, rest ]
+ =>
+ f [ env | stmts ] >>= \bndrs -> [ body | rest ]
+
+ExprStmts require the 'Control.Monad.guard' function for boolean
+expressions:
+
+ [ body | exp, stmts ]
+ =>
+ guard exp >> [ body | stmts ]
+
+Grouping/parallel statements require the 'Control.Monad.Group.groupM' and
+'Control.Monad.Zip.mzip' functions:
+
+ [ body | stmts, then group by e, rest]
+ =>
+ groupM [ body | stmts ] >>= \bndrs -> [ body | rest ]
+
+ [ body | stmts1 | stmts2 | .. ]
+ =>
+ mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body
+
+In any other context than 'MonadComp', the fields for most of these
+'SyntaxExpr's stay bottom.
+
\begin{code}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
+pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
-pprStmt (ExprStmt expr _ _) = ppr expr
-pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss)
+pprStmt (ExprStmt expr _ _ _) = ppr expr
+pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
-pprStmt (TransformStmt stmts bndrs using by)
- = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
-
-pprStmt (GroupStmt stmts _ by using)
- = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+ = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
@@ -1024,40 +1099,47 @@ pprTransformStmt bndrs using by
, nest 2 (ppr using)
, nest 2 (pprBy by)]
-pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
- -> Either (LHsExpr id) (SyntaxExpr is)
+pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id)
+ -> LHsExpr id -> TransForm
-> SDoc
-pprGroupStmt by using
- = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
- where
- ppr_using (Right _) = empty
- ppr_using (Left e) = ptext (sLit "using") <+> ppr e
+pprTransStmt by using ThenForm
+ = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
+pprTransStmt by _ GroupFormB
+ = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ]
+pprTransStmt by using GroupFormU
+ = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e
-pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
-pprDo ListComp stmts body = brackets $ pprComp stmts body
-pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body
-pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-
-ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
+pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
+pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
+pprDo ListComp stmts = brackets $ pprComp stmts
+pprDo PArrComp stmts = pa_brackets $ pprComp stmts
+pprDo MonadComp stmts = brackets $ pprComp stmts
+pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
+
+ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc
-- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs
-ppr_do_stmts stmts body
- = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body])
+ppr_do_stmts stmts
+ = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
<+> rbrace
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
-pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-pprComp quals body -- Prints: body | qual1, ..., qualn
- = hang (ppr body <+> char '|') 2 (interpp'SP quals)
+pprComp :: OutputableBndr id => [LStmt id] -> SDoc
+pprComp quals -- Prints: body | qual1, ..., qualn
+ | not (null quals)
+ , L _ (LastStmt body _) <- last quals
+ = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals))
+ | otherwise
+ = pprPanic "pprComp" (interpp'SP quals)
\end{code}
%************************************************************************
@@ -1175,26 +1257,35 @@ data HsMatchContext id -- Context of a Match
data HsStmtContext id
= ListComp
- | DoExpr
- | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
- | MDoExpr -- Recursive do-expression
+ | MonadComp
| PArrComp -- Parallel array comprehension
+
+ | DoExpr -- do { ... }
+ | MDoExpr -- mdo { ... } ie recursive do-expression
+ | ArrowExpr -- do-notation in an arrow-command context
+
+ | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
- | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
+ | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
deriving (Data, Typeable)
\end{code}
\begin{code}
-isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr = True
-isDoExpr MDoExpr = True
-isDoExpr _ = False
-
isListCompExpr :: HsStmtContext id -> Bool
-isListCompExpr ListComp = True
-isListCompExpr PArrComp = True
-isListCompExpr _ = False
+-- Uses syntax [ e | quals ]
+isListCompExpr ListComp = True
+isListCompExpr PArrComp = True
+isListCompExpr MonadComp = True
+isListCompExpr (ParStmtCtxt c) = isListCompExpr c
+isListCompExpr (TransStmtCtxt c) = isListCompExpr c
+isListCompExpr _ = False
+
+isMonadCompExpr :: HsStmtContext id -> Bool
+isMonadCompExpr MonadComp = True
+isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr _ = False
\end{code}
\begin{code}
@@ -1231,33 +1322,41 @@ pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction")
pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
$$ pprStmtContext ctxt
-pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+-----------------
+pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+pprAStmtContext ctxt = article <+> pprStmtContext ctxt
+ where
+ pp_an = ptext (sLit "an")
+ pp_a = ptext (sLit "a")
+ article = case ctxt of
+ MDoExpr -> pp_an
+ PArrComp -> pp_an
+ GhciStmt -> pp_an
+ _ -> pp_a
+
+
+-----------------
+pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command")
+pprStmtContext DoExpr = ptext (sLit "'do' block")
+pprStmtContext MDoExpr = ptext (sLit "'mdo' block")
+pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command")
+pprStmtContext ListComp = ptext (sLit "list comprehension")
+pprStmtContext MonadComp = ptext (sLit "monad comprehension")
+pprStmtContext PArrComp = ptext (sLit "array comprehension")
+pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt
+
+-- Drop the inner contexts when reporting errors, else we get
+-- Unexpected transform statement
+-- in a transformed branch of
+-- transformed branch of
+-- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c)
- = sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
-pprStmtContext (TransformStmtCtxt c)
- = sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
-pprStmtContext (PatGuard ctxt)
- = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
-pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
-pprStmtContext DoExpr = ptext (sLit "a 'do' expression")
-pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression")
-pprStmtContext ListComp = ptext (sLit "a list comprehension")
-pprStmtContext PArrComp = ptext (sLit "an array comprehension")
-
-{-
-pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative")
-pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda")
-pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc")
-pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt
-
--- Used for the result statement of comprehension
--- e.g. the 'e' in [ e | ... ]
--- or the 'r' in f x = r
-pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
-pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other
--}
+ | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
+pprStmtContext (TransStmtCtxt c)
+ | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
+
-- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
@@ -1268,14 +1367,16 @@ matchContextErrString RecUpd = ptext (sLit "record update")
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
-matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
-matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression")
-matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression")
-matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
-matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
+matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
+matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
+matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block")
+matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
+matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension")
+matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
\end{code}
\begin{code}
@@ -1286,11 +1387,16 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <>
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsStmtContext idL -> StmtLR idL idR -> SDoc
-pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
- 4 (ppr_stmt stmt)
+pprStmtInCtxt ctxt (LastStmt e _)
+ | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
+ = hang (ptext (sLit "In the expression:")) 2 (ppr e)
+
+pprStmtInCtxt ctxt stmt
+ = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon)
+ 2 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
- ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
- ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by
- ppr_stmt stmt = pprStmt stmt
+ ppr_stmt (TransStmt { trS_by = by, trS_using = using
+ , trS_form = form }) = pprTransStmt by using form
+ ppr_stmt stmt = pprStmt stmt
\end{code}
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index dd24aedb2b4704eeffcea2cc83d92e0b14bc2795..176182e98b725f91552c7d3c562ac530f02201a6 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -6,12 +6,6 @@
HsImpExp: Abstract syntax: imports, exports, interfaces
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
module HsImpExp where
@@ -21,7 +15,7 @@ import HsDoc ( HsDocString )
import Outputable
import FastString
-import SrcLoc ( Located(..) )
+import SrcLoc ( Located(..), noLoc )
import Data.Data
\end{code}
@@ -46,6 +40,16 @@ data ImportDecl name
ideclAs :: Maybe ModuleName, -- ^ as Module
ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
} deriving (Data, Typeable)
+
+simpleImportDecl :: ModuleName -> ImportDecl name
+simpleImportDecl mn = ImportDecl {
+ ideclName = noLoc mn,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclQualified = False,
+ ideclAs = Nothing,
+ ideclHiding = Nothing
+ }
\end{code}
\begin{code}
@@ -103,6 +107,7 @@ ieName (IEVar n) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
+ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
@@ -122,8 +127,8 @@ instance (Outputable name) => Outputable (IE name) where
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
- ppr (IEModuleContents mod)
- = ptext (sLit "module") <+> ppr mod
+ ppr (IEModuleContents mod')
+ = ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index 0874dda85815c116abd60da8f908ffbc8bb92078..2cda10347982ebb11f741740f41f846dde156ff8 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -12,7 +12,8 @@ module HsLit where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import HsTypes (PostTcType)
+import BasicTypes ( FractionalLit(..) )
+import HsTypes ( PostTcType )
import Type ( Type )
import Outputable
import FastString
@@ -40,10 +41,10 @@ data HsLit
| HsWordPrim Integer -- Unboxed Word
| HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION
+ | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsFloatPrim Rational -- Unboxed Float
- | HsDoublePrim Rational -- Unboxed Double
+ | HsFloatPrim FractionalLit -- Unboxed Float
+ | HsDoublePrim FractionalLit -- Unboxed Double
deriving (Data, Typeable)
instance Eq HsLit where
@@ -63,15 +64,14 @@ instance Eq HsLit where
data HsOverLit id -- An overloaded literal
= OverLit {
ol_val :: OverLitVal,
- ol_rebindable :: Bool, -- True <=> rebindable syntax
- -- False <=> standard syntax
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
ol_type :: PostTcType }
deriving (Data, Typeable)
data OverLitVal
= HsIntegral !Integer -- Integer-looking literals;
- | HsFractional !Rational -- Frac-looking literals
+ | HsFractional !FractionalLit -- Frac-looking literals
| HsIsString !FastString -- String-looking literals
deriving (Data, Typeable)
@@ -79,6 +79,19 @@ overLitType :: HsOverLit a -> Type
overLitType = ol_type
\end{code}
+Note [ol_rebindable]
+~~~~~~~~~~~~~~~~~~~~
+The ol_rebindable field is True if this literal is actually
+using rebindable syntax. Specifically:
+
+ False iff ol_witness is the standard one
+ True iff ol_witness is non-standard
+
+Equivalently it's True if
+ a) RebindableSyntax is on
+ b) the witness for fromInteger/fromRational/fromString
+ that happens to be in scope isn't the standard one
+
Note [Overloaded literal witnesses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Before* type checking, the SyntaxExpr in an HsOverLit is the
@@ -89,7 +102,7 @@ This witness should replace the literal.
This dual role is unusual, because we're replacing 'fromInteger' with
a call to fromInteger. Reason: it allows commoning up of the fromInteger
-calls, which wouldn't be possible if the desguarar made the application
+calls, which wouldn't be possible if the desguarar made the application.
The PostTcType in each branch records the type the overload literal is
found to have.
@@ -130,9 +143,9 @@ instance Outputable HsLit where
ppr (HsStringPrim s) = pprHsString s <> char '#'
ppr (HsInt i) = integer i
ppr (HsInteger i _) = integer i
- ppr (HsRat f _) = rational f
- ppr (HsFloatPrim f) = rational f <> char '#'
- ppr (HsDoublePrim d) = rational d <> text "##"
+ ppr (HsRat f _) = ppr f
+ ppr (HsFloatPrim f) = ppr f <> char '#'
+ ppr (HsDoublePrim d) = ppr d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsWordPrim w) = integer w <> text "##"
@@ -143,6 +156,6 @@ instance OutputableBndr id => Outputable (HsOverLit id) where
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
- ppr (HsFractional f) = rational f
+ ppr (HsFractional f) = ppr f
ppr (HsIsString s) = pprHsString s
\end{code}
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 78b5887a5979cc02edcf855df0c59fbc80286a28..7fb5f725334fdb03e2b45c64a93a5b86e9e6edcf 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -24,7 +24,7 @@ module HsPat (
isBangHsBind, isLiftedPatBind,
isBangLPat, hsPatNeedsParens,
- isIrrefutableHsPat,
+ isIrrefutableHsPat,
pprParendLPat
) where
@@ -65,7 +65,7 @@ data Pat id
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable
- | LazyPat (LPat id) -- Lazy pattern
+ | LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
| BangPat (LPat id) -- Bang pattern
@@ -122,7 +122,9 @@ data Pat id
| LitPat HsLit -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
- | NPat (HsOverLit id) -- ALWAYS positive
+ | NPat -- Used for all overloaded literals,
+ -- including overloaded strings with -XOverloadedStrings
+ (HsOverLit id) -- ALWAYS positive
(Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative
-- patterns, Nothing otherwise
(SyntaxExpr id) -- Equality checker, of type t->t->Bool
@@ -132,12 +134,6 @@ data Pat id
(SyntaxExpr id) -- (>=) function, of type t->t->Bool
(SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
- ------------ Generics ---------------
- | TypePat (LHsType id) -- Type pattern for generic definitions
- -- e.g f{| a+b |} = ...
- -- These show up only in class declarations,
- -- and should be a top-level pattern
-
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
@@ -281,7 +277,6 @@ pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (QuasiQuotePat qq) = ppr qq
-pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
@@ -439,7 +434,6 @@ isIrrefutableHsPat pat
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before
-- isIrrefutablePat is called
- go1 (TypePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
@@ -463,7 +457,6 @@ hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
-hsPatNeedsParens (TypePat {}) = False
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 38608a48a2a8a774e607dd6d637e17c12740b548..7dbb16df64b82608b0762aebbf9ca76e615f3d63 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -168,8 +168,6 @@ data HsType name
-- interface files smaller), so when printing a HsType we may need to
-- add parens.
- | HsNumTy Integer -- Generics only
-
| HsPredTy (HsPred name) -- Only used in the type of an instance
-- declaration, eg. Eq [a] -> Eq a
-- ^^^^
@@ -440,7 +438,6 @@ ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
-ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 13f3cd7e55e0087738d0bdb09075503ef60955ef..cc57e0544181f02f9f625b004b7e44dc361f01bb 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -19,15 +19,15 @@ module HsUtils(
mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
- mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
- coiToHsWrapper, mkHsLams, mkHsDictLet,
- mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
+ mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
+ coToHsWrapper, mkHsDictLet, mkHsLams,
+ mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
- -- Bindigns
+ -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals
@@ -42,8 +42,8 @@ module HsUtils(
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
- mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
- mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
+ mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
+ emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
@@ -77,14 +77,13 @@ import HsLit
import RdrName
import Var
import Coercion
-import Type
+import TypeRep
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
-import Outputable
import Util
import Bag
@@ -137,25 +136,25 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
| otherwise = HsWrap co_fn e
-mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI (IdCo _) e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo (Refl _) e = e
+mkHsWrapCo co e = mkHsWrap (WpCast co) e
-mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
-mkLHsWrapCoI (IdCo _) e = e
-mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo (Refl _) e = e
+mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e)
-coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper (IdCo _) = idHsWrapper
-coiToHsWrapper (ACo co) = WpCast co
+coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper (Refl _) = idHsWrapper
+coToHsWrapper co = WpCast co
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat co_fn p ty
-mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkHsWrapPatCoI (IdCo _) pat _ = pat
-mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo (Refl _) pat _ = pat
+mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
@@ -188,16 +187,15 @@ mkSimpleHsAlt pat expr
-- See RnEnv.lookupSyntaxName
mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
-mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsFractional :: FractionalLit -> 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
@@ -212,7 +210,10 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
noRebindableInfo :: Bool
noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
-mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
+mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
+ where
+ last_stmt = L (getLoc expr) $ mkLastStmt expr
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
@@ -220,24 +221,32 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
-mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing
-mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
-
+mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
+mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
-mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr)
-mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
-mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
-
-mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
+emptyTransStmt :: StmtLR idL idR
+emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = []
+ , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
+ , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
+ , trS_fmap = noSyntaxExpr }
+mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
+mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
+mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b }
+mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u }
+mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss
+ , trS_by = Just b, trS_using = u }
+
+mkLastStmt expr = LastStmt expr noSyntaxExpr
+mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
- , recS_rec_rets = [] }
+ , recS_rec_rets = [], recS_ret_ty = placeHolderType }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
@@ -327,8 +336,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
-nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
@@ -496,12 +505,12 @@ collectStmtBinders :: StmtLR idL idR -> [idL]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _) = []
-collectStmtBinders (ParStmt xs) = collectLStmtsBinders
+collectStmtBinders (ExprStmt {}) = []
+collectStmtBinders (LastStmt {}) = []
+collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
-collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
----------------- Patterns --------------------------
@@ -538,7 +547,6 @@ collect_lpat (L _ pat) bndrs
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (QuasiQuotePat _) = bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = go pat
\end{code}
@@ -642,12 +650,12 @@ lStmtsImplicits = hs_lstmts
hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
hs_stmt (LetStmt binds) = hs_local_binds binds
- hs_stmt (ExprStmt _ _ _) = emptyNameSet
- hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs
+ hs_stmt (ExprStmt {}) = emptyNameSet
+ hs_stmt (LastStmt {}) = emptyNameSet
+ hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
- hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts
- hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts
- hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+ 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
@@ -655,11 +663,15 @@ lStmtsImplicits = hs_lstmts
hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
hsValBindsImplicits (ValBindsOut binds _)
- = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+ = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
+hsValBindsImplicits (ValBindsIn binds _)
+ = lhsBindsImplicits binds
+
+lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
+lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
where
- hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
- hs_bind _ = emptyNameSet
-hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+ lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
+ lhs_bind _ = emptyNameSet
lPatImplicits :: LPat Name -> NameSet
lPatImplicits = hs_lpat
@@ -714,7 +726,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
-collect_sig_pat (TypePat ty) acc = ty:acc
collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index b1c97cdf00e8375792d4a41ec264caf668a3c2e9..c80628be725bb9fd12a734c178affcaae673788c 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,4 +1,3 @@
-
{-# OPTIONS_GHC -O #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -903,10 +902,11 @@ instance Binary IfaceType where
put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
-- Generic cases
-
put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
+ put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
+
get bh = do
h <- getByte bh
case h of
@@ -939,11 +939,11 @@ instance Binary IfaceType where
17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
- _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+ 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+ _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated
-
put_ bh IfaceIntTc = putByte bh 1
put_ bh IfaceBoolTc = putByte bh 2
put_ bh IfaceCharTc = putByte bh 3
@@ -954,9 +954,9 @@ instance Binary IfaceTyCon where
put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
put_ bh IfaceUbxTupleKindTc = putByte bh 9
put_ bh IfaceArgTypeKindTc = putByte bh 10
- put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
- put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
- put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
+ put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
+ put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
+ put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
get bh = do
h <- getByte bh
@@ -973,7 +973,27 @@ instance Binary IfaceTyCon where
10 -> return IfaceArgTypeKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
12 -> do { ext <- get bh; return (IfaceTc ext) }
- _ -> do { k <- get bh; return (IfaceAnyTc k) }
+ _ -> do { k <- get bh; return (IfaceAnyTc k) }
+
+instance Binary IfaceCoCon where
+ put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
+ put_ bh IfaceReflCo = putByte bh 1
+ put_ bh IfaceUnsafeCo = putByte bh 2
+ put_ bh IfaceSymCo = putByte bh 3
+ put_ bh IfaceTransCo = putByte bh 4
+ put_ bh IfaceInstCo = putByte bh 5
+ put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do { n <- get bh; return (IfaceCoAx n) }
+ 1 -> return IfaceReflCo
+ 2 -> return IfaceUnsafeCo
+ 3 -> return IfaceSymCo
+ 4 -> return IfaceTransCo
+ 5 -> return IfaceInstCo
+ _ -> do { d <- get bh; return (IfaceNthCo d) }
instance Binary IfacePredType where
put_ bh (IfaceClassP aa ab) = do
@@ -1013,50 +1033,50 @@ instance Binary IfaceExpr where
put_ bh (IfaceType ab) = do
putByte bh 1
put_ bh ab
- put_ bh (IfaceTuple ac ad) = do
+ put_ bh (IfaceCo ab) = do
putByte bh 2
+ put_ bh ab
+ put_ bh (IfaceTuple ac ad) = do
+ putByte bh 3
put_ bh ac
put_ bh ad
put_ bh (IfaceLam ae af) = do
- putByte bh 3
+ putByte bh 4
put_ bh ae
put_ bh af
put_ bh (IfaceApp ag ah) = do
- putByte bh 4
+ putByte bh 5
put_ bh ag
put_ bh ah
--- gaw 2004
- put_ bh (IfaceCase ai aj al ak) = do
- putByte bh 5
+ put_ bh (IfaceCase ai aj ak) = do
+ putByte bh 6
put_ bh ai
put_ bh aj
--- gaw 2004
- put_ bh al
put_ bh ak
put_ bh (IfaceLet al am) = do
- putByte bh 6
+ putByte bh 7
put_ bh al
put_ bh am
put_ bh (IfaceNote an ao) = do
- putByte bh 7
+ putByte bh 8
put_ bh an
put_ bh ao
put_ bh (IfaceLit ap) = do
- putByte bh 8
+ putByte bh 9
put_ bh ap
put_ bh (IfaceFCall as at) = do
- putByte bh 9
+ putByte bh 10
put_ bh as
put_ bh at
put_ bh (IfaceExt aa) = do
- putByte bh 10
+ putByte bh 11
put_ bh aa
put_ bh (IfaceCast ie ico) = do
- putByte bh 11
+ putByte bh 12
put_ bh ie
put_ bh ico
put_ bh (IfaceTick m ix) = do
- putByte bh 12
+ putByte bh 13
put_ bh m
put_ bh ix
get bh = do
@@ -1066,39 +1086,38 @@ instance Binary IfaceExpr where
return (IfaceLcl aa)
1 -> do ab <- get bh
return (IfaceType ab)
- 2 -> do ac <- get bh
+ 2 -> do ab <- get bh
+ return (IfaceCo ab)
+ 3 -> do ac <- get bh
ad <- get bh
return (IfaceTuple ac ad)
- 3 -> do ae <- get bh
+ 4 -> do ae <- get bh
af <- get bh
return (IfaceLam ae af)
- 4 -> do ag <- get bh
+ 5 -> do ag <- get bh
ah <- get bh
return (IfaceApp ag ah)
- 5 -> do ai <- get bh
+ 6 -> do ai <- get bh
aj <- get bh
--- gaw 2004
- al <- get bh
ak <- get bh
--- gaw 2004
- return (IfaceCase ai aj al ak)
- 6 -> do al <- get bh
+ return (IfaceCase ai aj ak)
+ 7 -> do al <- get bh
am <- get bh
return (IfaceLet al am)
- 7 -> do an <- get bh
+ 8 -> do an <- get bh
ao <- get bh
return (IfaceNote an ao)
- 8 -> do ap <- get bh
+ 9 -> do ap <- get bh
return (IfaceLit ap)
- 9 -> do as <- get bh
- at <- get bh
- return (IfaceFCall as at)
- 10 -> do aa <- get bh
+ 10 -> do as <- get bh
+ at <- get bh
+ return (IfaceFCall as at)
+ 11 -> do aa <- get bh
return (IfaceExt aa)
- 11 -> do ie <- get bh
+ 12 -> do ie <- get bh
ico <- get bh
return (IfaceCast ie ico)
- 12 -> do m <- get bh
+ 13 -> do m <- get bh
ix <- get bh
return (IfaceTick m ix)
_ -> panic ("get IfaceExpr " ++ show h)
@@ -1291,7 +1310,7 @@ instance Binary IfaceDecl where
put_ bh idinfo
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
@@ -1300,7 +1319,6 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh a8
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
@@ -1335,9 +1353,8 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
- a8 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+ return (IfaceData occ a2 a3 a4 a5 a6 a7)
3 -> do
a1 <- get bh
a2 <- get bh
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e71eefe33925a35c1b148f8dbc7bb04b3fe71f1f..eabe8c45aa42da1eefd91253f619c9c624bffe71 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -10,7 +10,8 @@ module BuildTyCl (
buildDataCon,
TcMethInfo, buildClass,
mkAbstractTyConRhs,
- mkNewTyConRhs, mkDataTyConRhs
+ mkNewTyConRhs, mkDataTyConRhs,
+ newImplicitBinder
) where
#include "HsVersions.h"
@@ -59,13 +60,12 @@ buildAlgTyCon :: Name -> [TyVar]
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
- -> Bool -- ^ True <=> want generics functions
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
parent mb_family
| Just fam_inst_info <- mb_family
= -- We need to tie a knot as the coercion of a data instance depends
@@ -74,11 +74,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- fam_parent is_rec want_generics gadt_syn) }
+ fam_parent is_rec gadt_syn) }
| otherwise
= return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- parent is_rec want_generics gadt_syn)
+ parent is_rec gadt_syn)
where
kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
@@ -100,8 +100,8 @@ mkFamInstParentInfo :: Name -> [TyVar]
mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
= do { -- Create the coercion
; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
- ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
- family instTys rep_tycon
+ ; let co_tycon = mkFamInstCo co_tycon_name tvs
+ family instTys rep_tycon
; return $ FamInstTyCon family instTys co_tycon }
------------------------------------------------------
@@ -127,23 +127,15 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
- ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
- cocon_maybe | all_coercions || isRecursiveTyCon tycon
- = Just co_tycon
- | otherwise
- = Nothing
- ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
+ ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
+ ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
- nt_co = cocon_maybe } ) }
+ nt_co = co_tycon } ) }
-- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise
where
- -- If all_coercions is True then we use coercions for all newtypes
- -- otherwise we use coercions for recursive newtypes and look through
- -- non-recursive newtypes
- all_coercions = True
tvs = tyConTyVars tycon
inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
@@ -156,7 +148,7 @@ mkNewTyConRhs tycon_name tycon con
-- has a single argument (Foo a) that is a *type class*, so
-- dataConInstOrigArgTys returns [].
- etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
+ etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
-- See Note [Tricky iface loop] in LoadIface
(etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
@@ -229,8 +221,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
\begin{code}
-type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate
- -- between tcClassSigs and buildClass
+type TcMethInfo = (Name, DefMethSpec, Type)
+ -- A temporary intermediate, to communicate between
+ -- tcClassSigs and buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
@@ -332,7 +325,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
- GenericDM -> return GenDefMeth
+ GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
+ ; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 3eae7a3d411b1aa6ae21a53f6dc4acc98fd29462..49fded9a59becb86e5ee89158c0020dfaac912d1 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -5,34 +5,34 @@
\begin{code}
module IfaceSyn (
- module IfaceType, -- Re-export all this
+ module IfaceType,
- IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
- IfaceBinding(..), IfaceConAlt(..),
- IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
- IfaceInst(..), IfaceFamInst(..),
+ IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
+ IfaceBinding(..), IfaceConAlt(..),
+ IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceInst(..), IfaceFamInst(..),
- -- Misc
+ -- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
-- Free Names
freeNamesIfDecl, freeNamesIfRule,
- -- Pretty printing
- pprIfaceExpr, pprIfaceDeclHead
+ -- Pretty printing
+ pprIfaceExpr, pprIfaceDeclHead
) where
#include "HsVersions.h"
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
-import PprCore() -- Printing DFunArgs
+import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
-import NameSet
+import NameSet
import Name
import CostCentre
import Literal
@@ -48,74 +48,67 @@ infixl 3 &&&
%************************************************************************
-%* *
- Data type declarations
-%* *
+%* *
+ Data type declarations
+%* *
%************************************************************************
\begin{code}
-data IfaceDecl
- = IfaceId { ifName :: OccName,
- ifType :: IfaceType,
- ifIdDetails :: IfaceIdDetails,
- ifIdInfo :: IfaceIdInfo }
-
- | IfaceData { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifCtxt :: IfaceContext, -- The "stupid theta"
- ifCons :: IfaceConDecls, -- Includes new/data info
- ifRec :: RecFlag, -- Recursive or not?
- ifGadtSyntax :: Bool, -- True <=> declared using
- -- GADT syntax
- ifGeneric :: Bool, -- True <=> generic converter
- -- functions available
- -- We need this for imported
- -- data decls, since the
- -- imported modules may have
- -- been compiled with
- -- different flags to the
- -- current compilation unit
+data IfaceDecl
+ = IfaceId { ifName :: OccName,
+ ifType :: IfaceType,
+ ifIdDetails :: IfaceIdDetails,
+ ifIdInfo :: IfaceIdInfo }
+
+ | IfaceData { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifCtxt :: IfaceContext, -- The "stupid theta"
+ ifCons :: IfaceConDecls, -- Includes new/data info
+ ifRec :: RecFlag, -- Recursive or not?
+ ifGadtSyntax :: Bool, -- True <=> declared using
+ -- GADT syntax
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
- -- Invariant:
+ -- Invariant:
-- ifCons /= IfOpenDataTyCon
-- for family instances
}
- | IfaceSyn { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
- ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
- -- Nothing for an open family
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
+ ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
+ -- Nothing for an open family
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant: ifOpenSyn == False
-- for family instances
}
- | IfaceClass { ifCtxt :: IfaceContext, -- Context...
- ifName :: OccName, -- Name of the class
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifFDs :: [FunDep FastString], -- Functional dependencies
- ifATs :: [IfaceDecl], -- Associated type families
- ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
+ | IfaceClass { ifCtxt :: IfaceContext, -- Context...
+ ifName :: OccName, -- Name of the class
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifFDs :: [FunDep FastString], -- Functional dependencies
+ ifATs :: [IfaceDecl], -- Associated type families
+ ifSigs :: [IfaceClassOp], -- Method signatures
+ ifRec :: RecFlag -- Is newtype/datatype associated
+ -- with the class recursive?
}
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move
-- beyond .NET
- ifExtName :: Maybe FastString }
+ ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
- -- Nothing => no default method
- -- Just False => ordinary polymorphic default method
- -- Just True => generic default method
+ -- Nothing => no default method
+ -- Just False => ordinary polymorphic default method
+ -- Just True => generic default method
data IfaceConDecls
- = IfAbstractTyCon -- No info
- | IfOpenDataTyCon -- Open data family
- | IfDataTyCon [IfaceConDecl] -- data type decls
- | IfNewTyCon IfaceConDecl -- newtype decls
+ = IfAbstractTyCon -- No info
+ | IfOpenDataTyCon -- Open data family
+ | IfDataTyCon [IfaceConDecl] -- data type decls
+ | IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
@@ -123,49 +116,49 @@ visibleIfConDecls IfOpenDataTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
-data IfaceConDecl
+data IfaceConDecl
= IfCon {
- ifConOcc :: OccName, -- Constructor name
- ifConWrapper :: Bool, -- True <=> has a wrapper
- ifConInfix :: Bool, -- True <=> declared infix
- ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
- ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
- ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
- ifConCtxt :: IfaceContext, -- Non-stupid context
- ifConArgTys :: [IfaceType], -- Arg types
- ifConFields :: [OccName], -- ...ditto... (field labels)
- ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
- -- or 1-1 corresp with arg tys
-
-data IfaceInst
- = IfaceInst { ifInstCls :: IfExtName, -- See comments with
- ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: IfExtName, -- The dfun
- ifOFlag :: OverlapFlag, -- Overlap flag
- ifInstOrph :: Maybe OccName } -- See Note [Orphans]
- -- There's always a separate IfaceDecl for the DFun, which gives
- -- its IdInfo with its full type and version number.
- -- The instance declarations taken together have a version number,
- -- and we don't want that to wobble gratuitously
- -- If this instance decl is *used*, we'll record a usage on the dfun;
- -- and if the head does not change it won't be used if it wasn't before
+ ifConOcc :: OccName, -- Constructor name
+ ifConWrapper :: Bool, -- True <=> has a wrapper
+ ifConInfix :: Bool, -- True <=> declared infix
+ ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
+ ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
+ ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
+ ifConCtxt :: IfaceContext, -- Non-stupid context
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConFields :: [OccName], -- ...ditto... (field labels)
+ ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
+ -- or 1-1 corresp with arg tys
+
+data IfaceInst
+ = IfaceInst { ifInstCls :: IfExtName, -- See comments with
+ ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
+ ifDFun :: IfExtName, -- The dfun
+ ifOFlag :: OverlapFlag, -- Overlap flag
+ ifInstOrph :: Maybe OccName } -- See Note [Orphans]
+ -- There's always a separate IfaceDecl for the DFun, which gives
+ -- its IdInfo with its full type and version number.
+ -- The instance declarations taken together have a version number,
+ -- and we don't want that to wobble gratuitously
+ -- If this instance decl is *used*, we'll record a usage on the dfun;
+ -- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
= IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon
- , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
- , ifFamInstTyCon :: IfaceTyCon -- Instance decl
- }
+ , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
+ , ifFamInstTyCon :: IfaceTyCon -- Instance decl
+ }
data IfaceRule
- = IfaceRule {
- ifRuleName :: RuleName,
- ifActivation :: Activation,
- ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: IfExtName, -- Head of lhs
- ifRuleArgs :: [IfaceExpr], -- Args of LHS
- ifRuleRhs :: IfaceExpr,
- ifRuleAuto :: Bool,
- ifRuleOrph :: Maybe OccName -- Just like IfaceInst
+ = IfaceRule {
+ ifRuleName :: RuleName,
+ ifActivation :: Activation,
+ ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
+ ifRuleHead :: IfExtName, -- Head of lhs
+ ifRuleArgs :: [IfaceExpr], -- Args of LHS
+ ifRuleRhs :: IfaceExpr,
+ ifRuleAuto :: Bool,
+ ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
data IfaceAnnotation
@@ -187,80 +180,81 @@ data IfaceIdDetails
| IfDFunId Int -- Number of silent args
data IfaceIdInfo
- = NoInfo -- When writing interface file without -O
- | HasInfo [IfaceInfoItem] -- Has info, and here it is
+ = NoInfo -- When writing interface file without -O
+ | HasInfo [IfaceInfoItem] -- Has info, and here it is
-- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f
-- * Change function f in A, and recompile without -O
-- * When we read in old A.hi we read in its IdInfo (as a thunk)
--- (In earlier GHCs we used to drop IdInfo immediately on reading,
--- but we do not do that now. Instead it's discarded when the
--- ModIface is read into the various decl pools.)
+-- (In earlier GHCs we used to drop IdInfo immediately on reading,
+-- but we do not do that now. Instead it's discarded when the
+-- ModIface is read into the various decl pools.)
-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
--- and so gives a new version.
+-- and so gives a new version.
data IfaceInfoItem
- = HsArity Arity
+ = HsArity Arity
| HsStrictness StrictSig
| HsInline InlinePragma
- | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
- IfaceUnfolding -- See Note [Expose recursive functions]
+ | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
+ IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
-data IfaceUnfolding
+data IfaceUnfolding
= IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
-- Possibly could eliminate the Bool here, the information
-- is also in the InlinePragma.
- | IfCompulsory IfaceExpr -- Only used for default methods, in fact
+ | IfCompulsory IfaceExpr -- Only used for default methods, in fact
| IfInlineRule Arity -- INLINE pragmas
- Bool -- OK to inline even if *un*-saturated
- Bool -- OK to inline even if context is boring
- IfaceExpr
+ Bool -- OK to inline even if *un*-saturated
+ Bool -- OK to inline even if context is boring
+ IfaceExpr
- | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
- | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
- -- another module.
+ | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
+ | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
+ -- another module.
| IfDFunUnfold [DFunArg IfaceExpr]
--------------------------------
data IfaceExpr
- = IfaceLcl IfLclName
+ = IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
- | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
+ | IfaceCo IfaceType -- We re-use IfaceType for coercions
+ | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
- | IfaceLit Literal
- | IfaceFCall ForeignCall IfaceType
+ | IfaceLit Literal
+ | IfaceFCall ForeignCall IfaceType
| IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
- -- Note: IfLclName, not IfaceBndr (and same with the case binder)
- -- We reconstruct the kind/type of the thing from the context
- -- thus saving bulk in interface files
+ -- Note: IfLclName, not IfaceBndr (and same with the case binder)
+ -- We reconstruct the kind/type of the thing from the context
+ -- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt IfExtName
- | IfaceTupleAlt Boxity
- | IfaceLitAlt Literal
+ | IfaceDataAlt IfExtName
+ | IfaceTupleAlt Boxity
+ | IfaceLitAlt Literal
data IfaceBinding
- = IfaceNonRec IfaceLetBndr IfaceExpr
- | IfaceRec [(IfaceLetBndr, IfaceExpr)]
+ = IfaceNonRec IfaceLetBndr IfaceExpr
+ | IfaceRec [(IfaceLetBndr, IfaceExpr)]
-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
@@ -299,9 +293,9 @@ complicate the situation though. Consider
and suppose we are compiling module X:
module X where
- import M
- data T = ...
- instance C Int T where ...
+ import M
+ data T = ...
+ instance C Int T where ...
This instance is an orphan, because when compiling a third module Y we
might get a constraint (C Int v), and we'd want to improve v to T. So
@@ -315,7 +309,7 @@ More precisely, an instance is an orphan iff
If there are fundeps, then for every fundep, at least one of the
names free in a *non-determined* part of the instance head is
- defined in this module.
+ defined in this module.
(Note that these conditions hold trivially if the class is locally
defined.)
@@ -342,10 +336,10 @@ a functionally-dependent part of the instance decl. E.g.
and suppose we are compiling module X:
module X where
- import M
- data S = ...
- data T = ...
- instance C S T where ...
+ import M
+ data S = ...
+ data T = ...
+ instance C S T where ...
If we base the instance verion on T, I'm worried that changing S to S'
would change T's version, but not S or S'. But an importing module might
@@ -356,8 +350,8 @@ and it seems deeply obscure, so I'm going to leave it for now.
Note [Versioning of rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-A rule that is not an orphan has an ifRuleOrph field of (Just n), where
-n appears on the LHS of the rule; any change in the rule changes the version of n.
+A rule that is not an orphan has an ifRuleOrph field of (Just n), where n
+appears on the LHS of the rule; any change in the rule changes the version of n.
\begin{code}
@@ -380,7 +374,7 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = []
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ }),
- ifFamInst = famInst})
+ ifFamInst = famInst})
= -- implicit coerion and (possibly) family instance coercion
(mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
-- data constructor and worker (newtypes don't have a wrapper)
@@ -388,8 +382,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
- ifCons = IfDataTyCon cons,
- ifFamInst = famInst})
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
= -- (possibly) family instance coercion;
-- there is no implicit coercion for non-newtypes
famInstCo famInst tc_occ
@@ -398,20 +392,20 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
++ concatMap dc_occs cons
where
dc_occs con_decl
- | has_wrapper = [con_occ, work_occ, wrap_occ]
- | otherwise = [con_occ, work_occ]
- where
- con_occ = ifConOcc con_decl -- DataCon namespace
- wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
- work_occ = mkDataConWorkerOcc con_occ -- Id namespace
- has_wrapper = ifConWrapper con_decl -- This is the reason for
- -- having the ifConWrapper field!
-
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
- ifSigs = sigs, ifATs = ats })
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ has_wrapper = ifConWrapper con_decl -- This is the reason for
+ -- having the ifConWrapper field!
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
= -- dictionary datatype:
-- type constructor
- tc_occ :
+ tc_occ :
-- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
@@ -428,14 +422,14 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
n_ctxt = length sc_ctxt
n_sigs = length sigs
tc_occ = mkClassTyConOcc cls_occ
- dc_occ = mkClassDataConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
- | otherwise = []
+ | otherwise = []
dcww_occ = mkDataConWorkerOcc dc_occ
- is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
- ifFamInst = famInst})
+ ifFamInst = famInst})
= famInstCo famInst tc_occ
ifaceDeclSubBndrs _ = []
@@ -451,54 +445,50 @@ instance Outputable IfaceDecl where
ppr = pprIfaceDecl
pprIfaceDecl :: IfaceDecl -> SDoc
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
ifIdDetails = details, ifIdInfo = info})
- = sep [ ppr var <+> dcolon <+> ppr ty,
- nest 2 (ppr details),
- nest 2 (ppr info) ]
+ = sep [ ppr var <+> dcolon <+> ppr ty,
+ nest 2 (ppr details),
+ nest 2 (ppr info) ]
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifSynRhs = Just mono_ty,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Just mono_ty,
ifFamInst = mbFamInst})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifSynRhs = Nothing, ifSynKind = kind })
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Nothing, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
-pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
- ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec, ifFamInst = mbFamInst})
+pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
+ 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])
+ 4 (vcat [pprRec isrec, pp_condecls tycon condecls,
+ 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
-pprGen :: Bool -> SDoc
-pprGen True = ptext (sLit "Generics: yes")
-pprGen False = ptext (sLit "Generics: no")
-
pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
pprFamily Nothing = ptext (sLit "FamilyInstance: none")
pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
@@ -508,68 +498,68 @@ instance Outputable IfaceClassOp where
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
- pprIfaceTvBndrs tyvars]
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+ pprIfaceTvBndrs tyvars]
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls _ IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
- (map (pprIfaceConDecl tc) cs))
+ (map (pprIfaceConDecl tc) cs))
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
pprIfaceConDecl tc
- (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
- ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
- ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
- ifConStricts = strs, ifConFields = fields })
+ (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
+ ifConStricts = strs, ifConFields = fields })
= sep [main_payload,
- if is_infix then ptext (sLit "Infix") else empty,
- if has_wrap then ptext (sLit "HasWrapper") else empty,
- ppUnless (null strs) $
- nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
- ppUnless (null fields) $
- nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+ if is_infix then ptext (sLit "Infix") else empty,
+ if has_wrap then ptext (sLit "HasWrapper") else empty,
+ ppUnless (null strs) $
+ nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
+ ppUnless (null fields) $
+ nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
- ppr_bang HsNoBang = char '_' -- Want to see these
+ ppr_bang HsNoBang = char '_' -- Want to see these
ppr_bang bang = ppr bang
-
- main_payload = ppr name <+> dcolon <+>
- pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
- eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
- | (tv,ty) <- eq_spec]
+ main_payload = ppr name <+> dcolon <+>
+ pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
+
+ 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
+ -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
+ -- because we don't have a Name for the tycon, only an OccName
pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
- (t:ts) -> fsep (t : map (arrow <+>) ts)
- [] -> panic "pp_con_taus"
+ (t:ts) -> fsep (t : map (arrow <+>) ts)
+ [] -> panic "pp_con_taus"
pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
- ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
- nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
- ptext (sLit "=") <+> ppr rhs])
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
+ nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
+ ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
- ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
- ifInstCls = cls, ifInstTys = mb_tcs})
- = hang (ptext (sLit "instance") <+> ppr flag
- <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
+ ifInstCls = cls, ifInstTys = mb_tcs})
+ = hang (ptext (sLit "instance") <+> ppr flag
+ <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
- ifFamInstTyCon = tycon_id})
- = hang (ptext (sLit "family instance") <+>
- ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ ifFamInstTyCon = tycon_id})
+ = hang (ptext (sLit "family instance") <+>
+ ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
ppr_rough :: Maybe IfaceTyCon -> SDoc
@@ -587,9 +577,11 @@ instance Outputable IfaceExpr where
pprParendIfaceExpr :: IfaceExpr -> SDoc
pprParendIfaceExpr = pprIfaceExpr parens
+-- | Pretty Print an IfaceExpre
+--
+-- The first argument should be a function that adds parens in context that need
+-- an atomic value (e.g. function args)
pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
- -- The function adds parens in context that need
- -- an atomic value (e.g. function args)
pprIfaceExpr _ (IfaceLcl v) = ppr v
pprIfaceExpr _ (IfaceExt v) = ppr v
@@ -597,104 +589,112 @@ pprIfaceExpr _ (IfaceLit l) = ppr l
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co
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 add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+ = add_par (sep [ptext (sLit "case")
<+> 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 add_par (IfaceCase scrut bndr alts)
+ = add_par (sep [ptext (sLit "case")
<+> 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
@@ -703,7 +703,7 @@ instance Outputable IfaceUnfolding where
<+> brackets (pprWithCommas ppr ns)
-- -----------------------------------------------------------------------------
--- Finding the Names in IfaceSyn
+-- | Finding the Names in IfaceSyn
-- This is used for dependency analysis in MkIface, so that we
-- fingerprint a declaration before the things that depend on it. It
@@ -713,11 +713,11 @@ instance Outputable IfaceUnfolding where
-- fingerprinting the instance, so DFuns are not dependencies.
freeNamesIfDecl :: IfaceDecl -> NameSet
-freeNamesIfDecl (IfaceId _s t d i) =
+freeNamesIfDecl (IfaceId _s t d i) =
freeNamesIfType t &&&
freeNamesIfIdInfo i &&&
freeNamesIfIdDetails d
-freeNamesIfDecl IfaceForeign{} =
+freeNamesIfDecl IfaceForeign{} =
emptyNameSet
freeNamesIfDecl d@IfaceData{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
@@ -744,7 +744,7 @@ freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
freeNamesIfSynRhs Nothing = emptyNameSet
freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
-freeNamesIfTcFam (Just (tc,tys)) =
+freeNamesIfTcFam (Just (tc,tys)) =
freeNamesIfTc tc &&& fnList freeNamesIfType tys
freeNamesIfTcFam Nothing =
emptyNameSet
@@ -764,15 +764,15 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
-freeNamesIfConDecl c =
+freeNamesIfConDecl c =
freeNamesIfTvBndrs (ifConUnivTvs c) &&&
freeNamesIfTvBndrs (ifConExTvs c) &&&
- freeNamesIfContext (ifConCtxt c) &&&
+ freeNamesIfContext (ifConCtxt c) &&&
fnList freeNamesIfType (ifConArgTys c) &&&
fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
freeNamesIfPredType :: IfacePredType -> NameSet
-freeNamesIfPredType (IfaceClassP cl tys) =
+freeNamesIfPredType (IfaceClassP cl tys) =
unitNameSet cl &&& fnList freeNamesIfType tys
freeNamesIfPredType (IfaceIParam _n ty) =
freeNamesIfType ty
@@ -783,11 +783,13 @@ freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceTyVar _) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st
-freeNamesIfType (IfaceTyConApp tc ts) =
+freeNamesIfType (IfaceTyConApp tc ts) =
freeNamesIfTc tc &&& fnList freeNamesIfType ts
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) =
+ freeNamesIfCo tc &&& fnList freeNamesIfType ts
freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -798,7 +800,7 @@ freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
-- Remember IfaceLetBndr is used only for *nested* bindings
--- The IdInfo can contain an unfolding (in the case of
+-- The IdInfo can contain an unfolding (in the case of
-- local INLINE pragmas), so look there too
freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
&&& freeNamesIfIdInfo info
@@ -811,7 +813,7 @@ freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
freeNamesIfIdBndr = freeNamesIfTvBndr
freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
-freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
@@ -827,28 +829,28 @@ freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
-freeNamesIfExpr (IfaceExt v) = unitNameSet v
+freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co) = freeNamesIfType co
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 (IfaceCase s _ alts)
= freeNamesIfExpr s
&&& fnList fn_alt alts &&& fn_cons alts
- &&& freeNamesIfType ty
where
fn_alt (_con,_bs,r) = freeNamesIfExpr r
-- 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
@@ -865,6 +867,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfTc _ = emptyNameSet
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
freeNamesIfRule :: IfaceRule -> NameSet
freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
, ifRuleArgs = es, ifRuleRhs = rhs })
@@ -883,18 +889,18 @@ fnList f = foldr (&&&) emptyNameSet . map f
Note [Tracking data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a case expression
+In a case expression
case e of { C a -> ...; ... }
You might think that we don't need to include the datacon C
-in the free names, because its type will probably show up in
+in the free names, because its type will probably show up in
the free names of 'e'. But in rare circumstances this may
not happen. Here's the one that bit me:
- module DynFlags where
+ module DynFlags where
import {-# SOURCE #-} Packages( PackageState )
data DynFlags = DF ... PackageState ...
- module Packages where
+ module Packages where
import DynFlags
data PackageState = PS ...
lookupModule (df :: DynFlags)
@@ -905,3 +911,4 @@ not happen. Here's the one that bit me:
Now, lookupModule depends on DynFlags, but the transitive dependency
on the *locally-defined* type PackageState is not visible. We need
to take account of the use of the data constructor PS in the pattern match.
+
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index c97e16eef266c288f8503eec2261f95c0e5867ad..7817b423aeb84de8ecc3fcb2960304a2edb6c764 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -9,15 +9,18 @@ This module defines interface types and binders
module IfaceType (
IfExtName, IfLclName,
- IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+ IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
-- Conversion from Type -> IfaceType
- toIfaceType, toIfacePred, toIfaceContext,
+ toIfaceType, toIfaceContext,
toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
toIfaceTyCon, toIfaceTyCon_name,
+ -- Conversion from Coercion -> IfaceType
+ coToIfaceType,
+
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
@@ -25,11 +28,13 @@ module IfaceType (
) where
-import TypeRep
+import Coercion
+import TypeRep hiding( maybeParen )
import TyCon
import Id
import Var
import TysWiredIn
+import TysPrim
import Name
import BasicTypes
import Outputable
@@ -59,14 +64,15 @@ type IfaceTvBndr = (IfLclName, IfaceKind)
type IfaceKind = IfaceType
type IfaceCoercion = IfaceType
-data IfaceType
- = IfaceTyVar IfLclName -- Type variable only, not tycon
+data IfaceType -- A kind of universal type, used for types, kinds, and coercions
+ = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceAppTy IfaceType IfaceType
+ | IfaceFunTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfacePredTy IfacePredType
- | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
- -- Includes newtypes, synonyms, tuples
- | IfaceFunTy IfaceType IfaceType
+ | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
+ -- Includes newtypes, synonyms, tuples
+ | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated
data IfacePredType -- NewTypes are handled as ordinary TyConApps
= IfaceClassP IfExtName [IfaceType]
@@ -75,18 +81,28 @@ data IfacePredType -- NewTypes are handled as ordinary TyConApps
type IfaceContext = [IfacePredType]
-data IfaceTyCon -- Abbreviations for common tycons with known names
+data IfaceTyCon -- Encodes type consructors, kind constructors
+ -- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc Boxity Arity
| IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-- other than 'Any :: *' itself
+
+ -- Kind constructors
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc
-ifaceTyConName :: IfaceTyCon -> IfExtName
-ifaceTyConName IfaceIntTc = intTyConName
+ -- Coercion constructors
+data IfaceCoCon
+ = IfaceCoAx IfExtName
+ | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
+ | IfaceTransCo | IfaceInstCo
+ | IfaceNthCo Int
+
+ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
ifaceTyConName IfaceListTc = listTyConName
@@ -208,6 +224,10 @@ ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
ppr_ty _ (IfacePredTy st) = ppr st
+ppr_ty ctxt_prec (IfaceCoConApp tc tys)
+ = maybeParen ctxt_prec tYCON_PREC
+ (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
@@ -268,6 +288,15 @@ instance Outputable IfaceTyCon where
-- so we fake it. It's only for debug printing!
ppr other_tc = ppr (ifaceTyConName other_tc)
+instance Outputable IfaceCoCon where
+ ppr (IfaceCoAx n) = ppr n
+ ppr IfaceReflCo = ptext (sLit "Refl")
+ ppr IfaceUnsafeCo = ptext (sLit "Unsafe")
+ ppr IfaceSymCo = ptext (sLit "Sym")
+ ppr IfaceTransCo = ptext (sLit "Trans")
+ ppr IfaceInstCo = ptext (sLit "Inst")
+ ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
+
-------------------
pprIfaceContext :: IfaceContext -> SDoc
-- Prints "(C a, D b) =>", including the arrow
@@ -309,18 +338,15 @@ toIfaceKind = toIfaceType
---------------------
toIfaceType :: Type -> IfaceType
-- Synonyms are retained in the interface type
-toIfaceType (TyVarTy tv) =
- IfaceTyVar (occNameFS (getOccName tv))
-toIfaceType (AppTy t1 t2) =
- IfaceAppTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (FunTy t1 t2) =
- IfaceFunTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (TyConApp tc tys) =
- IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
-toIfaceType (ForAllTy tv t) =
- IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (PredTy st) =
- IfacePredTy (toIfacePred st)
+toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyCoVar tv)
+toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
+toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st)
+
+toIfaceTyCoVar :: TyCoVar -> FastString
+toIfaceTyCoVar = occNameFS . getOccName
----------------
-- A little bit of (perhaps optional) trickiness here. When
@@ -364,16 +390,39 @@ toIfaceTypes :: [Type] -> [IfaceType]
toIfaceTypes ts = map toIfaceType ts
----------------
-toIfacePred :: PredType -> IfacePredType
-toIfacePred (ClassP cls ts) =
- IfaceClassP (getName cls) (toIfaceTypes ts)
-toIfacePred (IParam ip t) =
- IfaceIParam (mapIPName getOccName ip) (toIfaceType t)
-toIfacePred (EqPred ty1 ty2) =
- IfaceEqPred (toIfaceType ty1) (toIfaceType ty2)
+toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType
+toIfacePred to (ClassP cls ts) = IfaceClassP (getName cls) (map to ts)
+toIfacePred to (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (to t)
+toIfacePred to (EqPred ty1 ty2) = IfaceEqPred (to ty1) (to ty2)
----------------
toIfaceContext :: ThetaType -> IfaceContext
-toIfaceContext cs = map toIfacePred cs
+toIfaceContext cs = map (toIfacePred toIfaceType) cs
+
+----------------
+coToIfaceType :: Coercion -> IfaceType
+coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty]
+coToIfaceType (TyConAppCo tc cos) = IfaceTyConApp (toIfaceTyCon tc)
+ (map coToIfaceType cos)
+coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1)
+ (coToIfaceType co2)
+coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v)
+ (coToIfaceType co)
+coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceTyCoVar cv)
+coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con))
+ (map coToIfaceType cos)
+coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo
+ [ toIfaceType ty1
+ , toIfaceType ty2 ]
+coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo
+ [ coToIfaceType co ]
+coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo
+ [ coToIfaceType co1
+ , coToIfaceType co2 ]
+coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d)
+ [ coToIfaceType co ]
+coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
+ [ coToIfaceType co
+ , toIfaceType ty ]
\end{code}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b940cb15a7e79a94d236f949f159775b4064cca1..5c58a801f5f1b9ecd1442528404ae1ba3bb7f732 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -59,10 +59,10 @@ import Annotations
import CoreSyn
import CoreFVs
import Class
+import Kind
import TyCon
import DataCon
import Type
-import Coercion
import TcType
import InstEnv
import FamInstEnv
@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
- export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
- | otherwise = Nothing
+ export_hash | depend_on_exports = Just (mi_exp_hash iface)
+ | otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
- depend_on_exports mod =
- case lookupModuleEnv direct_imports mod of
- Just _ -> True
- -- Even if we used 'import M ()', we have to register a
- -- usage on the export list because we are sensitive to
- -- changes in orphan instances/rules.
- Nothing -> False
- -- In GHC 6.8.x the above line read "True", and in
- -- fact it recorded a dependency on *all* the
- -- modules underneath in the dependency tree. This
- -- happens to make orphans work right, but is too
- -- expensive: it'll read too many interface files.
- -- The 'isNothing maybe_iface' check above saved us
- -- from generating many of these usages (at least in
- -- one-shot mode), but that's even more bogus!
+ depend_on_exports = is_direct_import
+ {- True
+ Even if we used 'import M ()', we have to register a
+ usage on the export list because we are sensitive to
+ changes in orphan instances/rules.
+ False
+ In GHC 6.8.x we always returned true, and in
+ fact it recorded a dependency on *all* the
+ modules underneath in the dependency tree. This
+ happens to make orphans work right, but is too
+ expensive: it'll read too many interface files.
+ The 'isNothing maybe_iface' check above saved us
+ from generating many of these usages (at least in
+ one-shot mode), but that's even more bogus!
+ -}
\end{code}
\begin{code}
@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
- toDmSpec NoDefMeth = NoDM
- toDmSpec GenDefMeth = GenericDM
- toDmSpec (DefMeth _) = VanillaDM
+ toDmSpec NoDefMeth = NoDM
+ toDmSpec (GenDefMeth _) = GenericDM
+ toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
@@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon)
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
@@ -1387,14 +1386,16 @@ tyThingToIfaceDecl (ATyCon tycon)
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
- ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
- ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
- ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
- ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
- ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
+ ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+ ifConExTvs = toIfaceTvBndrs ex_tvs,
+ ifConEqSpec = to_eq_spec eq_spec,
+ ifConCtxt = toIfaceContext theta,
+ ifConArgTys = map toIfaceType arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
+ where
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
@@ -1402,6 +1403,8 @@ tyThingToIfaceDecl (ATyCon tycon)
famInstToIface (Just (famTyCon, instTys)) =
Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
+tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+
tyThingToIfaceDecl (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
@@ -1566,6 +1569,8 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
-- construct the same ru_rough field as we have right now;
-- see tcIfaceRule
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+ do_arg (Coercion co) = IfaceType (coToIfaceType co)
+
do_arg arg = toIfaceExpr arg
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
@@ -1585,15 +1590,16 @@ bogusIfaceRule id_name
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr
-toIfaceExpr (Var v) = toIfaceVar v
-toIfaceExpr (Lit l) = IfaceLit l
-toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
-toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
-toIfaceExpr (App f a) = toIfaceApp f [a]
-toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
-toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
-toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
+toIfaceExpr (Var v) = toIfaceVar v
+toIfaceExpr (Lit l) = IfaceLit l
+toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
+toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co)
+toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
+toIfaceExpr (App f a) = toIfaceApp f [a]
+toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
+toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
---------------------
toIfaceNote :: Note -> IfaceNote
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8dccc72b376341e9afbe39ac11d2ed83ae92c4d8..7ac95b1fa79a6fe0fb8b98e5f68afbe6b91d2c35 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -21,6 +21,7 @@ import BuildTyCl
import TcRnMonad
import TcType
import Type
+import Coercion
import TypeRep
import HscTypes
import Annotations
@@ -39,7 +40,6 @@ import TyCon
import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
-import Var ( Var, TyVar )
import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
@@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic,
ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
@@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; mb_fam_inst <- tcFamInst mb_family
; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
- want_generic gadt_syn parent mb_fam_inst
+ gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
@@ -791,20 +790,56 @@ tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy
tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t)
tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+ = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+ = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+ = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%* *
+ Coercions
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
+ mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
\end{code}
@@ -819,6 +854,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
+tcIfaceExpr (IfaceCo co)
+ = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+ = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
tcIfaceExpr (IfaceLcl name)
= Var <$> tcIfaceLclId name
@@ -853,7 +894,7 @@ tcIfaceExpr (IfaceLam bndr body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do
+tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
@@ -868,8 +909,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
- ty' <- tcIfaceType ty
- return (Case scrut' case_bndr' ty' alts')
+ return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
@@ -898,11 +938,6 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
(idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
-tcIfaceExpr (IfaceCast expr co) = do
- expr' <- tcIfaceExpr expr
- co' <- tcIfaceType co
- return (Cast expr' co')
-
tcIfaceExpr (IfaceNote note expr) = do
expr' <- tcIfaceExpr expr
case note of
@@ -942,14 +977,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
- ; let (ex_tvs, co_tvs, arg_ids)
+ ; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
- all_tvs = ex_tvs ++ co_tvs
- ; rhs' <- extendIfaceTyVarEnv all_tvs $
+ ; rhs' <- extendIfaceTyVarEnv ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
- ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+ ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
\end{code}
@@ -1217,6 +1251,10 @@ tcIfaceClass :: Name -> IfL Class
tcIfaceClass name = do { thing <- tcIfaceGlobal name
; return (tyThingClass thing) }
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+ ; return (tyThingCoAxiom thing) }
+
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 911592bc2053f3e99481bc5ac797173c84abc36d..9f25c088260041b8684d329d24e84ec91d23cf08 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -122,34 +122,25 @@ pprInfoTable env count lbl stat
then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
else (pprLlvmData ([ldata'], ltypes), llvmUsed)
+
-- | We generate labels for info tables by converting them to the same label
-- as for the entry code but adding this string as a suffix.
iTableSuf :: String
iTableSuf = "_itable"
--- | Create an appropriate section declaration for subsection <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"
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index 661dc9afe4cff6f113f44ad710dee04110db1a5d..b0c63a4c344b92b3743153fe33f8e9be64b422fd 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -38,6 +38,8 @@ lmGlobalReg suf reg
VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf
VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf
VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf
+ VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf
+ VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf
SpLim -> wordGlobal $ "SpLim" ++ suf
FloatReg 1 -> floatGlobal $"F1" ++ suf
FloatReg 2 -> floatGlobal $"F2" ++ suf
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 7b38ed8fa27a51b929bfee36e10407640cb29659..591ef81934717b4dd62a3ae6e698902d62fcd2de 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -1,17 +1,21 @@
+{-# OPTIONS -fno-warn-unused-binds #-}
-- -----------------------------------------------------------------------------
-- | GHC LLVM Mangler
--
-- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function. We also
--- use it to fix up the stack alignment, which needs to be 16 byte aligned
--- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
--- starting value in the RTS.
+-- so that an info table appears before its corresponding function.
--
--- We only need this for Mac OS X, other targets don't use it.
+-- On OSX we also use it to fix up the stack alignment, which needs to be 16
+-- byte aligned but always ends up off by word bytes because GHC sets it to
+-- the 'wrong' starting value in the RTS.
--
module LlvmMangler ( llvmFixupAsm ) where
+#include "HsVersions.h"
+
+import LlvmCodeGen.Ppr ( infoSection )
+
import Control.Exception
import qualified Data.ByteString.Char8 as B
import Data.Char
@@ -19,17 +23,24 @@ import qualified Data.IntMap as I
import System.IO
-- Magic Strings
-infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
-infoSec = B.pack "\t.section\t__STRIP,__me"
+secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
+secStmt = B.pack "\t.section\t"
+infoSec = B.pack infoSection
newInfoSec = B.pack "\n\t.text"
newLine = B.pack "\n"
-spInst = B.pack ", %esp\n"
jmpInst = B.pack "\n\tjmp"
-infoLen, spFix, labelStart :: Int
-infoLen = B.length infoSec
-spFix = 4
-labelStart = B.length jmpInst + 1
+infoLen, labelStart, spFix :: Int
+infoLen = B.length infoSec
+labelStart = B.length jmpInst
+
+#if x86_64_TARGET_ARCH
+spInst = B.pack ", %rsp\n"
+spFix = 8
+#else
+spInst = B.pack ", %esp\n"
+spFix = 4
+#endif
-- Search Predicates
eolPred, dollarPred, commaPred :: Char -> Bool
@@ -50,25 +61,30 @@ llvmFixupAsm f1 f2 = do
{- |
Here we process the assembly file one function and data
- defenition at a time. When a function is encountered that
+ definition at a time. When a function is encountered that
should have a info table we store it in a map. Otherwise
we print it. When an info table is found we retrieve its
function from the map and print them both.
For all functions we fix up the stack alignment. We also
- fix up the section defenition for functions and info tables.
+ fix up the section definition for functions and info tables.
-}
fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
fixTables r w m = do
f <- getFun r B.empty
if B.null f
then return ()
- else let fun = fixupStack f B.empty
- (a,b) = B.breakSubstring infoSec fun
- (x,c) = B.break eolPred b
- fun' = a `B.append` newInfoSec `B.append` c
- n = readInt $ B.drop infoLen x
- (bs, m') | B.null b = ([fun], m)
+ else let fun = fixupStack f B.empty
+ (a,b) = B.breakSubstring infoSec fun
+ (a',s) = B.breakEnd eolPred a
+ -- We search for the section header in two parts as it makes
+ -- us portable across OS types and LLVM version types since
+ -- section names are wrapped differently.
+ secHdr = secStmt `B.isPrefixOf` s
+ (x,c) = B.break eolPred b
+ fun' = a' `B.append` newInfoSec `B.append` c
+ n = readInt $ B.takeWhile isDigit $ B.drop infoLen x
+ (bs, m') | B.null b || not secHdr = ([fun], m)
| even n = ([], I.insert n fun' m)
| otherwise = case I.lookup (n+1) m of
Just xf' -> ([fun',xf'], m)
@@ -88,7 +104,7 @@ getFun r f = do
Mac OS X requires that the stack be 16 byte aligned when making a function
call (only really required though when making a call that will pass through
the dynamic linker). The alignment isn't correctly generated by LLVM as
- LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
+ LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
(since the function call was 16 byte aligned and the return address should
have been pushed, so sub 4). GHC though since it always uses jumps keeps
the stack 16 byte aligned on both function calls and function entry.
@@ -96,6 +112,11 @@ getFun r f = do
We correct the alignment here.
-}
fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
+
+#if !darwin_TARGET_OS
+fixupStack = const
+
+#else
fixupStack f f' | B.null f' =
let -- fixup sub op
(a, c) = B.breakSubstring spInst f
@@ -114,18 +135,21 @@ fixupStack f f' =
(a', n) = B.breakEnd dollarPred a
(n', x) = B.break commaPred n
num = B.pack $ show $ readInt n' + spFix
+ -- We need to avoid processing jumps to labels, they are of the form:
+ -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L...
+ targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
+ B.drop labelStart c
in if B.null c
then f' `B.append` f
- -- We need to avoid processing jumps to labels, they are of the form:
- -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
- else if B.index c labelStart == 'L'
+ else if B.head targ == 'L'
then fixupStack b $ f' `B.append` a `B.append` l
else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
x `B.append` l
+#endif
--- | read an int or error
+-- | Read an int or error
readInt :: B.ByteString -> Int
readInt str | B.all isDigit str = (read . B.unpack) str
- | otherwise = error $ "LLvmMangler Cannot read" ++ show str
- ++ "as it's not an Int"
+ | otherwise = error $ "LLvmMangler Cannot read " ++ show str
+ ++ " as it's not an Int"
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 67515e53a16b0419bda3999beb7743a82146aec7..372bd3507e1b7f4099bdecbe1f2d543a7459f84a 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -233,5 +233,5 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
errorsToGhcException :: [Located String] -> GhcException
errorsToGhcException errs =
let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
- in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
+ in UsageError (renderWithStyle errors cmdlineParserStyle)
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index f5030777cb8eba9633d76ea03d4e4d673b16f230..f5e339440bc9f96b2a591b0d9dc8856296301a67 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -8,9 +8,7 @@ module CodeOutput( codeOutput, outputForeignStubs ) where
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
-import AsmCodeGen ( nativeCodeGen )
-#endif
+import AsmCodeGen ( nativeCodeGen )
import LlvmCodeGen ( llvmCodeGen )
import UniqSupply ( mkSplitUniqSupply )
@@ -149,24 +147,16 @@ outputC dflags filenm flat_absC packages
\begin{code}
outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-
-#ifndef OMIT_NATIVE_CODEGEN
-
outputAsm dflags filenm flat_absC
+ | cGhcWithNativeCodeGen == "YES"
= do ncg_uniqs <- mkSplitUniqSupply 'n'
{-# SCC "OutputAsm" #-} doOutput filenm $
- \f -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen dflags f ncg_uniqs flat_absC
- where
+ \f -> {-# SCC "NativeCodeGen" #-}
+ nativeCodeGen dflags f ncg_uniqs flat_absC
-#else /* OMIT_NATIVE_CODEGEN */
-
-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}
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index e430c6e269aae507eda90251045233f76e9b8b02..1694aba9b87577cca5778647948d7582a861d4e2 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,7 +16,6 @@ module DriverMkDepend (
#include "HsVersions.h"
import qualified GHC
--- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
@@ -35,7 +34,6 @@ import FastString
import Exception
import ErrUtils
--- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index f6a9738af10cc24522f8948b6f5266334b3ed3d9..4702682ee416466fe4e258a6d3573a4f67494396 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -143,11 +143,7 @@ nextPhase (Hsc _) = HCc
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 = MergeStub
nextPhase Ccpp = As
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 61486fc3b6fb313ee025739f3af57aecb7bc4542..2719470aaa82cead8b19bfb31fc172a2145939df 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -51,11 +51,10 @@ import SrcLoc
import FastString
import LlvmCodeGen ( llvmFixupAsm )
import MonadUtils
+import Platform
--- import Data.Either
import Exception
import Data.IORef ( readIORef )
--- import GHC.Exts ( Int(..) )
import System.Directory
import System.FilePath
import System.IO
@@ -269,11 +268,11 @@ link :: GhcLink -- interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-#ifdef GHCI
link LinkInMemory _ _ _
- = do -- Not Linking...(demand linker will do the job)
- return Succeeded
-#endif
+ = if cGhcWithInterpreter == "YES"
+ then -- Not Linking...(demand linker will do the job)
+ return Succeeded
+ else panicBadLink LinkInMemory
link NoLink _ _ _
= return Succeeded
@@ -284,11 +283,6 @@ link LinkBinary dflags batch_attempt_linking hpt
link LinkDynLib dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
-#ifndef GHCI
--- warning suppression
-link other _ _ _ = panicBadLink other
-#endif
-
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
@@ -779,9 +773,9 @@ runPhase (Cpp sf) input_fn dflags0
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, 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
- io $ checkProcessArgsResult unhandled_flags
setDynFlags dflags2
@@ -814,8 +808,8 @@ runPhase (HsPp sf) input_fn dflags
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
setDynFlags dflags1
- io $ handleFlagWarnings dflags1 warns
io $ checkProcessArgsResult unhandled_flags
+ io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
@@ -1027,11 +1021,10 @@ runPhase cc_phase input_fn dflags
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
- let md_c_flags = machdepCCOpts dflags
- gcc_extra_viac_flags <- io $ 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
@@ -1062,15 +1055,14 @@ runPhase cc_phase input_fn dflags
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.
@@ -1092,33 +1084,33 @@ runPhase cc_phase input_fn dflags
, 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 platformArch (targetPlatform dflags) == ArchSPARC
+ then ["-mcpu=v9"]
+ else [])
+
++ (if hcc
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
@@ -1177,11 +1169,10 @@ runPhase As input_fn dflags
-- might be a hierarchical module.
io $ createDirectoryHierarchy (takeDirectory output_fn)
- let md_c_flags = machdepCCOpts 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
@@ -1189,14 +1180,15 @@ runPhase As input_fn dflags
-- 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 (next_phase, output_fn)
@@ -1232,11 +1224,10 @@ runPhase SplitAs _input_fn dflags
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
@@ -1244,14 +1235,15 @@ runPhase SplitAs _input_fn dflags
-- 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)
+ ])
io $ mapM_ assemble_file [1..n]
@@ -1313,24 +1305,18 @@ runPhase LlvmOpt input_fn dflags
-- fix up some pretty big deficiencies in the code we generate
llvmOpts = ["-mem2reg", "-O1", "-O2"]
-
-----------------------------------------------------------------------------
-- LlvmLlc phase
runPhase LlvmLlc input_fn dflags
= do
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 <- phaseOutputFilename nphase
+ output_fn <- phaseOutputFilename LlvmMangle
io $ SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
@@ -1339,14 +1325,12 @@ runPhase LlvmLlc input_fn dflags
SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts)
- return (nphase, 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
@@ -1418,14 +1402,12 @@ mkExtraCObj dflags xs
oFile <- newTempName dflags "o"
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
mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
@@ -1433,7 +1415,10 @@ 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]))
+ link_opts link_info]
+ <> char '\n')) -- final newline, to
+ -- keep gcc happy
+
where
mk_rts_opts_enabled val
= vcat [text "#include \"Rts.h\"",
@@ -1574,7 +1559,7 @@ getHCFilePackages filename =
linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
linkBinary dflags o_files dep_packages = do
- let verb = getVerbFlag dflags
+ let verbFlags = getVerbFlags dflags
output_fn = exeFileName dflags
-- get the full list of packages to link with, by combining the
@@ -1650,20 +1635,20 @@ linkBinary dflags o_files dep_packages = do
rc_objs <- maybeCreateManifest dflags output_fn
- let md_c_flags = machdepCCOpts dflags
SysTools.runLink dflags (
- [ SysTools.Option verb
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- ]
+ map SysTools.Option verbFlags
+ ++ [ SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ ]
++ map SysTools.Option (
- md_c_flags
+ []
-#ifdef mingw32_TARGET_OS
-- Permit the linker to auto link _symbol to _imp_symbol.
-- This lets us link against DLLs without needing an "import library".
- ++ ["-Wl,--enable-auto-import"]
-#endif
+ ++ (if platformOS (targetPlatform dflags) == OSMinGW32
+ then ["-Wl,--enable-auto-import"]
+ else [])
+
++ o_files
++ extra_ld_inputs
++ lib_path_opts
@@ -1694,19 +1679,15 @@ linkBinary dflags o_files dep_packages = do
exeFileName :: DynFlags -> FilePath
exeFileName dflags
| Just s <- outputFile dflags =
-#if defined(mingw32_HOST_OS)
- if null (takeExtension s)
- then s <.> "exe"
- else s
-#else
- s
-#endif
+ if platformOS (targetPlatform dflags) == OSMinGW32
+ then if null (takeExtension s)
+ then s <.> "exe"
+ else s
+ else s
| otherwise =
-#if defined(mingw32_HOST_OS)
- "main.exe"
-#else
- "a.out"
-#endif
+ if platformOS (targetPlatform dflags) == OSMinGW32
+ then "main.exe"
+ else "a.out"
maybeCreateManifest
:: DynFlags
@@ -1768,7 +1749,7 @@ maybeCreateManifest dflags exe_filename = do
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages = do
- let verb = getVerbFlag dflags
+ let verbFlags = getVerbFlags dflags
let o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
@@ -1802,7 +1783,6 @@ linkDynLib dflags o_files dep_packages = do
-- probably _stub.o files
extra_ld_inputs <- readIORef v_Ld_inputs
- let md_c_flags = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
@@ -1813,22 +1793,21 @@ linkDynLib dflags o_files dep_packages = do
-----------------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
- SysTools.runLink dflags
- ([ SysTools.Option verb
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- , SysTools.Option "-shared"
- ] ++
- [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
- | dopt Opt_SharedImplib dflags
- ]
+ SysTools.runLink dflags (
+ map SysTools.Option verbFlags
+ ++ [ SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ , SysTools.Option "-shared"
+ ] ++
+ [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
+ | dopt Opt_SharedImplib dflags
+ ]
++ map (SysTools.FileOption "") o_files
++ map SysTools.Option (
- md_c_flags
-- Permit the linker to auto link _symbol to _imp_symbol
-- This lets us link against DLLs without needing an "import library"
- ++ ["-Wl,--enable-auto-import"]
+ ["-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ lib_path_opts
@@ -1873,15 +1852,14 @@ linkDynLib dflags o_files dep_packages = do
Nothing -> do
pwd <- getCurrentDirectory
return $ pwd `combine` output_fn
- SysTools.runLink dflags
- ([ SysTools.Option verb
- , SysTools.Option "-dynamiclib"
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- ]
+ SysTools.runLink dflags (
+ map SysTools.Option verbFlags
+ ++ [ SysTools.Option "-dynamiclib"
+ , SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ ]
++ map SysTools.Option (
- md_c_flags
- ++ o_files
+ o_files
++ [ "-undefined", "dynamic_lookup", "-single_module",
#if !defined(x86_64_TARGET_ARCH)
"-Wl,-read_only_relocs,suppress",
@@ -1909,14 +1887,13 @@ linkDynLib dflags o_files dep_packages = do
-- non-PIC intra-package-relocations
["-Wl,-Bsymbolic"]
- SysTools.runLink dflags
- ([ SysTools.Option verb
- , SysTools.Option "-o"
- , SysTools.FileOption "" output_fn
- ]
+ SysTools.runLink dflags (
+ map SysTools.Option verbFlags
+ ++ [ SysTools.Option "-o"
+ , SysTools.FileOption "" output_fn
+ ]
++ map SysTools.Option (
- md_c_flags
- ++ o_files
+ o_files
++ [ "-shared" ]
++ bsymbolicFlag
-- Set the library soname. We use -h rather than -soname as
@@ -1942,14 +1919,11 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
- let verb = getVerbFlag dflags
+ let verbFlags = getVerbFlags dflags
let cc_opts
- | not include_cc_opts = []
- | otherwise = (optc ++ md_c_flags)
- where
- optc = getOpts dflags opt_c
- md_c_flags = machdepCCOpts dflags
+ | include_cc_opts = getOpts dflags opt_c
+ | otherwise = []
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
@@ -1962,7 +1936,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
-- remember, in code we *compile*, the HOST is the same our TARGET,
-- and BUILD is the same as our HOST.
- cpp_prog ([SysTools.Option verb]
+ cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
@@ -2001,7 +1975,6 @@ joinObjectFiles dflags o_files output_fn = do
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 = ""
@@ -2013,8 +1986,6 @@ joinObjectFiles dflags o_files output_fn = do
ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none"
| otherwise = ""
- md_c_flags = machdepCCOpts dflags
-
if cLdIsGNULd == "YES"
then do
script <- newTempName dflags "ldscript"
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9f504a10d1fde1366c9930d9acc4e92abf4a7596..d9f3246c34217ebe86e2b53e8925c66b0103fbac 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -w #-}
--- Temporary, until rtsIsProfiled is fixed
-
-- |
-- Dynamic flags
--
@@ -35,12 +32,21 @@ module DynFlags (
DPHBackend(..), dphPackageMaybe,
wayNames,
+ Settings(..),
+ ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
+ extraGccViaCFlags, systemPackageConfig,
+ pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
+ pgm_sysman, pgm_windres, pgm_lo, pgm_lc,
+ opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l,
+ opt_windres, opt_lo, opt_lc,
+
+
-- ** Manipulating DynFlags
- defaultDynFlags, -- DynFlags
+ defaultDynFlags, -- Settings -> DynFlags
initDynFlags, -- DynFlags -> IO DynFlags
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
- getVerbFlag,
+ getVerbFlags,
updOptLevel,
setTmpDir,
setPackageName,
@@ -54,14 +60,13 @@ module DynFlags (
supportedLanguagesAndExtensions,
-- ** DynFlag C compiler options
- machdepCCOpts, picCCOpts,
+ picCCOpts,
-- * Configuration of the stg-to-stg passes
StgToDo(..),
getStgToDo,
-- * Compiler configuration suitable for display to the user
- Printable(..),
compilerInfo
#ifdef GHCI
-- Only in stage 2 can we be sure that the RTS
@@ -72,9 +77,7 @@ module DynFlags (
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
import Platform
-#endif
import Module
import PackageConfig
import PrelNames ( mAIN )
@@ -90,10 +93,14 @@ import Maybes ( orElse )
import SrcLoc
import FastString
import Outputable
+#ifdef GHCI
import Foreign.C ( CInt )
+#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
+#ifdef GHCI
import System.IO.Unsafe ( unsafePerformIO )
+#endif
import Data.IORef
import Control.Monad ( when )
@@ -101,7 +108,8 @@ import Data.Char
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
import System.FilePath
import System.IO ( stderr, hPutChar )
@@ -116,6 +124,21 @@ data DynFlag
| Opt_D_dump_raw_cmm
| Opt_D_dump_cmmz
| Opt_D_dump_cmmz_pretty
+ -- All of the cmmz subflags (there are a lot!) Automatically
+ -- enabled if you run -ddump-cmmz
+ | Opt_D_dump_cmmz_cbe
+ | Opt_D_dump_cmmz_proc
+ | Opt_D_dump_cmmz_spills
+ | Opt_D_dump_cmmz_rewrite
+ | Opt_D_dump_cmmz_dead
+ | Opt_D_dump_cmmz_stub
+ | Opt_D_dump_cmmz_sp
+ | Opt_D_dump_cmmz_procmap
+ | Opt_D_dump_cmmz_split
+ | Opt_D_dump_cmmz_lower
+ | Opt_D_dump_cmmz_info
+ | Opt_D_dump_cmmz_cafs
+ -- end cmmz subflags
| Opt_D_dump_cps_cmm
| Opt_D_dump_cvt_cmm
| Opt_D_dump_asm
@@ -251,7 +274,6 @@ data DynFlag
-- misc opts
| Opt_Pp
| Opt_ForceRecomp
- | Opt_DryRun
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
@@ -314,7 +336,6 @@ data ExtensionFlag
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
- | Opt_Generics -- "Derivable type classes"
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
| Opt_UnboxedTuples
@@ -336,6 +357,9 @@ data ExtensionFlag
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
+ | Opt_DeriveGeneric -- Allow deriving Generic/1
+ | Opt_DefaultSignatures -- Allow extra signatures for defmeths
+ | Opt_Generics -- Old generic classes, now deprecated
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
@@ -351,6 +375,7 @@ data ExtensionFlag
| Opt_KindSignatures
| Opt_ParallelListComp
| Opt_TransformListComp
+ | Opt_MonadComprehensions
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_DoRec
@@ -393,9 +418,7 @@ data DynFlags = DynFlags {
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
-#ifndef OMIT_NATIVE_CODEGEN
- targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG.
-#endif
+ targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG.
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
importPaths :: [FilePath],
mainModIs :: Module,
@@ -440,41 +463,13 @@ data DynFlags = DynFlags {
libraryPaths :: [String],
frameworkPaths :: [String], -- used on darwin only
cmdlineFrameworks :: [String], -- ditto
- tmpDir :: String, -- no trailing '/'
- ghcUsagePath :: FilePath, -- Filled in by SysTools
- ghciUsagePath :: FilePath, -- ditto
rtsOpts :: Maybe String,
rtsOptsEnabled :: RtsOptsEnabled,
hpcDir :: String, -- ^ Path to store the .mix files
- -- options for particular phases
- opt_L :: [String],
- opt_P :: [String],
- opt_F :: [String],
- opt_c :: [String],
- opt_m :: [String],
- opt_a :: [String],
- opt_l :: [String],
- opt_windres :: [String],
- opt_lo :: [String], -- LLVM: llvm optimiser
- opt_lc :: [String], -- LLVM: llc static compiler
-
- -- commands for particular phases
- pgm_L :: String,
- pgm_P :: (String,[Option]),
- pgm_F :: String,
- pgm_c :: (String,[Option]),
- pgm_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,
@@ -484,8 +479,6 @@ data DynFlags = DynFlags {
-- Package flags
extraPkgConfs :: [FilePath],
- topDir :: FilePath, -- filled in by SysTools
- systemPackageConfig :: FilePath, -- ditto
-- ^ The @-package-conf@ flags given on the command line, in the order
-- they appeared.
@@ -504,6 +497,11 @@ data DynFlags = DynFlags {
filesToClean :: IORef [FilePath],
dirsToClean :: IORef (Map FilePath FilePath),
+ -- Names of files which were generated from -ddump-to-file; used to
+ -- track which ones we need to truncate because it's our first run
+ -- through
+ generatedDumps :: IORef (Set FilePath),
+
-- hsc dynamic flags
flags :: [DynFlag],
-- Don't change this without updating extensionFlags:
@@ -520,6 +518,105 @@ data DynFlags = DynFlags {
haddockOptions :: Maybe String
}
+data Settings = Settings {
+ sGhcUsagePath :: FilePath, -- Filled in by SysTools
+ sGhciUsagePath :: FilePath, -- ditto
+ sTopDir :: FilePath,
+ sTmpDir :: String, -- no trailing '/'
+ -- You shouldn't need to look things up in rawSettings directly.
+ -- They should have their own fields instead.
+ sRawSettings :: [(String, String)],
+ sExtraGccViaCFlags :: [String],
+ sSystemPackageConfig :: FilePath,
+ -- commands for particular phases
+ sPgm_L :: String,
+ sPgm_P :: (String,[Option]),
+ sPgm_F :: String,
+ sPgm_c :: (String,[Option]),
+ sPgm_s :: (String,[Option]),
+ sPgm_a :: (String,[Option]),
+ sPgm_l :: (String,[Option]),
+ sPgm_dll :: (String,[Option]),
+ sPgm_T :: String,
+ sPgm_sysman :: String,
+ sPgm_windres :: String,
+ sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser
+ sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler
+ -- options for particular phases
+ sOpt_L :: [String],
+ sOpt_P :: [String],
+ sOpt_F :: [String],
+ sOpt_c :: [String],
+ sOpt_m :: [String],
+ sOpt_a :: [String],
+ sOpt_l :: [String],
+ sOpt_windres :: [String],
+ sOpt_lo :: [String], -- LLVM: llvm optimiser
+ sOpt_lc :: [String] -- LLVM: llc static compiler
+
+ }
+
+ghcUsagePath :: DynFlags -> FilePath
+ghcUsagePath dflags = sGhcUsagePath (settings dflags)
+ghciUsagePath :: DynFlags -> FilePath
+ghciUsagePath dflags = sGhciUsagePath (settings dflags)
+topDir :: DynFlags -> FilePath
+topDir dflags = sTopDir (settings dflags)
+tmpDir :: DynFlags -> String
+tmpDir dflags = sTmpDir (settings dflags)
+rawSettings :: DynFlags -> [(String, String)]
+rawSettings dflags = sRawSettings (settings dflags)
+extraGccViaCFlags :: DynFlags -> [String]
+extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags)
+systemPackageConfig :: DynFlags -> FilePath
+systemPackageConfig dflags = sSystemPackageConfig (settings dflags)
+pgm_L :: DynFlags -> String
+pgm_L dflags = sPgm_L (settings dflags)
+pgm_P :: DynFlags -> (String,[Option])
+pgm_P dflags = sPgm_P (settings dflags)
+pgm_F :: DynFlags -> String
+pgm_F dflags = sPgm_F (settings dflags)
+pgm_c :: DynFlags -> (String,[Option])
+pgm_c dflags = sPgm_c (settings dflags)
+pgm_s :: DynFlags -> (String,[Option])
+pgm_s dflags = sPgm_s (settings dflags)
+pgm_a :: DynFlags -> (String,[Option])
+pgm_a dflags = sPgm_a (settings dflags)
+pgm_l :: DynFlags -> (String,[Option])
+pgm_l dflags = sPgm_l (settings dflags)
+pgm_dll :: DynFlags -> (String,[Option])
+pgm_dll dflags = sPgm_dll (settings dflags)
+pgm_T :: DynFlags -> String
+pgm_T dflags = sPgm_T (settings dflags)
+pgm_sysman :: DynFlags -> String
+pgm_sysman dflags = sPgm_sysman (settings dflags)
+pgm_windres :: DynFlags -> String
+pgm_windres dflags = sPgm_windres (settings dflags)
+pgm_lo :: DynFlags -> (String,[Option])
+pgm_lo dflags = sPgm_lo (settings dflags)
+pgm_lc :: DynFlags -> (String,[Option])
+pgm_lc dflags = sPgm_lc (settings dflags)
+opt_L :: DynFlags -> [String]
+opt_L dflags = sOpt_L (settings dflags)
+opt_P :: DynFlags -> [String]
+opt_P dflags = sOpt_P (settings dflags)
+opt_F :: DynFlags -> [String]
+opt_F dflags = sOpt_F (settings dflags)
+opt_c :: DynFlags -> [String]
+opt_c dflags = sOpt_c (settings dflags)
+opt_m :: DynFlags -> [String]
+opt_m dflags = sOpt_m (settings dflags)
+opt_a :: DynFlags -> [String]
+opt_a dflags = sOpt_a (settings dflags)
+opt_l :: DynFlags -> [String]
+opt_l dflags = sOpt_l (settings dflags)
+opt_windres :: DynFlags -> [String]
+opt_windres dflags = sOpt_windres (settings dflags)
+opt_lo :: DynFlags -> [String]
+opt_lo dflags = sOpt_lo (settings dflags)
+opt_lc :: DynFlags -> [String]
+opt_lc dflags = sOpt_lc (settings dflags)
+
wayNames :: DynFlags -> [WayName]
wayNames = map wayName . ways
@@ -552,6 +649,14 @@ data HscTarget
| HscNothing -- ^ Don't generate any code. See notes above.
deriving (Eq, Show)
+showHscTargetFlag :: HscTarget -> String
+showHscTargetFlag HscC = "-fvia-c"
+showHscTargetFlag HscAsm = "-fasm"
+showHscTargetFlag HscLlvm = "-fllvm"
+showHscTargetFlag HscJava = panic "No flag for HscJava"
+showHscTargetFlag HscInterpreted = "-fbyte-code"
+showHscTargetFlag HscNothing = "-fno-code"
+
-- | Will this target result in an object file on the disk?
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC = True
@@ -614,8 +719,9 @@ defaultHscTarget = defaultObjectTarget
-- object files on the current platform.
defaultObjectTarget :: HscTarget
defaultObjectTarget
+ | cGhcUnregisterised == "YES" = HscC
| cGhcWithNativeCodeGen == "YES" = HscAsm
- | otherwise = HscC
+ | otherwise = HscLlvm
data DynLibLoader
= Deployable
@@ -632,18 +738,20 @@ initDynFlags dflags = do
ways <- readIORef v_Ways
refFilesToClean <- newIORef []
refDirsToClean <- newIORef Map.empty
+ refGeneratedDumps <- newIORef Set.empty
return dflags{
ways = ways,
buildTag = mkBuildTag (filter (not . wayRTSOnly) ways),
rtsBuildTag = mkBuildTag ways,
filesToClean = refFilesToClean,
- dirsToClean = refDirsToClean
+ dirsToClean = refDirsToClean,
+ generatedDumps = refGeneratedDumps
}
-- | 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,
@@ -656,15 +764,13 @@ defaultDynFlags =
maxSimplIterations = 4,
shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
- specConstrThreshold = Just 200,
+ specConstrThreshold = Just 2000,
specConstrCount = Just 3,
- liberateCaseThreshold = Just 200,
+ liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
strictnessBefore = [],
-#ifndef OMIT_NATIVE_CODEGEN
targetPlatform = defaultTargetPlatform,
-#endif
cmdlineHcIncludes = [],
importPaths = ["."],
mainModIs = mAIN,
@@ -693,25 +799,11 @@ defaultDynFlags =
libraryPaths = [],
frameworkPaths = [],
cmdlineFrameworks = [],
- tmpDir = cDEFAULT_TMPDIR,
rtsOpts = Nothing,
rtsOptsEnabled = RtsOptsSafeOnly,
hpcDir = ".hpc",
- opt_L = [],
- opt_P = (if opt_PIC
- then ["-D__PIC__", "-U __PIC__"] -- this list is reversed
- else []),
- opt_F = [],
- opt_c = [],
- opt_a = [],
- opt_m = [],
- opt_l = [],
- opt_windres = [],
- opt_lo = [],
- opt_lc = [],
-
extraPkgConfs = [],
packageFlags = [],
pkgDatabase = Nothing,
@@ -720,25 +812,7 @@ defaultDynFlags =
buildTag = panic "defaultDynFlags: No buildTag",
rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag",
splitInfo = Nothing,
- -- initSysTools fills all these in
- ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath",
- ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath",
- topDir = panic "defaultDynFlags: No topDir",
- systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags",
- pgm_L = panic "defaultDynFlags: No pgm_L",
- pgm_P = panic "defaultDynFlags: No pgm_P",
- pgm_F = panic "defaultDynFlags: No pgm_F",
- pgm_c = panic "defaultDynFlags: No pgm_c",
- pgm_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,
@@ -747,6 +821,7 @@ defaultDynFlags =
-- end of ghc -M values
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
+ generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
flags = defaultFlags,
language = Nothing,
@@ -755,12 +830,12 @@ defaultDynFlags =
log_action = \severity srcSpan style msg ->
case severity of
- SevOutput -> printOutput (msg style)
- SevInfo -> printErrs (msg style)
- SevFatal -> printErrs (msg style)
+ SevOutput -> printSDoc msg style
+ SevInfo -> printErrs msg style
+ SevFatal -> printErrs msg style
_ -> do
hPutChar stderr '\n'
- printErrs ((mkLocMessage srcSpan msg) style)
+ printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
@@ -800,7 +875,11 @@ languageExtensions Nothing
-- But NB it's implied by GADTs etc
-- SLPJ September 2010
: Opt_NondecreasingIndentation -- This has been on by default for some time
- : languageExtensions (Just Haskell2010)
+ : delete Opt_DatatypeContexts -- The Haskell' committee decided to
+ -- remove datatype contexts from the
+ -- language:
+ -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
+ (languageExtensions (Just Haskell2010))
languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude,
@@ -873,10 +952,10 @@ getOpts dflags opts = reverse (opts dflags)
-- | Gets the verbosity flag for the current verbosity level. This is fed to
-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included
-getVerbFlag :: DynFlags -> String
-getVerbFlag dflags
- | verbosity dflags >= 3 = "-v"
- | otherwise = ""
+getVerbFlags :: DynFlags -> [String]
+getVerbFlags dflags
+ | verbosity dflags >= 4 = ["-v"]
+ | otherwise = []
setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName,
setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
@@ -912,9 +991,9 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option.
-setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)}
-addOptl f d = d{ opt_l = f : opt_l d}
-addOptP f d = d{ opt_P = f : opt_P d}
+setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)})
+addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s})
+addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s})
setDepMakefile :: FilePath -> DynFlags -> DynFlags
@@ -1052,16 +1131,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do
= runCmdLine (processArgs flag_spec args') dflags0
when (not (null errs)) $ ghcError $ errorsToGhcException errs
- let (pic_warns, dflags2)
-#if !(x86_64_TARGET_ARCH && linux_TARGET_OS)
- | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm
- = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -"
- ++ "dynamic on this platform;\n ignoring -fllvm"],
- dflags1{ hscTarget = HscAsm })
-#endif
- | otherwise = ([], dflags1)
-
- return (dflags2, leftover, pic_warns ++ warns)
+ return (dflags1, leftover, warns)
{- **********************************************************************
@@ -1085,7 +1155,7 @@ allFlags = map ('-':) $
--------------- The main flags themselves ------------------
dynamic_flags :: [Flag (CmdLineP DynFlags)]
dynamic_flags = [
- Flag "n" (NoArg (setDynFlag Opt_DryRun))
+ Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect"))
, Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp))
, Flag "F" (NoArg (setDynFlag Opt_Pp))
, Flag "#include"
@@ -1095,30 +1165,30 @@ dynamic_flags = [
------- Specific phases --------------------------------------------
-- need to appear before -pgmL to be parsed as LLVM flags.
- , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])}))
- , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])}))
- , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f}))
+ , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])})))
+ , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])})))
+ , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f})))
, Flag "pgmP" (hasArg setPgmP)
- , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f}))
- , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])}))
+ , Flag "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 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 "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
@@ -1145,8 +1215,8 @@ dynamic_flags = [
, Flag "dylib-install-name" (hasArg setDylibInstallName)
------- Libraries ---------------------------------------------------
- , Flag "L" (Prefix addLibraryPath)
- , Flag "l" (AnySuffix (upd . addOptl))
+ , Flag "L" (Prefix addLibraryPath)
+ , Flag "l" (hasArg (addOptl . ("-l" ++)))
------- Frameworks --------------------------------------------------
-- -framework-path should really be -F ...
@@ -1214,6 +1284,18 @@ dynamic_flags = [
, Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm)
, Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz)
, Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty)
+ , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe)
+ , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills)
+ , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc)
+ , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite)
+ , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead)
+ , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub)
+ , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp)
+ , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap)
+ , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split)
+ , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower)
+ , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info)
+ , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs)
, Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats)
, Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm)
, Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm)
@@ -1299,10 +1381,11 @@ dynamic_flags = [
, Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
------ Optimisation flags ------------------------------------------
- , Flag "O" (noArg (setOptLevel 1))
- , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead")
- , Flag "Odph" (noArg setDPHOpt)
- , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
+ , Flag "O" (noArgM (setOptLevel 1))
+ , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead"
+ setOptLevel 0 dflags))
+ , Flag "Odph" (noArgM setDPHOpt)
+ , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1)))
-- If the number is missing, use 1
, Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n }))
@@ -1317,7 +1400,7 @@ dynamic_flags = [
, Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n }))
, Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
, Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n }))
- , Flag "ffloat-all-lams" (intSuffix (\n d -> d{ floatLamArgs = Nothing }))
+ , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing }))
------ Profiling ----------------------------------------------------
@@ -1569,6 +1652,7 @@ xFlags = [
( "EmptyDataDecls", Opt_EmptyDataDecls, nop ),
( "ParallelListComp", Opt_ParallelListComp, nop ),
( "TransformListComp", Opt_TransformListComp, nop ),
+ ( "MonadComprehensions", Opt_MonadComprehensions, nop),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ),
( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ),
@@ -1577,14 +1661,15 @@ xFlags = [
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
- ( "RecursiveDo", Opt_RecursiveDo,
+ ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
- ( "DoRec", Opt_DoRec, nop ),
+ ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
- ( "Generics", Opt_Generics, nop ),
+ ( "Generics", Opt_Generics,
+ \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ),
( "ImplicitPrelude", Opt_ImplicitPrelude, nop ),
( "RecordWildCards", Opt_RecordWildCards, nop ),
( "NamedFieldPuns", Opt_RecordPuns, nop ),
@@ -1626,6 +1711,8 @@ xFlags = [
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
+ ( "DeriveGeneric", Opt_DeriveGeneric, nop ),
+ ( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ),
( "FlexibleContexts", Opt_FlexibleContexts, nop ),
( "FlexibleInstances", Opt_FlexibleInstances, nop ),
@@ -1806,6 +1893,7 @@ glasgowExtsFlags = [
, Opt_DeriveFunctor
, Opt_DeriveFoldable
, Opt_DeriveTraversable
+ , Opt_DeriveGeneric
, Opt_FlexibleContexts
, Opt_FlexibleInstances
, Opt_ConstrainedClassMethods
@@ -1833,18 +1921,20 @@ foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
rtsIsProfiled :: Bool
rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0
+#endif
checkTemplateHaskellOk :: Bool -> DynP ()
-checkTemplateHaskellOk turn_on
+#ifdef GHCI
+checkTemplateHaskellOk turn_on
| turn_on && rtsIsProfiled
= addErr "You can't use Template Haskell with a profiled compiler"
| otherwise
= return ()
#else
--- In stage 1 we don't know that the RTS has rts_isProfiled,
+-- In stage 1 we don't know that the RTS has rts_isProfiled,
-- so we simply say "ok". It doesn't matter because TH isn't
-- available in stage 1 anyway.
-checkTemplateHaskellOk turn_on = return ()
+checkTemplateHaskellOk _ = return ()
#endif
{- **********************************************************************
@@ -1856,13 +1946,21 @@ checkTemplateHaskellOk turn_on = return ()
type DynP = EwM (CmdLineP DynFlags)
upd :: (DynFlags -> DynFlags) -> DynP ()
-upd f = liftEwM (do { dfs <- getCmdLineState
- ; putCmdLineState $! (f dfs) })
+upd f = liftEwM (do dflags <- getCmdLineState
+ putCmdLineState $! f dflags)
+
+updM :: (DynFlags -> DynP DynFlags) -> DynP ()
+updM f = do dflags <- liftEwM getCmdLineState
+ dflags' <- f dflags
+ liftEwM $ putCmdLineState $! dflags'
--------------- Constructor functions for OptKind -----------------
noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
noArg fn = NoArg (upd fn)
+noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
+noArgM fn = NoArg (updM fn)
+
noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags)
noArgDF fn deprec = NoArg (upd fn >> deprecate deprec)
@@ -1876,6 +1974,10 @@ hasArgDF fn deprec = HasArg (\s -> do { upd (fn s)
intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
intSuffix fn = IntSuffix (\n -> upd (fn n))
+optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)
+ -> OptKind (CmdLineP DynFlags)
+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
+
setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
@@ -1900,6 +2002,10 @@ unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f)
-- When you un-set f, however, we don't un-set the things it implies
-- (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
@@ -1919,14 +2025,13 @@ forceRecompile :: DynP ()
-- recompiled which probably isn't what you want
forceRecompile = do { dfs <- liftEwM getCmdLineState
; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) }
- where
+ where
force_recomp dfs = isOneShot (ghcMode dfs)
setVerboseCore2Core :: DynP ()
setVerboseCore2Core = do forceRecompile
setDynFlag Opt_D_verbose_core2core
upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
-
setDumpSimplPhases :: String -> DynP ()
setDumpSimplPhases s = do forceRecompile
@@ -1970,20 +2075,43 @@ setTarget l = upd set
-- not from bytecode to object-code. The idea is that -fasm/-fllvm
-- can be safely used in an OPTIONS_GHC pragma.
setObjTarget :: HscTarget -> DynP ()
-setObjTarget l = upd set
+setObjTarget l = updM set
where
- set dfs
- | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
- | otherwise = dfs
-
-setOptLevel :: Int -> DynFlags -> DynFlags
+ set dflags
+ | isObjectTarget (hscTarget dflags)
+ = case l of
+ HscC
+ | cGhcUnregisterised /= "YES" ->
+ do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
+ return dflags
+ HscAsm
+ | cGhcWithNativeCodeGen /= "YES" ->
+ do addWarn ("Compiler has no native codegen, so ignoring " ++
+ flag)
+ return dflags
+ HscLlvm
+ | cGhcUnregisterised == "YES" ->
+ do addWarn ("Compiler unregisterised, so ignoring " ++ flag)
+ return dflags
+ | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
+ (not opt_Static || opt_PIC)
+ ->
+ do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
+ return dflags
+ _ -> return $ dflags { hscTarget = l }
+ | otherwise = return dflags
+ where platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
+ flag = showHscTargetFlag l
+
+setOptLevel :: Int -> DynFlags -> DynP DynFlags
setOptLevel n dflags
| hscTarget dflags == HscInterpreted && n > 0
- = dflags
- -- not in IO any more, oh well:
- -- putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+ = do addWarn "-O conflicts with --interactive; -O ignored."
+ return dflags
| otherwise
- = updOptLevel n dflags
+ = return (updOptLevel n dflags)
-- -Odph is equivalent to
@@ -1992,7 +2120,7 @@ setOptLevel n dflags
-- -fmax-simplifier-iterations20 this is necessary sometimes
-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion
--
-setDPHOpt :: DynFlags -> DynFlags
+setDPHOpt :: DynFlags -> DynP DynFlags
setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20
, simplPhases = 3
})
@@ -2044,7 +2172,6 @@ addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> D
addImportPath "" = upd (\s -> s{importPaths = []})
addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
-
addLibraryPath p =
upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
@@ -2115,7 +2242,7 @@ splitPathList s = filter notNull (splitUp s)
-- tmpDir, where we store temporary files.
setTmpDir :: FilePath -> DynFlags -> DynFlags
-setTmpDir dir dflags = dflags{ tmpDir = normalise dir }
+setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir })
-- we used to fix /cygdrive/c/.. on Windows, but this doesn't
-- seem necessary now --SDM 7/2/2008
@@ -2140,46 +2267,14 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg}
-- There are some options that we need to pass to gcc when compiling
-- Haskell code via C, but are only supported by recent versions of
-- gcc. The configure script decides which of these options we need,
--- and puts them in the file "extra-gcc-opts" in $topdir, which is
--- read before each via-C compilation. The advantage of having these
--- in a separate file is that the file can be created at install-time
--- depending on the available gcc version, and even re-generated later
--- if gcc is upgraded.
+-- and puts them in the "settings" file in $topdir. The advantage of
+-- having these in a separate file is that the file can be created at
+-- install-time depending on the available gcc version, and even
+-- re-generated later if gcc is upgraded.
--
-- The options below are not dependent on the version of gcc, only the
-- platform.
-machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations
-machdepCCOpts dflags = cCcOpts ++ machdepCCOpts'
-
-machdepCCOpts' :: [String] -- flags for all C compilations
-machdepCCOpts'
-#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 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.
- = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else []
-
-#else
- = []
-#endif
-
picCCOpts :: DynFlags -> [String]
picCCOpts _dflags
#if darwin_TARGET_OS
@@ -2222,30 +2317,34 @@ can_split = cSupportsSplitObjs == "YES"
-- -----------------------------------------------------------------------------
-- Compiler Info
-data Printable = String String
- | FromDynFlags (DynFlags -> String)
-
-compilerInfo :: [(String, Printable)]
-compilerInfo = [("Project name", String cProjectName),
- ("Project version", String cProjectVersion),
- ("Booter version", String cBooterVersion),
- ("Stage", String cStage),
- ("Build platform", String cBuildPlatformString),
- ("Host platform", String cHostPlatformString),
- ("Target platform", String cTargetPlatformString),
- ("Have interpreter", String cGhcWithInterpreter),
- ("Object splitting supported", String cSupportsSplitObjs),
- ("Have native code generator", String cGhcWithNativeCodeGen),
- ("Support SMP", String cGhcWithSMP),
- ("Unregisterised", String cGhcUnregisterised),
- ("Tables next to code", String cGhcEnableTablesNextToCode),
- ("RTS ways", String cGhcRTSWays),
- ("Leading underscore", String cLeadingUnderscore),
- ("Debug on", String (show debugIsOn)),
- ("LibDir", FromDynFlags topDir),
- ("Global Package DB", FromDynFlags systemPackageConfig),
- ("C compiler flags", String (show cCcOpts)),
- ("Gcc Linker flags", String (show cGccLinkerOpts)),
- ("Ld Linker flags", String (show cLdLinkerOpts))
- ]
+compilerInfo :: DynFlags -> [(String, String)]
+compilerInfo dflags
+ = -- We always make "Project name" be first to keep parsing in
+ -- other languages simple, i.e. when looking for other fields,
+ -- you don't have to worry whether there is a leading '[' or not
+ ("Project name", cProjectName)
+ -- Next come the settings, so anything else can be overridden
+ -- in the settings file (as "lookup" uses the first match for the
+ -- key)
+ : rawSettings dflags
+ ++ [("Project version", cProjectVersion),
+ ("Booter version", cBooterVersion),
+ ("Stage", cStage),
+ ("Build platform", cBuildPlatformString),
+ ("Host platform", cHostPlatformString),
+ ("Target platform", cTargetPlatformString),
+ ("Have interpreter", cGhcWithInterpreter),
+ ("Object splitting supported", cSupportsSplitObjs),
+ ("Have native code generator", cGhcWithNativeCodeGen),
+ ("Support SMP", cGhcWithSMP),
+ ("Unregisterised", cGhcUnregisterised),
+ ("Tables next to code", cGhcEnableTablesNextToCode),
+ ("RTS ways", cGhcRTSWays),
+ ("Leading underscore", cLeadingUnderscore),
+ ("Debug on", show debugIsOn),
+ ("LibDir", topDir dflags),
+ ("Global Package DB", systemPackageConfig dflags),
+ ("Gcc Linker flags", show cGccLinkerOpts),
+ ("Ld Linker flags", show cLdLinkerOpts)
+ ]
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d0a8a862a46d3b4f1dfdd31d1df6b0d162199f9f..1c7a389f3548e3ca5387d058e6f779df1010ffc7 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -41,6 +41,9 @@ import StaticFlags ( opt_ErrorSpans )
import System.Exit ( ExitCode(..), exitWith )
import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
import System.IO
-- -----------------------------------------------------------------------------
@@ -67,7 +70,8 @@ mkLocMessage locn msg
-- would look strange. Better to say explicitly "<no location info>".
printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+ printErrs (mkLocMessage span msg) defaultErrStyle
-- -----------------------------------------------------------------------------
@@ -207,19 +211,26 @@ mkDumpDoc hdr doc
-- otherwise emit to stdout.
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
- = do let mFile = chooseDumpFile dflags dflag
- case mFile of
- -- write the dump to a file
- -- don't add the header in this case, we can see what kind
- -- of dump it is from the filename.
- Just fileName
- -> do handle <- openFile fileName AppendMode
- hPrintDump handle doc
- hClose handle
-
- -- write the dump to stdout
- Nothing
- -> do printDump (mkDumpDoc hdr doc)
+ = do let mFile = chooseDumpFile dflags dflag
+ case mFile of
+ -- write the dump to a file
+ -- don't add the header in this case, we can see what kind
+ -- of dump it is from the filename.
+ Just fileName
+ -> do
+ let gdref = generatedDumps dflags
+ gd <- readIORef gdref
+ let append = Set.member fileName gd
+ mode = if append then AppendMode else WriteMode
+ when (not append) $
+ writeIORef gdref (Set.insert fileName gd)
+ handle <- openFile fileName mode
+ hPrintDump handle doc
+ hClose handle
+
+ -- write the dump to stdout
+ Nothing
+ -> printDump (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ca2e14cee2ecc7930efb3023c2ee6f3d5d6048f9..0ecc09b9d78aac4af555c333f515932868472447 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -171,7 +171,7 @@ module GHC (
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprForAll, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
-- ** Entities
TyThing(..),
@@ -256,7 +256,6 @@ import Type
import Coercion ( synTyConResKind )
import TcType hiding( typeKind )
import Id
-import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
@@ -388,7 +387,7 @@ runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
-> Ghc a -- ^ The action to perform.
-> IO a
runGhc mb_top_dir ghc = do
- ref <- newIORef undefined
+ ref <- newIORef (panic "empty session")
let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
@@ -406,7 +405,7 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
-> GhcT m a -- ^ The action to perform.
-> m a
runGhcT mb_top_dir ghct = do
- ref <- liftIO $ newIORef undefined
+ ref <- liftIO $ newIORef (panic "empty session")
let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
@@ -431,8 +430,8 @@ initGhcMonad mb_top_dir = do
liftIO $ StaticFlags.initStaticOpts
- dflags0 <- liftIO $ initDynFlags defaultDynFlags
- dflags <- liftIO $ initSysTools mb_top_dir dflags0
+ mySettings <- liftIO $ initSysTools mb_top_dir
+ dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
env <- liftIO $ newHscEnv dflags
setSession env
@@ -934,6 +933,10 @@ getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
#ifdef GHCI
getPackageModuleInfo hsc_env mdl = do
mb_avails <- hscGetModuleExports hsc_env mdl
+ -- This is the only use of hscGetModuleExports. Perhaps we could use
+ -- hscRnImportDecls instead, but that does a lot more than we need
+ -- (building instance environment, checking family instance consistency
+ -- etc.).
case mb_avails of
Nothing -> return Nothing
Just avails -> do
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0d4143560f64acff0026cf1a19de400113a72fa5..ab658942ac5e708c51b35c6afa7b9a7095e09201 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
let dflags = hsc_dflags hsc_env
- -- case we bypass the preprocessing stage?
- let
- local_opts = getOptions dflags buf src_fn
- --
+ let local_opts = getOptions dflags buf src_fn
+
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
- let
- needs_preprocessing
+ 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
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 711259c9baf3ffd0d05249be3f08cc3e5c7fcda1..4c72f144c28daa6843590445d8c2f4c53222e09a 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -15,11 +15,11 @@ module GhcMonad (
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
- Session(..), withSession, modifySession, withTempSession,
+ Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings, printException, printExceptionAndWarnings,
- WarnErrLogger, defaultWarnErrLogger
+ WarnErrLogger, defaultWarnErrLogger
) where
import MonadUtils
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 70ddd6adb8e02ca27aaf58c31633336118cb48f9..6a5552f5dfb726c2367142faa5f47973f9b6b818 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -1132,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it)
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
- Just (L _ (ExprStmt expr _ _)) ->
- ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
- _ ->
- liftIO $ throwIO $ mkSrcErr $ unitBag $
- mkPlainErrMsg noSrcSpan
- (text "not an expression:" <+> quotes (text expr))
+ Just (L _ (ExprStmt expr _ _ _)) ->
+ ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+ _ ->
+ liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+ (text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index b96eb56b8c2e69b85446241c36d5ad6c5d4d7518..d90262633c86732e1b81b8d4f2c8c1b272f1fa73 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("InstType ", inst_type_ds),
("InstData ", inst_data_ds),
("TypeSigs ", bind_tys),
+ ("GenericSigs ", generic_sigs),
("ValBinds ", val_bind_ds),
("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines),
@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
- (fixity_sigs, bind_tys, bind_specs, bind_inlines)
+ (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
= count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
count_bind (FunBind {}) = (0,1)
count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
- count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+ count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
- sig_info (FixSig _) = (1,0,0,0)
- sig_info (TypeSig _ _) = (0,1,0,0)
- sig_info (SpecSig _ _ _) = (0,0,1,0)
- sig_info (InlineSig _ _) = (0,0,0,1)
- sig_info _ = (0,0,0,0)
+ sig_info (FixSig _) = (1,0,0,0,0)
+ sig_info (TypeSig _ _) = (0,1,0,0,0)
+ sig_info (SpecSig _ _ _) = (0,0,1,0,0)
+ sig_info (InlineSig _ _) = (0,0,0,1,0)
+ sig_info (GenericSig _ _) = (0,0,0,0,1)
+ sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {})
= case count_sigs (map unLoc (tcdSigs decl)) of
- (_,classops,_,_) ->
+ (_,classops,_,_,_) ->
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
- (_,_,ss,is) ->
+ (_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
(tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
@@ -157,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
- add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
addpr (x,y) = x+y
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
- add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
\end{code}
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e59c2239a7460918ea3c1becc4e7dad456eafd4e..77e69fdd38e7c5319ccd56281f9f755d5143d59a 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -54,13 +54,13 @@ module HscTypes (
-- * TyThings and type environments
TyThing(..),
- tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
- implicitTyThings, isImplicitTyThing,
+ tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
+ implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
- typeEnvDataCons,
+ typeEnvDataCons, typeEnvCoAxioms,
-- * MonadThings
MonadThings(..),
@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a 'ModIface' and
--- 'ModDetails' are extracted and the ModGuts is dicarded.
+-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
@@ -863,37 +863,47 @@ emptyModIface mod
%************************************************************************
\begin{code}
--- | Interactive context, recording information relevant to GHCi
+-- | Interactive context, recording information about the state of the
+-- context in which statements are executed in a GHC session.
+--
data InteractiveContext
= InteractiveContext {
- ic_toplev_scope :: [Module] -- ^ The context includes the "top-level" scope of
- -- these modules
-
- , ic_exports :: [(Module, Maybe (ImportDecl RdrName))] -- ^ The context includes just the exported parts of these
- -- modules
-
- , ic_rn_gbl_env :: GlobalRdrEnv -- ^ The contexts' cached 'GlobalRdrEnv', built from
- -- 'ic_toplev_scope' and 'ic_exports'
-
- , ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user.
- -- Later Ids shadow earlier ones with the same OccName
- -- Expressions are typed with these Ids in the envt
- -- For runtime-debugging, these Ids may have free
- -- TcTyVars of RuntimUnkSkol flavour, but no free TyVars
- -- (because the typechecker doesn't expect that)
+ -- These two fields are only stored here so that the client
+ -- can retrieve them with GHC.getContext. GHC itself doesn't
+ -- use them, but it does reset them to empty sometimes (such
+ -- as before a GHC.load). The context is set with GHC.setContext.
+ ic_toplev_scope :: [Module],
+ -- ^ The context includes the "top-level" scope of
+ -- these modules
+ ic_imports :: [ImportDecl RdrName],
+ -- ^ The context is extended with these import declarations
+
+ ic_rn_gbl_env :: GlobalRdrEnv,
+ -- ^ The contexts' cached 'GlobalRdrEnv', built by
+ -- 'InteractiveEval.setContext'
+
+ ic_tmp_ids :: [Id],
+ -- ^ Names bound during interaction with the user. Later
+ -- Ids shadow earlier ones with the same OccName
+ -- Expressions are typed with these Ids in the envt For
+ -- runtime-debugging, these Ids may have free TcTyVars of
+ -- RuntimUnkSkol flavour, but no free TyVars (because the
+ -- typechecker doesn't expect that)
#ifdef GHCI
- , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
+ ic_resume :: [Resume],
+ -- ^ The stack of breakpoint contexts
#endif
- , ic_cwd :: Maybe FilePath -- virtual CWD of the program
+ ic_cwd :: Maybe FilePath
+ -- virtual CWD of the program
}
emptyInteractiveContext :: InteractiveContext
emptyInteractiveContext
= InteractiveContext { ic_toplev_scope = [],
- ic_exports = [],
+ ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tmp_ids = []
#ifdef GHCI
@@ -1027,19 +1037,18 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
implicitTyThings :: TyThing -> [TyThing]
-
--- For data and newtype declarations:
-implicitTyThings (ATyCon tc)
- = -- fields (names of selectors)
- -- (possibly) implicit coercion and family coercion
- -- depending on whether it's a newtype or a family instance or both
- implicitCoTyCon tc ++
- -- for each data constructor in order,
- -- the contructor, worker, and (possibly) wrapper
- concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-
-implicitTyThings (AClass cl)
- = -- dictionary datatype:
+implicitTyThings (AnId _) = []
+implicitTyThings (ACoAxiom _cc) = []
+implicitTyThings (ATyCon tc) = implicitTyConThings tc
+implicitTyThings (AClass cl) = implicitClassThings cl
+implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
+ -- For data cons add the worker and (possibly) wrapper
+
+implicitClassThings :: Class -> [TyThing]
+implicitClassThings cl
+ = -- Does not include default methods, because those Ids may have
+ -- their own pragmas, unfoldings etc, not derived from the Class object
+ -- Dictionary datatype:
-- [extras_plus:]
-- type constructor
-- [recursive call:]
@@ -1055,11 +1064,16 @@ implicitTyThings (AClass cl)
-- superclass and operation selectors
map AnId (classAllSelIds cl)
-implicitTyThings (ADataCon dc) =
- -- For data cons add the worker and (possibly) wrapper
- map AnId (dataConImplicitIds dc)
+implicitTyConThings :: TyCon -> [TyThing]
+implicitTyConThings tc
+ = -- fields (names of selectors)
+ -- (possibly) implicit coercion and family coercion
+ -- depending on whether it's a newtype or a family instance or both
+ implicitCoTyCon tc ++
+ -- for each data constructor in order,
+ -- the contructor, worker, and (possibly) wrapper
+ concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-implicitTyThings (AnId _) = []
-- add a thing and recursive call
extras_plus :: TyThing -> [TyThing]
@@ -1069,10 +1083,10 @@ extras_plus thing = thing : implicitTyThings thing
-- add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
- = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not
- newTyConCo_maybe tc,
+ = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
+ newTyConCo_maybe tc,
-- Just if family instance, Nothing if not
- tyConFamilyCoercion_maybe tc]
+ tyConFamilyCoercion_maybe tc]
-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
@@ -1082,10 +1096,11 @@ implicitCoTyCon tc
-- of some other declaration, or it is generated implicitly by some
-- other declaration.
isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon _) = True
-isImplicitTyThing (AnId id) = isImplicitId id
-isImplicitTyThing (AClass _) = False
-isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AnId id) = isImplicitId id
+isImplicitTyThing (AClass {}) = False
+isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ACoAxiom {}) = True
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
@@ -1107,6 +1122,7 @@ emptyTypeEnv :: TypeEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
@@ -1115,6 +1131,7 @@ emptyTypeEnv = emptyNameEnv
typeEnvElts env = nameEnvElts env
typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
typeEnvIds env = [id | AnId id <- typeEnvElts env]
typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
@@ -1170,6 +1187,11 @@ tyThingTyCon :: TyThing -> TyCon
tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
+-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
+tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom (ACoAxiom ax) = ax
+tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
+
-- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
tyThingClass :: TyThing -> Class
tyThingClass (AClass cls) = cls
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index e0a30b46dca7bdeed2a1e3219e0f598e4af60d36..bb5fab6b9fe0bc51bef7f5ddfe79173458d59cac 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -40,10 +40,9 @@ module InteractiveEval (
import GhcMonad
import HscMain
-import HsSyn (ImportDecl)
+import HsSyn
import HscTypes
-import TcRnDriver
-import RnNames (gresFromAvails)
+import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
@@ -68,14 +67,13 @@ import ErrUtils
import SrcLoc
import BreakArray
import RtClosureInspect
-import BasicTypes
import Outputable
import FastString
import MonadUtils
import System.Directory
import Data.Dynamic
-import Data.List (find, partition)
+import Data.List (find)
import Control.Monad
import Foreign hiding (unsafePerformIO)
import Foreign.C
@@ -779,37 +777,27 @@ fromListBL bound l = BL (length l) bound l []
-- module. They always shadow anything in scope in the current context.
setContext :: GhcMonad m =>
[Module] -- ^ entire top level scope of these modules
- -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules
+ -> [ImportDecl RdrName] -- ^ these import declarations
-> m ()
-setContext toplev_mods other_mods = do
+setContext toplev_mods import_decls = do
hsc_env <- getSession
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
- (decls,mods) = partition (isJust . snd) other_mods -- time for tracing
- export_mods = map fst mods
- imprt_decls = map noLoc (catMaybes (map snd decls))
+ imprt_decls = map noLoc import_decls
--
- export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
let this_mod | null toplev_mods = pRELUDE
| otherwise = head toplev_mods
liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
+
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
- let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
+
+ let all_env = foldr plusGlobalRdrEnv import_env toplev_envs
modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = other_mods,
- ic_rn_gbl_env = all_env }}
-
--- Make a GlobalRdrEnv based on the exports of the modules only.
-mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
-mkExportEnv hsc_env mods
- = do { stuff <- mapM (getModuleExports hsc_env) mods
- ; let (_msgs, mb_name_sets) = unzip stuff
- envs = [ availsToGlobalRdrEnv (moduleName mod) avails
- | (Just avails, mod) <- zip mb_name_sets mods ]
- ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
+ ic_imports = import_decls,
+ ic_rn_gbl_env = all_env }}
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
@@ -837,9 +825,9 @@ mkTopLevEnv hpt modl
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
-- of modules from which we take just the exports respectively.
-getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))])
+getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName])
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic)
+ return (ic_toplev_scope ic, ic_imports ic)
-- | Returns @True@ if the specified module is interpreted, and hence has
-- its full top-level scope available.
@@ -949,15 +937,9 @@ compileExpr expr = withSession $ \hsc_env -> do
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
- (full,exports) <- getContext
- setContext full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
- setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
(_:[], v:[]) -> return v
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 5e265e85994d7ca2e63c07a81f3d3708aef09df0..860464e974b7452c330462a89afee224bac9d769 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -36,7 +36,7 @@ where
#include "HsVersions.h"
import PackageConfig
-import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) )
+import DynFlags
import StaticFlags
import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
@@ -56,7 +56,8 @@ import ErrUtils ( debugTraceMsg, putMsg, Message )
import Exception
import System.Directory
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.List as List
import Data.Map (Map)
@@ -246,7 +247,8 @@ readPackageConfig dflags conf_file = do
let
top_dir = topDir dflags
- pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+ pkgroot = takeDirectory conf_file
+ pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
pkg_configs2 = maybeHidePackages dflags pkg_configs1
--
return pkg_configs2
@@ -258,27 +260,52 @@ maybeHidePackages dflags pkgs
where
hide pkg = pkg{ exposed = False }
-mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$topdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ importDirs = munge_paths (importDirs p),
- includeDirs = munge_paths (includeDirs p),
- libraryDirs = munge_paths (libraryDirs p),
- frameworkDirs = munge_paths (frameworkDirs p),
- haddockInterfaces = munge_paths (haddockInterfaces p),
- haddockHTMLs = munge_paths (haddockHTMLs p)
- }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- stripPrefix "$topdir" p = top_dir ++ p'
- | Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
+mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+ | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+ stripVarPrefix var (root:path')
+ | Just [sep] <- stripPrefix var root
+ , isPathSeparator sep
+ = Just (joinPath path')
+
+ stripVarPrefix _ _ = Nothing
-- -----------------------------------------------------------------------------
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index d859784fad746f86a03fcd25c05175128bdffbfb..6d5344df7457c533de48e871e54f093b7f1a5c15 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -23,8 +23,8 @@ import DataCon
import Id
import IdInfo
import TyCon
+import Coercion( pprCoAxiom )
import TcType
-import Var
import Name
import Outputable
import FastString
@@ -45,7 +45,7 @@ type ShowMe = Name -> Bool
----------------------------
-- | Pretty-prints a 'TyThing' with its defining location.
pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing
+pprTyThingLoc pefas tyThing
= showWithLoc loc (pprTyThing pefas tyThing)
where loc = pprNameLoc (GHC.getName tyThing)
@@ -57,10 +57,11 @@ ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
ppr_ty_thing pefas _ (AnId id) = pprId pefas id
ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon
ppr_ty_thing pefas show_me (ATyCon tyCon) = pprTyCon pefas show_me tyCon
+ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax
ppr_ty_thing pefas show_me (AClass cls) = pprClass pefas show_me cls
-- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then
+-- is a data constructor, record selector, or class method, then
-- the entity's parent declaration is pretty-printed with irrelevant
-- parts omitted.
pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
@@ -77,7 +78,7 @@ pprTyThingInContextLoc pefas tyThing
(pprTyThingInContext pefas tyThing)
pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p)
+-- (pprTyThingParent_maybe x) returns (Just p)
-- when pprTyThingInContext sould print a declaration for p
-- (albeit with some "..." in it) when asked to show x
pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
@@ -94,6 +95,7 @@ pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingHdr pefas (AnId id) = pprId pefas id
pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon
+pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax
pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
@@ -103,7 +105,7 @@ pprTyConHdr _ tyCon
| otherwise
= ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
- vars | GHC.isPrimTyCon tyCon ||
+ vars | GHC.isPrimTyCon tyCon ||
GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
| otherwise = GHC.tyConTyVars tyCon
@@ -116,7 +118,7 @@ pprTyConHdr _ tyCon
| otherwise = empty
opt_stupid -- The "stupid theta" part of the declaration
- | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon)
+ | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
| otherwise = empty -- Returns 'empty' if null theta
pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
@@ -125,14 +127,14 @@ pprDataConSig pefas dataCon
pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
pprClassHdr _ cls
- = ptext (sLit "class") <+>
- GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+ = ptext (sLit "class") <+>
+ GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
ppr_bndr cls <+>
hsep (map ppr tyVars) <+>
GHC.pprFundeps funDeps
where
(tyVars, funDeps) = GHC.classTvsFds cls
-
+
pprId :: PrintExplicitForalls -> Var -> SDoc
pprId pefas ident
= hang (ppr_bndr ident <+> dcolon)
@@ -147,7 +149,7 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
-- forall a. C a => forall b. Ord b => stuff
-- Then we want to display
-- (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty
+pprTypeForUser print_foralls ty
| print_foralls = ppr tidy_ty
| otherwise = ppr (mkPhiTy ctxt ty')
where
@@ -160,7 +162,7 @@ pprTyCon pefas show_me tyCon
= if GHC.isFamilyTyCon tyCon
then pprTyConHdr pefas tyCon <+> dcolon <+>
pprTypeForUser pefas (GHC.synTyConResKind tyCon)
- else
+ else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
| otherwise
@@ -168,7 +170,7 @@ pprTyCon pefas show_me tyCon
pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
pprAlgTyCon pefas show_me tyCon
- | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
+ | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
nest 2 (vcat (ppr_trim show_con datacons))
| otherwise = hang (pprTyConHdr pefas tyCon)
2 (add_bars (ppr_trim show_con datacons))
@@ -184,8 +186,8 @@ pprAlgTyCon pefas show_me tyCon
pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
pprDataConDecl pefas show_me gadt_style dataCon
| not gadt_style = ppr_fields tys_w_strs
- | otherwise = ppr_bndr dataCon <+> dcolon <+>
- sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
+ | otherwise = ppr_bndr dataCon <+> dcolon <+>
+ sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
-- Printing out the dataCon as a type signature, in GADT style
where
(forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
@@ -214,15 +216,15 @@ pprDataConDecl pefas show_me gadt_style dataCon
| null labels
= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
| otherwise
- = ppr_bndr dataCon <+>
- braces (sep (punctuate comma (ppr_trim maybe_show_label
+ = ppr_bndr dataCon <+>
+ braces (sep (punctuate comma (ppr_trim maybe_show_label
(zip labels fields))))
pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
pprClass pefas show_me cls
| null methods
= pprClassHdr pefas cls
- | otherwise
+ | otherwise
= hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
2 (vcat (ppr_trim show_meth methods))
where
@@ -237,7 +239,7 @@ pprClassMethod pefas id
-- Here's the magic incantation to strip off the dictionary
-- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
--
- -- It's important to tidy it *before* splitting it up, so that if
+ -- It's important to tidy it *before* splitting it up, so that if
-- we have class C a b where
-- op :: forall a. a -> b
-- then the inner forall on op gets renamed to a1, and we print
@@ -268,7 +270,7 @@ ppr_bndr :: GHC.NamedThing a => a -> SDoc
ppr_bndr a = GHC.pprParenSymName a
showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc
+showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
-- The tab tries to make them line up a bit
where
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index 54f0a921159cc5f796dc9858aa822d3f8211dd3a..5767a52552997e6a835f205116ed03d8dd8c56c9 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -210,7 +210,6 @@ unregFlags :: [Located String]
unregFlags = map (mkGeneralLocated "in unregFlags")
[ "-optc-DNO_REGS"
, "-optc-DUSE_MINIINTERPRETER"
- , "-fno-asm-mangling"
, "-funregisterised" ]
-----------------------------------------------------------------------------
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 049b61fedb6e0fe7ce3c09daf1de7b1c8cd7ba84..f6d0af2665e2d36209eb657d3554a49b5c6d99d9 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -167,7 +167,7 @@ try_read sw str
= case reads str of
((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses
[] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
- -- ToDo: hack alert. We should really parse the arugments
+ -- ToDo: hack alert. We should really parse the arguments
-- and announce errors in a more civilised way.
@@ -192,16 +192,12 @@ opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci")
-- debugging options
-- | Suppress all that is suppressable in core dumps.
+-- Except for uniques, as some simplifier phases introduce new varibles that
+-- have otherwise identical names.
opt_SuppressAll :: Bool
opt_SuppressAll
= lookUp (fsLit "-dsuppress-all")
--- | Suppress unique ids on variables.
-opt_SuppressUniques :: Bool
-opt_SuppressUniques
- = lookUp (fsLit "-dsuppress-all")
- || lookUp (fsLit "-dsuppress-uniques")
-
-- | Suppress all coercions, them replacing with '...'
opt_SuppressCoercions :: Bool
opt_SuppressCoercions
@@ -232,10 +228,16 @@ opt_SuppressTypeSignatures
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-type-signatures")
+-- | Suppress unique ids on variables.
+-- Except for uniques, as some simplifier phases introduce new variables that
+-- have otherwise identical names.
+opt_SuppressUniques :: Bool
+opt_SuppressUniques
+ = lookUp (fsLit "-dsuppress-uniques")
-- | Display case expressions with a single alternative as strict let bindings
opt_PprCaseAsLet :: Bool
-opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
+opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
-- | Set the maximum width of the dumps
-- If GHC's command line options are bad then the options parser uses the
@@ -330,16 +332,16 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int
opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
opt_UF_KeenessFactor :: Float
-opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
-opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int)
-opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int)
+opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int)
+opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int)
+opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int)
-opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (3::Int)
+opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int)
-- Be fairly keen to inline a fuction if that means
-- we'll be able to pick the right method from a dictionary
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
-opt_UF_DearOp = ( 4 :: Int)
+opt_UF_DearOp = ( 40 :: Int)
-- Related to linking
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 5c64a34650c479b54edd47eb1ac1712439456633..9c086cc80bf3e761799f01fb93927147446fae61 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -26,7 +26,6 @@ module SysTools (
touch, -- String -> String -> IO ()
copy,
copyWithHeader,
- getExtraViaCOpts,
-- Temporary-file management
setTmpDir,
@@ -47,6 +46,7 @@ import ErrUtils
import Panic
import Util
import DynFlags
+import StaticFlags
import Exception
import Data.IORef
@@ -148,25 +148,47 @@ stuff.
\begin{code}
initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
-
- -> DynFlags
- -> IO DynFlags -- Set all the mutable variables above, holding
+ -> IO Settings -- Set all the mutable variables above, holding
-- (a) the system programs
-- (b) the package-config file
-- (c) the GHC usage message
-
-
-initSysTools mbMinusB dflags0
+initSysTools mbMinusB
= do { top_dir <- findTopDir mbMinusB
-- see [Note topdir]
-- NB: top_dir is assumed to be in standard Unix
-- format, '/' separated
- ; let installed :: FilePath -> FilePath
+ ; let settingsFile = top_dir </> "settings"
+ installed :: FilePath -> FilePath
installed file = top_dir </> file
installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
installed_perl_bin file = top_dir </> ".." </> "perl" </> file
+ ; settingsStr <- readFile settingsFile
+ ; mySettings <- case maybeReadFuzzy settingsStr of
+ Just s ->
+ return s
+ Nothing ->
+ pgmError ("Can't parse " ++ show settingsFile)
+ ; let getSetting key = case lookup key mySettings of
+ Just xs ->
+ return xs
+ Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+ ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
+ -- On Windows, mingw is distributed with GHC,
+ -- so we look in TopDir/../mingw/bin
+ -- It would perhaps be nice to be able to override this
+ -- with the settings file, but it would be a little fiddly
+ -- to make that possible, so for now you can't.
+ ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc"
+ else getSetting "C compiler command"
+ ; gcc_args_str <- if isWindowsHost then return []
+ else getSetting "C compiler flags"
+ ; let gcc_args = map Option (words gcc_args_str)
+ ; perl_path <- if isWindowsHost
+ then return $ installed_perl_bin "perl"
+ else getSetting "perl command"
+
; let pkgconfig_path = installed "package.conf.d"
ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
@@ -181,17 +203,8 @@ initSysTools mbMinusB dflags0
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
@@ -214,37 +227,57 @@ initSysTools mbMinusB dflags0
-- cpp is derived from gcc on all platforms
-- HACK, see setPgmP below. We keep 'words' here to remember to fix
-- Config.hs one day.
- ; let cpp_path = (gcc_prog,
- (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+ ; let cpp_prog = gcc_prog
+ cpp_args = Option "-E"
+ : map Option (words cRAWCPP_FLAGS)
+ ++ gcc_args
-- Other things being equal, as and ld are simply gcc
; let as_prog = gcc_prog
+ as_args = gcc_args
ld_prog = gcc_prog
+ ld_args = gcc_args
- -- figure out llvm location. (TODO: Acutally implement).
+ -- We just assume on command line
; let lc_prog = "llc"
lo_prog = "opt"
- ; return dflags1{
- ghcUsagePath = ghc_usage_msg_path,
- ghciUsagePath = ghci_usage_msg_path,
- topDir = top_dir,
- systemPackageConfig = pkgconfig_path,
- pgm_L = unlit_path,
- pgm_P = cpp_path,
- pgm_F = "",
- pgm_c = (gcc_prog,[]),
- pgm_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}
@@ -448,11 +481,6 @@ copyWithHeader dflags purpose maybe_header from to = do
hClose hout
hClose hin
-getExtraViaCOpts :: DynFlags -> IO [String]
-getExtraViaCOpts dflags = do
- f <- readFile (topDir dflags </> "extra-gcc-opts")
- return (words f)
-
-- | read the contents of the named section in an ELF object as a
-- String.
readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
@@ -527,8 +555,9 @@ newTempName dflags extn
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
+getTempDir dflags
= do let ref = dirsToClean dflags
+ tmp_dir = tmpDir dflags
mapping <- readIORef ref
case Map.lookup tmp_dir mapping of
Nothing ->
@@ -759,20 +788,16 @@ data BuildMessage
| EOF
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+-- trace the command (at two levels of verbosity)
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
; showPass dflags phase_name
; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
- -- Test for -n flag
- ; unless (dopt Opt_DryRun dflags) $ do {
-
-- And run it!
; action `catchIO` handle_exn verb
- }}
+ }
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
@@ -793,14 +818,15 @@ getBaseDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
-- return the path $(stuff)/lib.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
- buf <- mallocArray len
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then free buf >> return Nothing
- else do s <- peekCString buf
- free buf
- return (Just (rootDir s))
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
rootDir s = case splitFileName $ normalise s of
(d, ghc_exe)
| lower ghc_exe `elem` ["ghc.exe",
@@ -815,8 +841,8 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
where fail = panic ("can't decompose ghc.exe path: " ++ show s)
lower = map toLower
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getBaseDir = return Nothing
#endif
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index f23280bc1991dba7aeb5a39b16d5bdb95a96fe45..b4296cbb072c6f8c549c5462f9a76b47aea681a2 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1156,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts
cafRefs p (Note _n e) = cafRefs p e
cafRefs p (Cast e _co) = cafRefs p e
cafRefs _ (Type _) = fastBool False
+cafRefs _ (Coercion _) = fastBool False
cafRefss :: VarEnv Id -> [Expr a] -> FastBool
cafRefss _ [] = fastBool False
diff --git a/compiler/nativeGen/Alpha/CodeGen.hs b/compiler/nativeGen/Alpha/CodeGen.hs
deleted file mode 100644
index 4ce774f14f635f48c6e742b2fa3eaa478a2053b9..0000000000000000000000000000000000000000
--- a/compiler/nativeGen/Alpha/CodeGen.hs
+++ /dev/null
@@ -1,789 +0,0 @@
-module Alpha.CodeGen ()
-
-where
-
-{-
-
-getRegister :: CmmExpr -> NatM Register
-
-#if !x86_64_TARGET_ARCH
- -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
- -- register, it can only be used for rip-relative addressing.
-getRegister (CmmReg (CmmGlobal PicBaseReg))
- = do
- reg <- getPicBaseNat wordSize
- return (Fixed wordSize reg nilOL)
-#endif
-
-getRegister (CmmReg reg)
- = return (Fixed (cmmTypeSize (cmmRegType reg))
- (getRegisterReg reg) nilOL)
-
-getRegister tree@(CmmRegOff _ _)
- = getRegister (mangleIndexTree tree)
-
-
-#if WORD_SIZE_IN_BITS==32
- -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
- -- TO_W_(x), TO_W_(x >> 32)
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32)
- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32)
- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 rlo code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 rlo code
-
-#endif
-
--- end of machine-"independent" bit; here we go on the rest...
-
-
-getRegister (StDouble d)
- = getBlockIdNat `thenNat` \ lbl ->
- getNewRegNat PtrRep `thenNat` \ tmp ->
- let code dst = mkSeqInstrs [
- LDATA RoDataSegment lbl [
- DATA TF [ImmLab (rational d)]
- ],
- LDA tmp (AddrImm (ImmCLbl lbl)),
- LD TF dst (AddrReg tmp)]
- in
- return (Any FF64 code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEG Q False) x
-
- NotOp -> trivialUCode NOT x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
- DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
-
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP pr x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP pr x
-
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
- other_op -> getRegister (StCall fn CCallConv FF64 [x])
- where
- fn = case other_op of
- FloatExpOp -> fsLit "exp"
- FloatLogOp -> fsLit "log"
- FloatSqrtOp -> fsLit "sqrt"
- FloatSinOp -> fsLit "sin"
- FloatCosOp -> fsLit "cos"
- FloatTanOp -> fsLit "tan"
- FloatAsinOp -> fsLit "asin"
- FloatAcosOp -> fsLit "acos"
- FloatAtanOp -> fsLit "atan"
- FloatSinhOp -> fsLit "sinh"
- FloatCoshOp -> fsLit "cosh"
- FloatTanhOp -> fsLit "tanh"
- DoubleExpOp -> fsLit "exp"
- DoubleLogOp -> fsLit "log"
- DoubleSqrtOp -> fsLit "sqrt"
- DoubleSinOp -> fsLit "sin"
- DoubleCosOp -> fsLit "cos"
- DoubleTanOp -> fsLit "tan"
- DoubleAsinOp -> fsLit "asin"
- DoubleAcosOp -> fsLit "acos"
- DoubleAtanOp -> fsLit "atan"
- DoubleSinhOp -> fsLit "sinh"
- DoubleCoshOp -> fsLit "cosh"
- DoubleTanhOp -> fsLit "tanh"
- where
- pr = panic "MachCode.getRegister: no primrep needed for Alpha"
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> trivialCode (CMP LTT) y x
- CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQQ) x y
- CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LTT) x y
- CharLeOp -> trivialCode (CMP LE) x y
-
- IntGtOp -> trivialCode (CMP LTT) y x
- IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQQ) x y
- IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LTT) x y
- IntLeOp -> trivialCode (CMP LE) x y
-
- WordGtOp -> trivialCode (CMP ULT) y x
- WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQQ) x y
- WordNeOp -> int_NE_code x y
- WordLtOp -> trivialCode (CMP ULT) x y
- WordLeOp -> trivialCode (CMP ULE) x y
-
- AddrGtOp -> trivialCode (CMP ULT) y x
- AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQQ) x y
- AddrNeOp -> int_NE_code x y
- AddrLtOp -> trivialCode (CMP ULT) x y
- AddrLeOp -> trivialCode (CMP ULE) x y
-
- FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
- FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
- DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- IntAddOp -> trivialCode (ADD Q False) x y
- IntSubOp -> trivialCode (SUB Q False) x y
- IntMulOp -> trivialCode (MUL Q False) x y
- IntQuotOp -> trivialCode (DIV Q False) x y
- IntRemOp -> trivialCode (REM Q False) x y
-
- WordAddOp -> trivialCode (ADD Q False) x y
- WordSubOp -> trivialCode (SUB Q False) x y
- WordMulOp -> trivialCode (MUL Q False) x y
- WordQuotOp -> trivialCode (DIV Q True) x y
- WordRemOp -> trivialCode (REM Q True) x y
-
- FloatAddOp -> trivialFCode W32 (FADD TF) x y
- FloatSubOp -> trivialFCode W32 (FSUB TF) x y
- FloatMulOp -> trivialFCode W32 (FMUL TF) x y
- FloatDivOp -> trivialFCode W32 (FDIV TF) x y
-
- DoubleAddOp -> trivialFCode W64 (FADD TF) x y
- DoubleSubOp -> trivialFCode W64 (FSUB TF) x y
- DoubleMulOp -> trivialFCode W64 (FMUL TF) x y
- DoubleDivOp -> trivialFCode W64 (FDIV TF) x y
-
- AddrAddOp -> trivialCode (ADD Q False) x y
- AddrSubOp -> trivialCode (SUB Q False) x y
- AddrRemOp -> trivialCode (REM Q True) x y
-
- AndOp -> trivialCode AND x y
- OrOp -> trivialCode OR x y
- XorOp -> trivialCode XOR x y
- SllOp -> trivialCode SLL x y
- SrlOp -> trivialCode SRL x y
-
- ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
- ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
- ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
-
- FloatPowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
- DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
- where
- {- ------------------------------------------------------------
- Some bizarre special code for getting condition codes into
- registers. Integer non-equality is a test for equality
- followed by an XOR with 1. (Integer comparisons always set
- the result register to 0 or 1.) Floating point comparisons of
- any kind leave the result in a floating point register, so we
- need to wrangle an integer register out of things.
- -}
- int_NE_code :: StixTree -> StixTree -> NatM Register
-
- int_NE_code x y
- = trivialCode (CMP EQQ) x y `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
- in
- return (Any IntRep code__2)
-
- {- ------------------------------------------------------------
- Comments for int_NE_code also apply to cmpF_code
- -}
- cmpF_code
- :: (Reg -> Reg -> Reg -> Instr)
- -> Cond
- -> StixTree -> StixTree
- -> NatM Register
-
- cmpF_code instr cond x y
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- getBlockIdNat `thenNat` \ lbl ->
- let
- code = registerCode register tmp
- result = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- OR zeroh (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zeroh (RIReg zeroh) dst,
- NEWBLOCK lbl]
- in
- return (Any IntRep code__2)
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
- ------------------------------------------------------------
-
-getRegister (CmmLoad pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code . mkSeqInstr (LD size dst src)
- in
- return (Any pk code__2)
-
-getRegister (StInt i)
- | fits8Bits i
- = let
- code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
- in
- return (Any IntRep code)
- | otherwise
- = let
- code dst = mkSeqInstr (LDI Q dst src)
- in
- return (Any IntRep code)
- where
- src = ImmInt (fromInteger i)
-
-getRegister leaf
- | isJust imm
- = let
- code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
- in
- return (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-
-getAmode :: CmmExpr -> NatM Amode
-getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [x, StInt i])
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- return (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- return (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | isJust imm
- = return (Amode (AddrImm imm__2) id)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- return (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business. Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers. If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side. This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
-
-
-assignIntCode pk (CmmLoad dst _) src
- = getNewRegNat IntRep `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- return code__2
-
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
- else code
- in
- return code__2
-
-assignFltCode pk (CmmLoad dst _) src
- = getNewRegNat pk `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- return code__2
-
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (FMOV src__2 dst__2)
- else code
- in
- return code__2
-
-
--- -----------------------------------------------------------------------------
--- Generating an non-local jump
-
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-
-genJump (CmmLabel lbl)
- | isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
- where
- target = ImmCLbl lbl
-
-genJump tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNat PtrRep `thenNat` \ tmp ->
- let
- dst = registerName register pv
- code = registerCode register pv
- target = registerName register pv
- in
- if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
- else
- return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-
--- -----------------------------------------------------------------------------
--- Unconditional branches
-
-genBranch :: BlockId -> NatM InstrBlock
-
-genBranch = return . toOL . mkBranchInstr
-
-
--- -----------------------------------------------------------------------------
--- Conditional jumps
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions. We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
--}
-
-
-genCondJump
- :: BlockId -- the branch target
- -> CmmExpr -- the condition on which to branch
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-genCondJump id (StPrim op [x, StInt 0])
- = getRegister x `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnSeq code [BI (cmpOp op) value target]
- where
- cmpOp CharGtOp = GTT
- cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQQ
- cmpOp CharNeOp = NE
- cmpOp CharLtOp = LTT
- cmpOp CharLeOp = LE
- cmpOp IntGtOp = GTT
- cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQQ
- cmpOp IntNeOp = NE
- cmpOp IntLtOp = LTT
- cmpOp IntLeOp = LE
- cmpOp WordGtOp = NE
- cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQQ
- cmpOp WordNeOp = NE
- cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQQ
- cmpOp AddrGtOp = NE
- cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQQ
- cmpOp AddrNeOp = NE
- cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BF (cmpOp op) value target))
- where
- cmpOp FloatGtOp = GTT
- cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQQ
- cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LTT
- cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GTT
- cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQQ
- cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LTT
- cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
- | fltCmpOp op
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BF cond result target))
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
- fltCmpOp op = case op of
- FloatGtOp -> True
- FloatGeOp -> True
- FloatEqOp -> True
- FloatNeOp -> True
- FloatLtOp -> True
- FloatLeOp -> True
- DoubleGtOp -> True
- DoubleGeOp -> True
- DoubleEqOp -> True
- DoubleNeOp -> True
- DoubleLtOp -> True
- DoubleLeOp -> True
- _ -> False
- (instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQQ)
- FloatGeOp -> (FCMP TF LTT, EQQ)
- FloatEqOp -> (FCMP TF EQQ, NE)
- FloatNeOp -> (FCMP TF EQQ, EQQ)
- FloatLtOp -> (FCMP TF LTT, NE)
- FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQQ)
- DoubleGeOp -> (FCMP TF LTT, EQQ)
- DoubleEqOp -> (FCMP TF EQQ, NE)
- DoubleNeOp -> (FCMP TF EQQ, EQQ)
- DoubleLtOp -> (FCMP TF LTT, NE)
- DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op [x, y])
- = trivialCode instr x y `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BI cond result target))
- where
- (instr, cond) = case op of
- CharGtOp -> (CMP LE, EQQ)
- CharGeOp -> (CMP LTT, EQQ)
- CharEqOp -> (CMP EQQ, NE)
- CharNeOp -> (CMP EQQ, EQQ)
- CharLtOp -> (CMP LTT, NE)
- CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQQ)
- IntGeOp -> (CMP LTT, EQQ)
- IntEqOp -> (CMP EQQ, NE)
- IntNeOp -> (CMP EQQ, EQQ)
- IntLtOp -> (CMP LTT, NE)
- IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQQ)
- WordGeOp -> (CMP ULT, EQQ)
- WordEqOp -> (CMP EQQ, NE)
- WordNeOp -> (CMP EQQ, EQQ)
- WordLtOp -> (CMP ULT, NE)
- WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQQ)
- AddrGeOp -> (CMP ULT, EQQ)
- AddrEqOp -> (CMP EQQ, NE)
- AddrNeOp -> (CMP EQQ, EQQ)
- AddrLtOp -> (CMP ULT, NE)
- AddrLeOp -> (CMP ULE, NE)
-
--- -----------------------------------------------------------------------------
--- Generating C calls
-
--- Now the biggest nightmare---calls. Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations. Apart from that, the code is easy.
---
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genCCall
- :: CmmCallTarget -- function to call
- -> HintedCmmFormals -- where to put the result
- -> HintedCmmActuals -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-ccallResultRegs =
-
-genCCall fn cconv result_regs args
- = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenNat` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- code = asmSeqThen (map ($ []) argCode)
- in
- returnSeq code [
- LDA pv (AddrImm (ImmLab (ptext fn))),
- JSR ra (AddrReg pv) nRegs,
- LDGP gp (AddrReg ra)]
- where
- ------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The first 6 arguments go into the appropriate
- argument register (separate registers for integer and floating
- point arguments, but used in lock-step), and the remaining
- arguments are dumped to the stack, beginning at 0(sp). Our
- first argument is a pair of the list of remaining argument
- registers to be assigned for this call and the next stack
- offset to use for overflowing arguments. This way,
- @get_Arg@ can be applied to all of a call's arguments using
- @mapAccumLNat@.
- -}
- get_arg
- :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-
- -- We have to use up all of our argument registers first...
-
- get_arg ((iDst,fDst):dsts, offset) arg
- = getRegister arg `thenNat` \ register ->
- let
- reg = if isFloatType pk then fDst else iDst
- code = registerCode register reg
- src = registerName register reg
- pk = registerRep register
- in
- return (
- if isFloatType pk then
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (FMOV src fDst)
- else code)
- else
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR src (RIReg src) iDst)
- else code))
-
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-trivialCode instr x (StInt y)
- | fits8Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
- in
- return (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNat IntRep `thenNat` \ tmp1 ->
- getNewRegNat IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 []
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
- src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- return (Any IntRep code__2)
-
-------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
- in
- return (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNat FF64 `thenNat` \ tmp1 ->
- getNewRegNat FF64 `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst = asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (instr src1 src2 dst)
- in
- return (Any FF64 code__2)
-
-trivialUFCode _ instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
- in
- return (Any FF64 code__2)
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- ST Q src (spRel 0),
- LD TF dst (spRel 0),
- CVTxy Q TF dst dst]
- in
- return (Any FF64 code__2)
-
--------------
-coerceFP2Int x
- = getRegister x `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- CVTxy TF Q src tmp,
- ST TF tmp (spRel 0),
- LD Q dst (spRel 0)]
- in
- return (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--}
-
-
-
-
-
diff --git a/compiler/nativeGen/Alpha/Instr.hs b/compiler/nativeGen/Alpha/Instr.hs
deleted file mode 100644
index 990ea8bc1acc7acf407ea931e9b7dd922aac1180..0000000000000000000000000000000000000000
--- a/compiler/nativeGen/Alpha/Instr.hs
+++ /dev/null
@@ -1,142 +0,0 @@
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-module Alpha.Instr (
--- Cond(..),
--- Instr(..),
--- RI(..)
-)
-
-where
-
-{-
-import BlockId
-import Regs
-import Cmm
-import FastString
-import CLabel
-
-data Cond
- = ALWAYS -- For BI (same as BR)
- | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
- | GE -- For BI only
- | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
- | LE -- For CMP and BI
- | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
- | NE -- For BI only
- | NEVER -- For BI (null instruction)
- | ULE -- For CMP only
- | ULT -- For CMP only
- deriving Eq
-
-
--- -----------------------------------------------------------------------------
--- Machine's assembly language
-
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Register or immediate
-data RI
- = RIReg Reg
- | RIImm Imm
-
-data Instr
- -- comment pseudo-op
- = COMMENT FastString
-
- -- some static data spat out during code
- -- generation. Will be extracted before
- -- pretty-printing.
- | LDATA Section [CmmStatic]
-
- -- start a new basic block. Useful during
- -- codegen, removed later. Preceding
- -- instruction should be a jump, as per the
- -- invariants for a BasicBlock (see Cmm).
- | NEWBLOCK BlockId
-
- -- specify current stack offset for
- -- benefit of subsequent passes
- | DELTA Int
-
- -- | spill this reg to a stack slot
- | SPILL Reg Int
-
- -- | reload this reg from a stack slot
- | RELOAD Int Reg
-
- -- Loads and stores.
- | LD Size Reg AddrMode -- size, dst, src
- | LDA Reg AddrMode -- dst, src
- | LDAH Reg AddrMode -- dst, src
- | LDGP Reg AddrMode -- dst, src
- | LDI Size Reg Imm -- size, dst, src
- | ST Size Reg AddrMode -- size, src, dst
-
- -- Int Arithmetic.
- | CLR Reg -- dst
- | ABS Size RI Reg -- size, src, dst
- | NEG Size Bool RI Reg -- size, overflow, src, dst
- | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SADD Size Size Reg RI Reg -- size, scale, src, src, dst
- | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst
- | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst
- | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst
-
- -- Simple bit-twiddling.
- | NOT RI Reg
- | AND Reg RI Reg
- | ANDNOT Reg RI Reg
- | OR Reg RI Reg
- | ORNOT Reg RI Reg
- | XOR Reg RI Reg
- | XORNOT Reg RI Reg
- | SLL Reg RI Reg
- | SRL Reg RI Reg
- | SRA Reg RI Reg
-
- | ZAP Reg RI Reg
- | ZAPNOT Reg RI Reg
-
- | NOP
-
- -- Comparison
- | CMP Cond Reg RI Reg
-
- -- Float Arithmetic.
- | FCLR Reg
- | FABS Reg Reg
- | FNEG Size Reg Reg
- | FADD Size Reg Reg Reg
- | FDIV Size Reg Reg Reg
- | FMUL Size Reg Reg Reg
- | FSUB Size Reg Reg Reg
- | CVTxy Size Size Reg Reg
- | FCMP Size Cond Reg Reg Reg
- | FMOV Reg Reg
-
- -- Jumping around.
- | BI Cond Reg Imm
- | BF Cond Reg Imm
- | BR Imm
- | JMP Reg AddrMode Int
- | BSR Imm Int
- | JSR Reg AddrMode Int
-
- -- Alpha-specific pseudo-ops.
- | FUNBEGIN CLabel
- | FUNEND CLabel
-
-
--}
diff --git a/compiler/nativeGen/Alpha/Ppr.hs-old b/compiler/nativeGen/Alpha/Ppr.hs-old
deleted file mode 100644
index c14eef205db03852edc07a4b51a3cade7c8d83e9..0000000000000000000000000000000000000000
--- a/compiler/nativeGen/Alpha/Ppr.hs-old
+++ /dev/null
@@ -1,562 +0,0 @@
-
-module Alpha.Ppr (
-{-
- pprReg,
- pprSize,
- pprCond,
- pprAddr,
- pprSectionHeader,
- pprTypeAndSizeDecl,
- pprRI,
- pprRegRIReg,
- pprSizeRegRegReg
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-import BlockId
-import Cmm
-import Regs -- may differ per-platform
-import Instrs
-
-import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
- labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
-
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-import CLabel ( mkDeadStripPreventer )
-#endif
-
-import Panic ( panic )
-import Unique ( pprUnique )
-import Pretty
-import FastString
-import qualified Outputable
-import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
-
-import Data.Array.ST
-import Data.Word ( Word8 )
-import Control.Monad.ST
-import Data.Char ( chr, ord )
-import Data.Maybe ( isJust )
-
-
-
-pprReg :: Reg -> Doc
-pprReg r
- = case r of
- RealReg i -> ppr_reg_no i
- VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
- VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
- VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
- VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
- where
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i = ptext
- (case i of {
- 0 -> sLit "$0"; 1 -> sLit "$1";
- 2 -> sLit "$2"; 3 -> sLit "$3";
- 4 -> sLit "$4"; 5 -> sLit "$5";
- 6 -> sLit "$6"; 7 -> sLit "$7";
- 8 -> sLit "$8"; 9 -> sLit "$9";
- 10 -> sLit "$10"; 11 -> sLit "$11";
- 12 -> sLit "$12"; 13 -> sLit "$13";
- 14 -> sLit "$14"; 15 -> sLit "$15";
- 16 -> sLit "$16"; 17 -> sLit "$17";
- 18 -> sLit "$18"; 19 -> sLit "$19";
- 20 -> sLit "$20"; 21 -> sLit "$21";
- 22 -> sLit "$22"; 23 -> sLit "$23";
- 24 -> sLit "$24"; 25 -> sLit "$25";
- 26 -> sLit "$26"; 27 -> sLit "$27";
- 28 -> sLit "$28"; 29 -> sLit "$29";
- 30 -> sLit "$30"; 31 -> sLit "$31";
- 32 -> sLit "$f0"; 33 -> sLit "$f1";
- 34 -> sLit "$f2"; 35 -> sLit "$f3";
- 36 -> sLit "$f4"; 37 -> sLit "$f5";
- 38 -> sLit "$f6"; 39 -> sLit "$f7";
- 40 -> sLit "$f8"; 41 -> sLit "$f9";
- 42 -> sLit "$f10"; 43 -> sLit "$f11";
- 44 -> sLit "$f12"; 45 -> sLit "$f13";
- 46 -> sLit "$f14"; 47 -> sLit "$f15";
- 48 -> sLit "$f16"; 49 -> sLit "$f17";
- 50 -> sLit "$f18"; 51 -> sLit "$f19";
- 52 -> sLit "$f20"; 53 -> sLit "$f21";
- 54 -> sLit "$f22"; 55 -> sLit "$f23";
- 56 -> sLit "$f24"; 57 -> sLit "$f25";
- 58 -> sLit "$f26"; 59 -> sLit "$f27";
- 60 -> sLit "$f28"; 61 -> sLit "$f29";
- 62 -> sLit "$f30"; 63 -> sLit "$f31";
- _ -> sLit "very naughty alpha register"
- })
-
-
-pprSize :: Size -> Doc
-pprSize x = ptext (case x of
- B -> sLit "b"
- Bu -> sLit "bu"
--- W -> sLit "w" UNUSED
--- Wu -> sLit "wu" UNUSED
- L -> sLit "l"
- Q -> sLit "q"
--- FF -> sLit "f" UNUSED
--- DF -> sLit "d" UNUSED
--- GF -> sLit "g" UNUSED
--- SF -> sLit "s" UNUSED
- TF -> sLit "t"
-
-
-pprCond :: Cond -> Doc
-pprCond c
- = ptext (case c of
- EQQ -> sLit "eq"
- LTT -> sLit "lt"
- LE -> sLit "le"
- ULT -> sLit "ult"
- ULE -> sLit "ule"
- NE -> sLit "ne"
- GTT -> sLit "gt"
- GE -> sLit "ge")
-
-
-pprAddr :: AddrMode -> Doc
-pprAddr (AddrReg r) = parens (pprReg r)
-pprAddr (AddrImm i) = pprImm i
-pprAddr (AddrRegImm r1 i)
- = (<>) (pprImm i) (parens (pprReg r1))
-
-
-pprSectionHeader Text
- = ptext (sLit "\t.text\n\t.align 3")
-
-pprSectionHeader Data
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader ReadOnlyData
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader RelocatableReadOnlyData
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader UninitialisedData
- = ptext (sLit "\t.bss\n\t.align 3")
-
-pprSectionHeader ReadOnlyData16
- = ptext (sLit "\t.data\n\t.align 4")
-
-pprSectionHeader (OtherSection sec)
- = panic "PprMach.pprSectionHeader: unknown section"
-
-
-pprTypeAndSizeDecl :: CLabel -> Doc
-pprTypeAndSizeDecl lbl
- = empty
-
-
-
-pprInstr :: Instr -> Doc
-
-pprInstr (DELTA d)
- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-
-pprInstr (NEWBLOCK _)
- = panic "PprMach.pprInstr: NEWBLOCK"
-
-pprInstr (LDATA _ _)
- = panic "PprMach.pprInstr: LDATA"
-
-pprInstr (SPILL reg slot)
- = hcat [
- ptext (sLit "\tSPILL"),
- char '\t',
- pprReg reg,
- comma,
- ptext (sLit "SLOT") <> parens (int slot)]
-
-pprInstr (RELOAD slot reg)
- = hcat [
- ptext (sLit "\tRELOAD"),
- char '\t',
- ptext (sLit "SLOT") <> parens (int slot),
- comma,
- pprReg reg]
-
-pprInstr (LD size reg addr)
- = hcat [
- ptext (sLit "\tld"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDA reg addr)
- = hcat [
- ptext (sLit "\tlda\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDAH reg addr)
- = hcat [
- ptext (sLit "\tldah\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDGP reg addr)
- = hcat [
- ptext (sLit "\tldgp\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDI size reg imm)
- = hcat [
- ptext (sLit "\tldi"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprImm imm
- ]
-
-pprInstr (ST size reg addr)
- = hcat [
- ptext (sLit "\tst"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (CLR reg)
- = hcat [
- ptext (sLit "\tclr\t"),
- pprReg reg
- ]
-
-pprInstr (ABS size ri reg)
- = hcat [
- ptext (sLit "\tabs"),
- pprSize size,
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (NEG size ov ri reg)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (ADD size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tadd"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SADD size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "add"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SUB size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tsub"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SSUB size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "sub"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (MUL size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tmul"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (DIV size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\tdiv"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (REM size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\trem"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (NOT ri reg)
- = hcat [
- ptext (sLit "\tnot"),
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
-pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
-pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
-pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
-pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
-pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
-
-pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
-
-pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
-pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
-
-pprInstr (NOP) = ptext (sLit "\tnop")
-
-pprInstr (CMP cond reg1 ri reg2)
- = hcat [
- ptext (sLit "\tcmp"),
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCLR reg)
- = hcat [
- ptext (sLit "\tfclr\t"),
- pprReg reg
- ]
-
-pprInstr (FABS reg1 reg2)
- = hcat [
- ptext (sLit "\tfabs\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FNEG size reg1 reg2)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
-pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
-pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
-pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
-
-pprInstr (CVTxy size1 size2 reg1 reg2)
- = hcat [
- ptext (sLit "\tcvt"),
- pprSize size1,
- case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCMP size cond reg1 reg2 reg3)
- = hcat [
- ptext (sLit "\tcmp"),
- pprSize size,
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
-pprInstr (FMOV reg1 reg2)
- = hcat [
- ptext (sLit "\tfmov\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-
-pprInstr (BI NEVER reg lab) = empty
-
-pprInstr (BI cond reg lab)
- = hcat [
- ptext (sLit "\tb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BF cond reg lab)
- = hcat [
- ptext (sLit "\tfb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BR lab)
- = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
-
-pprInstr (JMP reg addr hint)
- = hcat [
- ptext (sLit "\tjmp\t"),
- pprReg reg,
- comma,
- pprAddr addr,
- comma,
- int hint
- ]
-
-pprInstr (BSR imm n)
- = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
-
-pprInstr (JSR reg addr n)
- = hcat [
- ptext (sLit "\tjsr\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (FUNBEGIN clab)
- = hcat [
- if (externallyVisibleCLabel clab) then
- hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
- else
- empty,
- ptext (sLit "\t.ent "),
- pp_lab,
- char '\n',
- pp_lab,
- pp_ldgp,
- pp_lab,
- pp_frame
- ]
- where
- pp_lab = pprCLabel_asm clab
-
- -- NEVER use commas within those string literals, cpp will ruin your day
- pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
- pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
- ptext (sLit "4240"), char ',',
- ptext (sLit "$26"), char ',',
- ptext (sLit "0\n\t.prologue 1") ]
-
-pprInstr (FUNEND clab)
- = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
-
-
-pprRI :: RI -> Doc
-
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
-pprRegRIReg name reg1 ri reg2
- = hcat [
- char '\t',
- ptext name,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
--}
-
-
-
diff --git a/compiler/nativeGen/Alpha/RegInfo.hs b/compiler/nativeGen/Alpha/RegInfo.hs
deleted file mode 100644
index 7fdde4daf69cb773d354bf80c7d098bd2e0ad647..0000000000000000000000000000000000000000
--- a/compiler/nativeGen/Alpha/RegInfo.hs
+++ /dev/null
@@ -1,218 +0,0 @@
-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
-module Alpha.RegInfo (
-{-
- RegUsage(..),
- noUsage,
- regUsage,
- patchRegs,
- jumpDests,
- isJumpish,
- patchJump,
- isRegRegMove,
-
- JumpDest, canShortcut, shortcutJump, shortcutStatic,
-
- maxSpillSlots,
- mkSpillInstr,
- mkLoadInstr,
- mkRegRegMoveInstr,
- mkBranchInstr
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-
-import BlockId
-import Cmm
-import CLabel
-import Instrs
-import Regs
-import Outputable
-import Constants ( rESERVED_C_STACK_BYTES )
-import FastBool
-
-data RegUsage = RU [Reg] [Reg]
-
-noUsage :: RegUsage
-noUsage = RU [] []
-
-regUsage :: Instr -> RegUsage
-
-regUsage instr = case instr of
- SPILL reg slot -> usage ([reg], [])
- RELOAD slot reg -> usage ([], [reg])
- LD B reg addr -> usage (regAddr addr, [reg, t9])
- LD Bu reg addr -> usage (regAddr addr, [reg, t9])
--- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
--- LD Wu reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
- LD sz reg addr -> usage (regAddr addr, [reg])
- LDA reg addr -> usage (regAddr addr, [reg])
- LDAH reg addr -> usage (regAddr addr, [reg])
- LDGP reg addr -> usage (regAddr addr, [reg])
- LDI sz reg imm -> usage ([], [reg])
- ST B reg addr -> usage (reg : regAddr addr, [t9, t10])
--- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED
- ST sz reg addr -> usage (reg : regAddr addr, [])
- CLR reg -> usage ([], [reg])
- ABS sz ri reg -> usage (regRI ri, [reg])
- NEG sz ov ri reg -> usage (regRI ri, [reg])
- ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- NOT ri reg -> usage (regRI ri, [reg])
- AND r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- OR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XOR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2])
- FCLR reg -> usage ([], [reg])
- FABS r1 r2 -> usage ([r1], [r2])
- FNEG sz r1 r2 -> usage ([r1], [r2])
- FADD sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3])
- CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2])
- FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3])
- FMOV r1 r2 -> usage ([r1], [r2])
-
-
- -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line.
- BI cond reg lbl -> usage ([reg], [])
- BF cond reg lbl -> usage ([reg], [])
- JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet
-
- BSR _ n -> RU (argRegSet n) callClobberedRegSet
- JSR reg addr n -> RU (argRegSet n) callClobberedRegSet
-
- _ -> noUsage
-
- where
- usage (src, dst) = RU (mkRegSet (filter interesting src))
- (mkRegSet (filter interesting dst))
-
- interesting (FixedReg _) = False
- interesting _ = True
-
- regAddr (AddrReg r1) = [r1]
- regAddr (AddrRegImm r1 _) = [r1]
- regAddr (AddrImm _) = []
-
- regRI (RIReg r) = [r]
- regRI _ = []
-
-
-patchRegs :: Instr -> (Reg -> Reg) -> Instr
-patchRegs instr env = case instr of
- SPILL reg slot -> SPILL (env reg) slot
- RELOAD slot reg -> RELOAD slot (env reg)
- LD sz reg addr -> LD sz (env reg) (fixAddr addr)
- LDA reg addr -> LDA (env reg) (fixAddr addr)
- LDAH reg addr -> LDAH (env reg) (fixAddr addr)
- LDGP reg addr -> LDGP (env reg) (fixAddr addr)
- LDI sz reg imm -> LDI sz (env reg) imm
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- CLR reg -> CLR (env reg)
- ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
- NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
- ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
- SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
- SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
- SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
- MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
- DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
- REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
- NOT ar reg -> NOT (fixRI ar) (env reg)
- AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
- ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
- OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
- ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
- XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
- XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2)
- SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
- SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
- SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
- ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
- ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
- CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
- FCLR reg -> FCLR (env reg)
- FABS r1 r2 -> FABS (env r1) (env r2)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
- FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
- FMOV r1 r2 -> FMOV (env r1) (env r2)
- BI cond reg lbl -> BI cond (env reg) lbl
- BF cond reg lbl -> BF cond (env reg) lbl
- JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
- JSR reg addr i -> JSR (env reg) (fixAddr addr) i
- _ -> instr
- where
- fixAddr (AddrReg r1) = AddrReg (env r1)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
- fixAddr other = other
-
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
-
-
-mkSpillInstr
- :: Reg -- register to spill
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-
-mkSpillInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- -- Alpha: spill below the stack pointer (?)
- ST sz dyn (spRel (- (off `div` 8)))
-
-
-mkLoadInstr
- :: Reg -- register to load
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-mkLoadInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- LD sz dyn (spRel (- (off `div` 8)))
-
-
-mkBranchInstr
- :: BlockId
- -> [Instr]
-
-mkBranchInstr id = [BR id]
-
--}
-
-
-
-
diff --git a/compiler/nativeGen/Alpha/Regs.hs b/compiler/nativeGen/Alpha/Regs.hs
deleted file mode 100644
index ee490509deac1eb04b80084b6bf7fa6d385e911b..0000000000000000000000000000000000000000
--- a/compiler/nativeGen/Alpha/Regs.hs
+++ /dev/null
@@ -1,323 +0,0 @@
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1994-2004
---
--- Alpha support is rotted and incomplete.
--- -----------------------------------------------------------------------------
-
-
-module Alpha.Regs (
-{-
- Size(..),
- AddrMode(..),
- fits8Bits,
- fReg,
- gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-#include "../includes/stg/MachRegs.h"
-
-import RegsBase
-
-import BlockId
-import Cmm
-import CLabel ( CLabel, mkMainCapabilityLabel )
-import Pretty
-import Outputable ( Outputable(..), pprPanic, panic )
-import qualified Outputable
-import Unique
-import UniqSet
-import Constants
-import FastTypes
-import FastBool
-import UniqFM
-
-
-data Size
- = B -- byte
- | Bu
--- | W -- word (2 bytes): UNUSED
--- | Wu -- : UNUSED
- | L -- longword (4 bytes)
- | Q -- quadword (8 bytes)
--- | FF -- VAX F-style floating pt: UNUSED
--- | GF -- VAX G-style floating pt: UNUSED
--- | DF -- VAX D-style floating pt: UNUSED
--- | SF -- IEEE single-precision floating pt: UNUSED
- | TF -- IEEE double-precision floating pt
- deriving Eq
-
-
-data AddrMode
- = AddrImm Imm
- | AddrReg Reg
- | AddrRegImm Reg Imm
-
-
-addrOffset :: AddrMode -> Int -> Maybe AddrMode
-addrOffset addr off
- = case addr of
- _ -> panic "MachMisc.addrOffset not defined for Alpha"
-
-fits8Bits :: Integer -> Bool
-fits8Bits i = i >= -256 && i < 256
-
-
--- The Alpha has 64 registers of interest; 32 integer registers and 32 floating
--- point registers. The mapping of STG registers to alpha machine registers
--- is defined in StgRegs.h. We are, of course, prepared for any eventuality.
-
-fReg :: Int -> RegNo
-fReg x = (32 + x)
-
-v0, f0, ra, pv, gp, sp, zeroh :: Reg
-v0 = realReg 0
-f0 = realReg (fReg 0)
-ra = FixedReg ILIT(26)
-pv = t12
-gp = FixedReg ILIT(29)
-sp = FixedReg ILIT(30)
-zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method)
-
-t9, t10, t11, t12 :: Reg
-t9 = realReg 23
-t10 = realReg 24
-t11 = realReg 25
-t12 = realReg 27
-
-
-#define f0 32
-#define f1 33
-#define f2 34
-#define f3 35
-#define f4 36
-#define f5 37
-#define f6 38
-#define f7 39
-#define f8 40
-#define f9 41
-#define f10 42
-#define f11 43
-#define f12 44
-#define f13 45
-#define f14 46
-#define f15 47
-#define f16 48
-#define f17 49
-#define f18 50
-#define f19 51
-#define f20 52
-#define f21 53
-#define f22 54
-#define f23 55
-#define f24 56
-#define f25 57
-#define f26 58
-#define f27 59
-#define f28 60
-#define f29 61
-#define f30 62
-#define f31 63
-
-
--- allMachRegs is the complete set of machine regs.
-allMachRegNos :: [RegNo]
-allMachRegNos = [0..63]
-
-
--- these are the regs which we cannot assume stay alive over a
--- C call.
-callClobberedRegs :: [Reg]
-callClobberedRegs
- = [0, 1, 2, 3, 4, 5, 6, 7, 8,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
- fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15,
- fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23,
- fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
-
-
--- argRegs is the set of regs which are read for an n-argument call to C.
--- For archs which pass all args on the stack (x86), is empty.
--- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
-argRegs :: RegNo -> [Reg]
-
-argRegs 0 = []
-argRegs 1 = freeMappedRegs [16, fReg 16]
-argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17]
-argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]
-argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]
-argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]
-argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]
-argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!"
-
-
--- all of the arg regs ??
-allArgRegs :: [(Reg, Reg)]
-allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
-
-
--- horror show -----------------------------------------------------------------
-
-freeReg :: RegNo -> FastBool
-
-freeReg 26 = fastBool False -- return address (ra)
-freeReg 28 = fastBool False -- reserved for the assembler (at)
-freeReg 29 = fastBool False -- global pointer (gp)
-freeReg 30 = fastBool False -- stack pointer (sp)
-freeReg 31 = fastBool False -- always zero (zeroh)
-freeReg 63 = fastBool False -- always zero (f31)
-
-#ifdef REG_Base
-freeReg REG_Base = fastBool False
-#endif
-#ifdef REG_R1
-freeReg REG_R1 = fastBool False
-#endif
-#ifdef REG_R2
-freeReg REG_R2 = fastBool False
-#endif
-#ifdef REG_R3
-freeReg REG_R3 = fastBool False
-#endif
-#ifdef REG_R4
-freeReg REG_R4 = fastBool False
-#endif
-#ifdef REG_R5
-freeReg REG_R5 = fastBool False
-#endif
-#ifdef REG_R6
-freeReg REG_R6 = fastBool False
-#endif
-#ifdef REG_R7
-freeReg REG_R7 = fastBool False
-#endif
-#ifdef REG_R8
-freeReg REG_R8 = fastBool False
-#endif
-#ifdef REG_F1
-freeReg REG_F1 = fastBool False
-#endif
-#ifdef REG_F2
-freeReg REG_F2 = fastBool False
-#endif
-#ifdef REG_F3
-freeReg REG_F3 = fastBool False
-#endif
-#ifdef REG_F4
-freeReg REG_F4 = fastBool False
-#endif
-#ifdef REG_D1
-freeReg REG_D1 = fastBool False
-#endif
-#ifdef REG_D2
-freeReg REG_D2 = fastBool False
-#endif
-#ifdef REG_Sp
-freeReg REG_Sp = fastBool False
-#endif
-#ifdef REG_Su
-freeReg REG_Su = fastBool False
-#endif
-#ifdef REG_SpLim
-freeReg REG_SpLim = fastBool False
-#endif
-#ifdef REG_Hp
-freeReg REG_Hp = fastBool False
-#endif
-#ifdef REG_HpLim
-freeReg REG_HpLim = fastBool False
-#endif
-freeReg n = fastBool True
-
-
--- | Returns 'Nothing' if this global register is not stored
--- in a real machine register, otherwise returns @'Just' reg@, where
--- reg is the machine register it is stored in.
-
-globalRegMaybe :: GlobalReg -> Maybe Reg
-
-#ifdef REG_Base
-globalRegMaybe BaseReg = Just (RealReg REG_Base)
-#endif
-#ifdef REG_R1
-globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1)
-#endif
-#ifdef REG_R2
-globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2)
-#endif
-#ifdef REG_R3
-globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3)
-#endif
-#ifdef REG_R4
-globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4)
-#endif
-#ifdef REG_R5
-globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5)
-#endif
-#ifdef REG_R6
-globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6)
-#endif
-#ifdef REG_R7
-globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7)
-#endif
-#ifdef REG_R8
-globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8)
-#endif
-#ifdef REG_R9
-globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9)
-#endif
-#ifdef REG_R10
-globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10)
-#endif
-#ifdef REG_F1
-globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1)
-#endif
-#ifdef REG_F2
-globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2)
-#endif
-#ifdef REG_F3
-globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3)
-#endif
-#ifdef REG_F4
-globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4)
-#endif
-#ifdef REG_D1
-globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1)
-#endif
-#ifdef REG_D2
-globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2)
-#endif
-#ifdef REG_Sp
-globalRegMaybe Sp = Just (RealReg REG_Sp)
-#endif
-#ifdef REG_Lng1
-globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1)
-#endif
-#ifdef REG_Lng2
-globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2)
-#endif
-#ifdef REG_SpLim
-globalRegMaybe SpLim = Just (RealReg REG_SpLim)
-#endif
-#ifdef REG_Hp
-globalRegMaybe Hp = Just (RealReg REG_Hp)
-#endif
-#ifdef REG_HpLim
-globalRegMaybe HpLim = Just (RealReg REG_HpLim)
-#endif
-#ifdef REG_CurrentTSO
-globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO)
-#endif
-#ifdef REG_CurrentNursery
-globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery)
-#endif
-globalRegMaybe _ = Nothing
-
--}
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7a38540baaa135d0f78efe40fd1ab5647793da9a..57faa6ff0efc14d72b3a83a1a936d3c61bf48e36 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -13,13 +13,7 @@ module AsmCodeGen ( nativeCodeGen ) where
#include "nativeGen/NCG.h"
-#if alpha_TARGET_ARCH
-import Alpha.CodeGen
-import Alpha.Regs
-import Alpha.RegInfo
-import Alpha.Instr
-
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
import X86.Instr
@@ -56,6 +50,7 @@ import qualified RegAlloc.Graph.TrivColorable as Color
import TargetReg
import Platform
+import Config
import Instruction
import PIC
import Reg
@@ -64,7 +59,7 @@ import NCGMonad
import BlockId
import CgUtils ( fixStgRegisters )
import OldCmm
-import CmmOpt ( cmmMiniInline, cmmMachOpFold )
+import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
import OldPprCmm
import CLabel
@@ -74,7 +69,6 @@ import UniqSupply
import DynFlags
import StaticFlags
import Util
-import Config
import Digraph
import qualified Pretty
@@ -92,7 +86,6 @@ import Data.List
import Data.Maybe
import Control.Monad
import System.IO
-import Distribution.System
{-
The native-code generator has machine-independent and
@@ -378,37 +371,48 @@ cmmNativeGen dflags us cmm count
, Nothing
, mPprStats)
+ ---- x86fp_kludge. This pass inserts ffree instructions to clear
+ ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
+ ---- is clear, and library functions can return odd results if it
+ ---- isn't.
+ ----
+ ---- NB. must happen before shortcutBranches, because that
+ ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+ let kludged =
+#if i386_TARGET_ARCH
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge alloced
+#else
+ alloced
+#endif
+
+ ---- generate jump tables
+ let tabled =
+ {-# SCC "generateJumpTables" #-}
+ generateJumpTables kludged
+
---- shortcut branches
let shorted =
{-# SCC "shortcutBranches" #-}
- shortcutBranches dflags alloced
+ shortcutBranches dflags tabled
---- sequence blocks
let sequenced =
{-# SCC "sequenceBlocks" #-}
map sequenceTop shorted
- ---- x86fp_kludge
- let kludged =
-#if i386_TARGET_ARCH
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced
-#else
- sequenced
-#endif
-
- ---- expansion of SPARC synthetic instrs
+ ---- expansion of SPARC synthetic instrs
#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
- map expandTop kludged
+ map expandTop sequenced
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
#else
let expanded =
- kludged
+ sequenced
#endif
return ( usAlloc
@@ -447,14 +451,12 @@ makeImportsDoc dflags imports
-- stack so add the note in:
Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
#endif
-#if !defined(darwin_TARGET_OS)
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
-#endif
where
-- Generate "symbol stubs" for all external symbols that might
@@ -480,7 +482,7 @@ makeImportsDoc dflags imports
| otherwise
= Pretty.empty
- doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
astyle = mkCodeStyle AsmStyle
@@ -608,6 +610,18 @@ makeFarBranches blocks
makeFarBranches = id
#endif
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+ :: [NatCmmTop Instr] -> [NatCmmTop Instr]
+generateJumpTables xs = concatMap f xs
+ where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+ f p = [p]
+ g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs)
+
-- -----------------------------------------------------------------------------
-- Shortcut branches
@@ -718,10 +732,9 @@ Here we do:
and position independent refs
(ii) compile a list of imported symbols
-Ideas for other things we could do (ToDo):
+Ideas for other things we could do:
- shortcut jumps-to-jumps
- - eliminate dead code blocks
- simple CSE: if an expr is assigned to a temp, then replace later occs of
that expr with the temp, until the expr is no longer valid (can push through
temp assignments, and certain assigns to mem...)
@@ -730,7 +743,7 @@ Ideas for other things we could do (ToDo):
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
- blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
+ blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@ -807,8 +820,10 @@ cmmStmtConFold stmt
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
- = case expr of
+cmmExprConFold referenceKind expr = do
+ dflags <- getDynFlagsCmmOpt
+ let arch = platformArch (targetPlatform dflags)
+ case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
@@ -821,11 +836,9 @@ cmmExprConFold referenceKind expr
CmmLit (CmmLabel lbl)
-> do
- dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
@@ -836,15 +849,15 @@ cmmExprConFold referenceKind expr
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 29b9a54d49375ddd53723963adba3bc980f63c89..c96baddca1f9ec757a52a82ddf3b045f7e499507 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -15,6 +15,7 @@
module PPC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
@@ -798,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl))
genJump tree
= do
(target,code) <- getSomeReg tree
- return (code `snocOL` MTCTR target `snocOL` BCTR [])
+ return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
-- -----------------------------------------------------------------------------
@@ -1126,22 +1127,12 @@ genSwitch expr ids
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
- let
- jumpTable = map jumpTableEntryRel ids
-
- jumpTableEntryRel Nothing
- = CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just blockid)
- = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel (getUnique blockid)
-
- code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ let code = e_code `appOL` t_code `appOL` toOL [
SLW tmp reg (RIImm (ImmInt 2)),
LD II32 tmp (AddrRegReg tableReg tmp),
ADD tmp tmp (RIReg tableReg),
MTCTR tmp,
- BCTR [ id | Just id <- ids ]
+ BCTR ids (Just lbl)
]
return code
| otherwise
@@ -1149,19 +1140,27 @@ genSwitch expr ids
(reg,e_code) <- getSomeReg expr
tmp <- getNewRegNat II32
lbl <- getNewLabelNat
- let
- jumpTable = map jumpTableEntry ids
-
- code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ let code = e_code `appOL` toOL [
SLW tmp reg (RIImm (ImmInt 2)),
ADDIS tmp tmp (HA (ImmCLbl lbl)),
LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
MTCTR tmp,
- BCTR [ id | Just id <- ids ]
+ BCTR ids (Just lbl)
]
return code
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+ let jumpTable
+ | opt_PIC = map jumpTableEntryRel ids
+ | otherwise = map jumpTableEntry ids
+ where jumpTableEntryRel Nothing
+ = CmmStaticLit (CmmInt 0 wordWidth)
+ jumpTableEntryRel (Just blockid)
+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
+ in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 6aeccd3a8768b95288d0bd5a41d51b81cf15ecc6..0288f1bf02387bc28e1657ef3ecce60de4705e55 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -104,7 +104,7 @@ data Instr
| JMP CLabel -- same as branch,
-- but with CLabel instead of block ID
| MTCTR Reg
- | BCTR [BlockId] -- with list of local destinations
+ | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
| BL CLabel [Reg] -- with list of argument regs
| BCTRL [Reg]
@@ -184,7 +184,7 @@ ppc_regUsageOfInstr instr
BCC _ _ -> noUsage
BCCFAR _ _ -> noUsage
MTCTR reg -> usage ([reg],[])
- BCTR _ -> noUsage
+ BCTR _ _ -> noUsage
BL _ params -> usage (params, callClobberedRegs)
BCTRL params -> usage (params, callClobberedRegs)
ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
@@ -257,7 +257,7 @@ ppc_patchRegsOfInstr instr env
BCC cond lbl -> BCC cond lbl
BCCFAR cond lbl -> BCCFAR cond lbl
MTCTR reg -> MTCTR (env reg)
- BCTR targets -> BCTR targets
+ BCTR targets lbl -> BCTR targets lbl
BL imm argRegs -> BL imm argRegs -- argument regs
BCTRL argRegs -> BCTRL argRegs -- cannot be remapped
ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
@@ -326,7 +326,7 @@ ppc_jumpDestsOfInstr insn
= case insn of
BCC _ id -> [id]
BCCFAR _ id -> [id]
- BCTR targets -> targets
+ BCTR targets _ -> [id | Just id <- targets]
_ -> []
@@ -338,7 +338,7 @@ ppc_patchJumpInstr insn patchF
= case insn of
BCC cc id -> BCC cc (patchF id)
BCCFAR cc id -> BCCFAR cc (patchF id)
- BCTR _ -> error "Cannot patch BCTR"
+ BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl
_ -> insn
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 9fb86c013e94b7d26e3f5a1ed36db40e133aa4e0..8d8b16a0a561904e1ff19b02321d46fbaa7daa1d 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -12,7 +12,6 @@ module PPC.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
@@ -157,9 +156,6 @@ instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
pprReg :: Reg -> Doc
pprReg r
@@ -545,7 +541,7 @@ pprInstr (MTCTR reg) = hcat [
char '\t',
pprReg reg
]
-pprInstr (BCTR _) = hcat [
+pprInstr (BCTR _ _) = hcat [
char '\t',
ptext (sLit "bctr")
]
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index 73e0c2023e4ca706a9c26ba70db5cd597722ed26..7a2a84b68c9020d4eed2b24f39ae886b438c7399 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -209,7 +209,6 @@ spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE))
-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
argRegs :: RegNo -> [Reg]
argRegs 0 = []
argRegs 1 = map regSingle [3]
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 903082fc26b2a3e6b1297fe9cdbc979947849693..ef6ae9bc3a57fa2a57fb78b2d9c27230820aa95d 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -190,7 +190,7 @@ joinToTargets_again
_ -> let instr' = patchJumpInstr instr
(\bid -> if bid == dest
then mkBlockId fixup_block_id
- else dest)
+ else bid) -- no change!
in joinToTargets' block_live (block : new_blocks) block_id instr' dests
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index d08d10d437908cbe1b4f09cb16d26bf59bfc1e4f..beb48d66569c5ca3d7cab0fb13d54b652d118c72 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -8,6 +8,7 @@
module SPARC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
@@ -299,15 +300,11 @@ genSwitch expr ids
dst <- getNewRegNat II32
label <- getNewLabelNat
- let jumpTable = map jumpTableEntry ids
return $ e_code `appOL`
toOL
- -- the jump table
- [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
- -- load base of jump table
- , SETHI (HI (ImmCLbl label)) base_reg
+ [ -- load base of jump table
+ SETHI (HI (ImmCLbl label)) base_reg
, OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
-- the addrs in the table are 32 bits wide..
@@ -315,6 +312,11 @@ genSwitch expr ids
-- load and jump to the destination
, LD II32 (AddrRegReg base_reg offset_reg) dst
- , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+ , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
, NOP ]
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+ let jumpTable = map jumpTableEntry ids
+ in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 79b4629e548e5b53c5db77f46d1c895e0c396d04..93f4d274449863580de3c6997f82577caca99f1e 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -37,6 +37,7 @@ import RegClass
import Reg
import Size
+import CLabel
import BlockId
import OldCmm
import FastString
@@ -194,7 +195,7 @@ data Instr
-- With a tabled jump we know all the possible destinations.
-- We also need this info so we can work out what regs are live across the jump.
--
- | JMP_TBL AddrMode [BlockId]
+ | JMP_TBL AddrMode [Maybe BlockId] CLabel
| CALL (Either Imm Reg) Int Bool -- target, args, terminal
@@ -247,7 +248,7 @@ sparc_regUsageOfInstr instr
FxTOy _ _ r1 r2 -> usage ([r1], [r2])
JMP addr -> usage (regAddr addr, [])
- JMP_TBL addr _ -> usage (regAddr addr, [])
+ JMP_TBL addr _ _ -> usage (regAddr addr, [])
CALL (Left _ ) _ True -> noUsage
CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs)
@@ -315,7 +316,7 @@ sparc_patchRegsOfInstr instr env = case instr of
FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
JMP addr -> JMP (fixAddr addr)
- JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids
+ JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l
CALL (Left i) n t -> CALL (Left i) n t
CALL (Right r) n t -> CALL (Right (env r)) n t
@@ -345,7 +346,7 @@ sparc_jumpDestsOfInstr insn
= case insn of
BI _ _ id -> [id]
BF _ _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ -> [id | Just id <- ids]
_ -> []
@@ -354,6 +355,7 @@ sparc_patchJumpInstr insn patchF
= case insn of
BI cc annul id -> BI cc annul (patchF id)
BF cc annul id -> BF cc annul (patchF id)
+ JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l
_ -> insn
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index a63661f1452f812f5f0863c7c211ca4407780273..c5a33141d5699f4d16f8200ff3b07048df2784a3 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -12,7 +12,6 @@ module SPARC.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem
@@ -140,12 +139,6 @@ instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
--- | 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
@@ -543,7 +536,7 @@ pprInstr (BF cond b blockid)
]
pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
-pprInstr (JMP_TBL op _) = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) n _)
= hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 5df8f7777e22b7d93e8b1890cb52ab7dc76958a5..a6cc36fcb76743cec53f8f924a242f108943d37f 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -20,6 +20,7 @@
module X86.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
@@ -1932,16 +1933,7 @@ genSwitch expr ids
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
- let
- jumpTable = map jumpTableEntryRel ids
-
- jumpTableEntryRel Nothing
- = CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just blockid)
- = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel (getUnique blockid)
-
- op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+ let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0))
#if x86_64_TARGET_ARCH
@@ -1954,8 +1946,7 @@ genSwitch expr ids
code = e_code `appOL` t_code `appOL` toOL [
ADD (intSize wordWidth) op (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
- LDATA Text (CmmDataLabel lbl : jumpTable)
+ JMP_TBL (OpReg tableReg) ids Text lbl
]
#else
-- HACK: On x86_64 binutils<2.17 is only able to generate PC32
@@ -1965,20 +1956,18 @@ genSwitch expr ids
-- conjunction with the hack in PprMach.hs/pprDataItem once
-- binutils 2.17 is standard.
code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
MOVSxL II32
(OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0)))
(OpReg reg),
ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+ JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
]
#endif
#else
code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
ADD (intSize wordWidth) op (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+ JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
]
#endif
return code
@@ -1987,15 +1976,28 @@ genSwitch expr ids
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
let
- jumpTable = map jumpTableEntry ids
op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
- JMP_TBL op [ id | Just id <- ids ]
+ JMP_TBL op ids ReadOnlyData lbl
]
-- in
return code
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
+generateJumpTableForInstr _ = Nothing
+
+createJumpTable ids section lbl
+ = let jumpTable
+ | opt_PIC =
+ let jumpTableEntryRel Nothing
+ = CmmStaticLit (CmmInt 0 wordWidth)
+ jumpTableEntryRel (Just blockid)
+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
+ in map jumpTableEntryRel ids
+ | otherwise = map jumpTableEntry ids
+ in CmmData section (CmmDataLabel lbl : jumpTable)
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index a96452b9f16f152fc39b2eb5cd4924a23351e026..92655d16937be0d348f68fb05a94c4df2805ce02 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -289,7 +289,11 @@ data Instr
| JMP Operand
| JXX Cond BlockId -- includes unconditional branches
| JXX_GBL Cond Imm -- non-local version of JXX
- | JMP_TBL Operand [BlockId] -- table jump
+ -- Table jump
+ | JMP_TBL Operand -- Address to jump to
+ [Maybe BlockId] -- Blocks in the jump table
+ Section -- Data section jump table should be put in
+ CLabel -- Label of jump table
| CALL (Either Imm Reg) [Reg]
-- Other things.
@@ -350,7 +354,7 @@ x86_regUsageOfInstr instr
JXX _ _ -> mkRU [] []
JXX_GBL _ _ -> mkRU [] []
JMP op -> mkRUR (use_R op)
- JMP_TBL op _ -> mkRUR (use_R op)
+ JMP_TBL op _ _ _ -> mkRUR (use_R op)
CALL (Left _) params -> mkRU params callClobberedRegs
CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
CLTD _ -> mkRU [eax] [edx]
@@ -482,7 +486,7 @@ x86_patchRegsOfInstr instr env
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
JMP op -> patch1 JMP op
- JMP_TBL op ids -> patch1 JMP_TBL op $ ids
+ JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
@@ -579,7 +583,7 @@ x86_jumpDestsOfInstr
x86_jumpDestsOfInstr insn
= case insn of
JXX _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ _ -> [id | Just id <- ids]
_ -> []
@@ -589,7 +593,8 @@ x86_patchJumpInstr
x86_patchJumpInstr insn patchF
= case insn of
JXX cc id -> JXX cc (patchF id)
- JMP_TBL _ _ -> error "Cannot patch JMP_TBL"
+ JMP_TBL op ids section lbl
+ -> JMP_TBL op (map (fmap patchF) ids) section lbl
_ -> insn
@@ -741,7 +746,7 @@ i386_insert_ffrees blocks
where p insn r = case insn of
CALL _ _ -> GFREE : insn : r
JMP _ -> GFREE : insn : r
- JXX_GBL _ _ -> GFREE : insn : r
+ JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL"
_ -> insn : r
-- if you ever add a new FP insn to the fake x86 FP insn set,
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 5fe78e10142d86de3e85f70aa2256f434f81f2b9..38b6344950604f06be997c30a769a2a089d18917 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -12,7 +12,6 @@ module X86.Ppr (
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
@@ -34,7 +33,6 @@ import PprBase
import OldCmm
import CLabel
-import Config
import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
@@ -42,7 +40,6 @@ import qualified Outputable
import Outputable (panic, Outputable)
import Data.Word
-import Distribution.System
#if i386_TARGET_ARCH && darwin_TARGET_OS
import Data.Bits
@@ -87,7 +84,17 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
<+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
else empty
#endif
+ $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> Doc
+#if elf_OBJ_FORMAT
+pprSizeDecl lbl =
+ ptext (sLit "\t.size") <+> pprCLabel_asm lbl
+ <> ptext (sLit ", .-") <> pprCLabel_asm lbl
+#else
+pprSizeDecl _ = empty
+#endif
pprBasicBlock :: NatBasicBlock Instr -> Doc
pprBasicBlock (BasicBlock blockid instrs) =
@@ -162,12 +169,6 @@ instance Outputable Instr where
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg
- | cTargetArch == I386 = pprReg II32
- | cTargetArch == X86_64 = pprReg II64
- | otherwise = panic "X86.Ppr.pprUserReg: not defined"
-
pprReg :: Size -> Reg -> Doc
pprReg s r
@@ -626,7 +627,7 @@ pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
-pprInstr (JMP_TBL op _) = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
@@ -641,8 +642,8 @@ pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
-pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
-pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
+pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to
+pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to
pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
@@ -1093,7 +1094,6 @@ pprSizeOpReg name size op1 reg2
pprReg archWordSize reg2
]
-
pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
pprCondRegReg name size cond reg1 reg2
= hcat [
@@ -1115,11 +1115,18 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2
pprSize size2,
space,
pprReg size1 reg1,
-
comma,
pprReg size2 reg2
]
+pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc
+pprSizeSizeOpReg name size1 size2 op1 reg2
+ = hcat [
+ pprMnemonic name size2,
+ pprOperand size1 op1,
+ comma,
+ pprReg size2 reg2
+ ]
pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 094b74dc37581affe5ca6d054aae2e25e871419c..28d148c12c57b6607d5cf32bbec856efb0fefad8 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -249,7 +249,6 @@ floatregnos = fakeregnos ++ xmmregnos;
-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
argRegs :: RegNo -> [Reg]
argRegs _ = panic "MachRegs.argRegs(x86): should not be used!"
@@ -333,10 +332,24 @@ fake5 = regSingle 21
{-
AMD x86_64 architecture:
-- Registers 0-16 have 32-bit counterparts (eax, ebx etc.)
-- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
-- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-
+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
+
+ 8 16 32 64
+ ---------------------
+ al ax eax rax
+ bl bx ebx rbx
+ cl cx ecx rcx
+ dl dx edx rdx
+ sil si esi rsi
+ dil si edi rdi
+ bpl bp ebp rbp
+ spl sp esp rsp
+ r10b r10w r10d r10
+ r11b r11w r11d r11
+ r12b r12w r12d r12
+ r13b r13w r13d r13
+ r14b r14w r14d r14
+ r15b r15w r15d r15
-}
rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5c41d7238d22df7b37f9d28152d44da04c51b611..a55a6310c97ac30555638bc3e1e7a2fc6bd839ea 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,7 +68,7 @@ import UniqFM
import DynFlags
import Module
import Ctype
-import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) )
+import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
import Control.Monad
@@ -335,11 +335,6 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") }
{ token ITcubxparen }
}
-<0> {
- "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
- "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
-}
-
<0,option_prags> {
\( { special IToparen }
\) { special ITcparen }
@@ -541,14 +536,14 @@ data Token
| ITchar Char
| ITstring FastString
| ITinteger Integer
- | ITrational Rational
+ | ITrational FractionalLit
| ITprimchar Char
| ITprimstring FastString
| ITprimint Integer
| ITprimword Integer
- | ITprimfloat Rational
- | ITprimdouble Rational
+ | ITprimfloat FractionalLit
+ | ITprimdouble FractionalLit
-- Template Haskell extension tokens
| ITopenExpQuote -- [| or [e|
@@ -1061,9 +1056,12 @@ hexadecimal = (16,hexDigit)
-- readRational can understand negative rationals, exponents, everything.
tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float str = ITrational $! readRational str
-tok_primfloat str = ITprimfloat $! readRational str
-tok_primdouble str = ITprimdouble $! readRational str
+tok_float str = ITrational $! readFractionalLit str
+tok_primfloat str = ITprimfloat $! readFractionalLit str
+tok_primdouble str = ITprimdouble $! readFractionalLit str
+
+readFractionalLit :: String -> FractionalLit
+readFractionalLit str = (FL $! str) $! readRational str
-- -----------------------------------------------------------------------------
-- Layout processing
@@ -1751,8 +1749,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
-- integer
-genericsBit :: Int
-genericsBit = 0 -- {| and |}
+-- The "genericsBit" is now unused, available for others
+-- genericsBit :: Int
+-- genericsBit = 0 -- {|, |} and "generic"
+
ffiBit :: Int
ffiBit = 1
parrBit :: Int
@@ -1803,8 +1803,6 @@ nondecreasingIndentationBit = 25
always :: Int -> Bool
always _ = True
-genericsEnabled :: Int -> Bool
-genericsEnabled flags = testBit flags genericsBit
parrEnabled :: Int -> Bool
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
@@ -1856,7 +1854,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
@@ -1873,34 +1871,34 @@ mkPState flags buf loc =
alr_justClosedExplicitLetBlock = False
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
- .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
- .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` xopt Opt_DoRec flags
- .|. recBit `setBitIf` xopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
+ .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
- .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
- | otherwise = 0
+ | otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index bfadfbaff878b63b59ea3ef8b7f7f4a175a1bc07..102f989332b711894647d84678e7e44fa7cb13a1 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -721,6 +721,11 @@ decl_cls :: { Located (OrdList (LHsDecl RdrName)) }
decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
| decl { $1 }
+ -- A 'default' signature used with the generic-programming extension
+ | 'default' infixexp '::' sigtypedoc
+ {% do { (TypeSig l ty) <- checkValSig $2 $4
+ ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) }
| decls_cls ';' { LL (unLoc $1) }
@@ -1022,8 +1027,6 @@ atype :: { LHsType RdrName }
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
--- Generics
- | INTEGER { L1 (HsNumTy (getINTEGER $1)) }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
@@ -1232,9 +1235,11 @@ gdrh :: { LGRHS RdrName }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
- : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
- ; return (LL $ unitOL (LL $ SigD s)) }
- -- See Note [Declaration/signature overlap] for why we need infixexp here
+ :
+ -- See Note [Declaration/signature overlap] for why we need infixexp here
+ infixexp '::' sigtypedoc
+ {% do s <- checkValSig $1 $3
+ ; return (LL $ unitOL (LL $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
@@ -1283,14 +1288,9 @@ exp10 :: { LHsExpr RdrName }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
- | 'do' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo DoExpr stmts body)) }
- | 'mdo' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo MDoExpr
- [L loc (mkRecStmt stmts)]
- body)) }
+ | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
+ | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
@@ -1465,7 +1465,10 @@ list :: { LHsExpr RdrName }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals
+ {% checkMonadComp >>= \ ctxt ->
+ return (sL (comb2 $1 $>) $
+ mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
@@ -1480,7 +1483,7 @@ flattenedpquals :: { Located [LStmt RdrName] }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+ qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
-- we wrap them into as a ParStmt
}
@@ -1501,8 +1504,7 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
-- Function is applied to a list of stmts *in order*
@@ -1537,7 +1539,7 @@ parr :: { LHsExpr RdrName }
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case.
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 8bf94539fa42f00aacd004d7b7750fc2013fa68d..3f2b32a8b3e614ac0783a03ff24b89c44fa0a31e 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -269,7 +269,7 @@ exp :: { IfaceExpr }
| '%let' let_bind '%in' exp { IfaceLet $2 $4 }
-- gaw 2004
| '%case' '(' ty ')' aexp '%of' id_bndr
- '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
+ '{' alts1 '}' { IfaceCase $5 (fst $7) $9 }
| '%cast' aexp aty { IfaceCast $2 $3 }
-- No InlineMe any more
-- | '%note' STRING exp
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 47abf232e23181fe556aa754bd1052d9dc5b8862..a9433441e81ed4c7f0c8e53758efb6ca765a8ff1 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -40,8 +40,7 @@ module RdrHsSyn (
checkPattern, -- HsExp -> P HsPat
bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
- checkDo, -- [Stmt] -> P [Stmt]
- checkMDo, -- [Stmt] -> P [Stmt]
+ checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkDoAndIfThenElse,
@@ -54,6 +53,7 @@ import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
+import Name ( Name )
import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
InlinePragma(..), InlineSpec(..) )
import Lexer
@@ -127,7 +127,6 @@ extract_lty (L loc ty) acc
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
- HsNumTy {} -> acc
HsCoreTy {} -> acc -- The type is closed
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
@@ -152,8 +151,7 @@ extractGenericPatTyVars binds
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
get _ acc = acc
- get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
- get_m _ acc = acc
+ get_m _ acc = acc
\end{code}
@@ -611,34 +609,6 @@ checkPred (L spn ty)
check loc _ _ = parseErrorSDoc loc
(text "malformed class assertion:" <+> ppr ty)
----------------------------------------------------------------------------
--- Checking statements in a do-expression
--- We parse do { e1 ; e2 ; }
--- as [ExprStmt e1, ExprStmt e2]
--- checkDo (a) checks that the last thing is an ExprStmt
--- (b) returns it separately
--- same comments apply for mdo as well
-
-checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-
-checkDo = checkDoMDo "a " "'do'"
-checkMDo = checkDoMDo "an " "'mdo'"
-
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
-checkDoMDo pre nm _ ss = do
- check ss
- where
- check [] = panic "RdrHsSyn:checkDoMDo"
- check [L _ (ExprStmt e _ _)] = return ([], e)
- check [L l e] = parseErrorSDoc l
- (text ("The last statement in " ++ pre ++ nm ++
- " construct must be an expression:")
- $$ ppr e)
- check (s:ss) = do
- (ss',e') <- check ss
- return ((s:ss'),e')
-
-- -------------------------------------------------------------------------
-- Checking Patterns.
@@ -732,8 +702,6 @@ checkAPat dynflags loc e0 = case e0 of
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsQuasiQuoteE q -> return (QuasiQuotePat q)
--- Generics
- HsType ty -> return (TypePat ty)
_ -> patFail loc e0
placeHolderPunRhs :: LHsExpr RdrName
@@ -812,17 +780,20 @@ checkValSig lhs@(L l _) ty
ppr lhs <+> text "::" <+> ppr ty)
$$ text hint)
where
- hint = if looks_like_foreign lhs
+ hint = if foreign_RDR `looks_like` lhs
then "Perhaps you meant to use -XForeignFunctionInterface?"
- else "Should be of form <variable> :: <type>"
+ else if default_RDR `looks_like` lhs
+ then "Perhaps you meant to use -XDefaultSignatures?"
+ else "Should be of form <variable> :: <type>"
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
- looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
- looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
- looks_like_foreign _ = False
+ looks_like s (L _ (HsVar v)) = v == s
+ looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
+ looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
+ default_RDR = mkUnqual varName (fsLit "default")
checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool
@@ -912,6 +883,20 @@ isFunLhs e = go e []
_ -> return Nothing }
go _ _ = return Nothing
+
+---------------------------------------------------------------------------
+-- Check for monad comprehensions
+--
+-- If the flag MonadComprehensions is set, return a `MonadComp' context,
+-- otherwise use the usual `ListComp' context
+
+checkMonadComp :: P (HsStmtContext Name)
+checkMonadComp = do
+ pState <- getPState
+ return $ if xopt Opt_MonadComprehensions (dflags pState)
+ then MonadComp
+ else ListComp
+
---------------------------------------------------------------------------
-- Miscellaneous utilities
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index a92cabdec054a7d542d78a917790527a0624b34b..87bb94a14862c5167a55e6e913de8241703c4597 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,7 +13,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
- ForeignCall(..),
+ ForeignCall(..), isSafeForeignCall,
Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
deriving Eq
{-! derive: Binary !-}
+isSafeForeignCall :: ForeignCall -> Bool
+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
+
-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 24756d5bae8823d5a2be24d8bb440dcf66d485f5..101780deb206b4172bfef8e0072aee7c920a097b 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey
%* *
%************************************************************************
-This section tells what the compiler knows about the assocation of
+This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
@@ -160,6 +160,7 @@ basicKnownKeyNames
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName,
+ fmapName,
-- MonadRec stuff
mfixName,
@@ -221,10 +222,27 @@ basicKnownKeyNames
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
+
+ -- Generics
+ , genClassName, gen1ClassName
+ , datatypeClassName, constructorClassName, selectorClassName
+
+ -- Monad comprehensions
+ , guardMName
+ , liftMName
+ , groupMName
+ , mzipName
]
genericTyConNames :: [Name]
-genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
+genericTyConNames = [
+ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+ k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+ compTyConName, rTyConName, pTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+ repTyConName, rep1TyConName
+ ]
-- Know names from the DPH package which vary depending on the selected DPH backend.
--
@@ -256,14 +274,15 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM,
+ gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
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")
@@ -271,6 +290,7 @@ gHC_UNIT = mkPrimModule (fsLit "GHC.Unit")
gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering")
gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
+gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
@@ -311,6 +331,8 @@ gHC_INT = mkBaseModule (fsLit "GHC.Int")
gHC_WORD = mkBaseModule (fsLit "GHC.Word")
mONAD = mkBaseModule (fsLit "Control.Monad")
mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix")
+mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group")
+mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip")
aRROW = mkBaseModule (fsLit "Control.Arrow")
cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
@@ -525,12 +547,59 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
+error_RDR :: RdrName
+error_RDR = varQual_RDR gHC_ERR (fsLit "error")
+
+-- Old Generics (constructors and functions)
crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl")
inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr")
genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit")
+-- Generics (constructors and functions)
+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
+ k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
+ prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR,
+ to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
+ conFixity_RDR, conIsRecord_RDR,
+ noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
+ prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
+ rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+
+u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
+par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
+rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1")
+k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1")
+m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1")
+
+l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1")
+r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1")
+
+prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
+comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
+
+from_RDR = varQual_RDR gHC_GENERICS (fsLit "from")
+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
+to_RDR = varQual_RDR gHC_GENERICS (fsLit "to")
+to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1")
+
+datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
+moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName")
+selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName")
+conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName")
+conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity")
+conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
+
+noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
+arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity")
+prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
+infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix")
+leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
+rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
+notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+
+
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
@@ -576,19 +645,48 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey
leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
--- Generics
-crossTyConName, plusTyConName, genUnitTyConName :: Name
-crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey
-plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey
-genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey
+-- Generics (types)
+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+ k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+ compTyConName, rTyConName, pTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+ repTyConName, rep1TyConName :: Name
+
+v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
+u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
+par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
+rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
+k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
+m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
+
+sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey
+prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
+compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
+
+rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey
+pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey
+dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey
+cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey
+sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey
+
+rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
+par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
+d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
+c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
+s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
+noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
+
+repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
-- Base strings Strings
unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
-unpackCStringName = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
+unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey
@@ -597,12 +695,13 @@ inlineIdName :: Name
inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
-- Base classes (Eq, Ord, Functor)
-eqClassName, eqName, ordClassName, geName, functorClassName :: Name
+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey
eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey
functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
+fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad
monadClassName, thenMName, bindMName, returnMName, failMName :: Name
@@ -755,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey
readClassName :: Name
readClassName = clsQual gHC_READ (fsLit "Read") readClassKey
+-- Classes Generic and Generic1, Datatype, Constructor and Selector
+genClassName, gen1ClassName, datatypeClassName, constructorClassName,
+ selectorClassName :: Name
+genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey
+gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey
+
+datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
+constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
+selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
+
-- parallel array types and functions
enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
singletonPName, replicatePName, mapPName, filterPName,
@@ -834,6 +943,14 @@ appAName = varQual aRROW (fsLit "app") appAIdKey
choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey
loopAName = varQual aRROW (fsLit "loop") loopAIdKey
+-- Monad comprehensions
+guardMName, liftMName, groupMName, mzipName :: Name
+guardMName = varQual mONAD (fsLit "guard") guardMIdKey
+liftMName = varQual mONAD (fsLit "liftM") liftMIdKey
+groupMName = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey
+mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey
+
+
-- Annotation type checking
toAnnotationWrapperName :: Name
toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey
@@ -944,6 +1061,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique
applicativeClassKey = mkPreludeClassUnique 34
foldableClassKey = mkPreludeClassUnique 35
traversableClassKey = mkPreludeClassUnique 36
+
+genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
+ selectorClassKey :: Unique
+genClassKey = mkPreludeClassUnique 37
+gen1ClassKey = mkPreludeClassUnique 38
+
+datatypeClassKey = mkPreludeClassUnique 39
+constructorClassKey = mkPreludeClassUnique 40
+selectorClassKey = mkPreludeClassUnique 41
\end{code}
%************************************************************************
@@ -1003,11 +1129,12 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
- funPtrTyConKey, tVarPrimTyConKey :: Unique
+ funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
-stableNameTyConKey = mkPreludeTyConUnique 52
-mutVarPrimTyConKey = mkPreludeTyConUnique 55
+stableNameTyConKey = mkPreludeTyConUnique 52
+eqPredPrimTyConKey = mkPreludeTyConUnique 53
+mutVarPrimTyConKey = mkPreludeTyConUnique 55
ioTyConKey = mkPreludeTyConUnique 56
wordPrimTyConKey = mkPreludeTyConUnique 58
wordTyConKey = mkPreludeTyConUnique 59
@@ -1029,12 +1156,6 @@ ptrTyConKey = mkPreludeTyConUnique 74
funPtrTyConKey = mkPreludeTyConUnique 75
tVarPrimTyConKey = mkPreludeTyConUnique 76
--- Generic Type Constructors
-crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
-crossTyConKey = mkPreludeTyConUnique 79
-plusTyConKey = mkPreludeTyConUnique 80
-genUnitTyConKey = mkPreludeTyConUnique 81
-
-- Parallel array type constructor
parrTyConKey :: Unique
parrTyConKey = mkPreludeTyConUnique 82
@@ -1047,9 +1168,8 @@ eitherTyConKey :: Unique
eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors
-tySuperKindTyConKey, coSuperKindTyConKey :: Unique
+tySuperKindTyConKey :: Unique
tySuperKindTyConKey = mkPreludeTyConUnique 85
-coSuperKindTyConKey = mkPreludeTyConUnique 86
-- Kind constructors
liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
@@ -1086,6 +1206,41 @@ opaqueTyConKey = mkPreludeTyConUnique 133
stringTyConKey :: Unique
stringTyConKey = mkPreludeTyConUnique 134
+-- Generics (Unique keys)
+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
+ k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
+ compTyConKey, rTyConKey, pTyConKey, dTyConKey,
+ cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+ d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
+ repTyConKey, rep1TyConKey :: Unique
+
+v1TyConKey = mkPreludeTyConUnique 135
+u1TyConKey = mkPreludeTyConUnique 136
+par1TyConKey = mkPreludeTyConUnique 137
+rec1TyConKey = mkPreludeTyConUnique 138
+k1TyConKey = mkPreludeTyConUnique 139
+m1TyConKey = mkPreludeTyConUnique 140
+
+sumTyConKey = mkPreludeTyConUnique 141
+prodTyConKey = mkPreludeTyConUnique 142
+compTyConKey = mkPreludeTyConUnique 143
+
+rTyConKey = mkPreludeTyConUnique 144
+pTyConKey = mkPreludeTyConUnique 145
+dTyConKey = mkPreludeTyConUnique 146
+cTyConKey = mkPreludeTyConUnique 147
+sTyConKey = mkPreludeTyConUnique 148
+
+rec0TyConKey = mkPreludeTyConUnique 149
+par0TyConKey = mkPreludeTyConUnique 150
+d1TyConKey = mkPreludeTyConUnique 151
+c1TyConKey = mkPreludeTyConUnique 152
+s1TyConKey = mkPreludeTyConUnique 153
+noSelTyConKey = mkPreludeTyConUnique 154
+
+repTyConKey = mkPreludeTyConUnique 155
+rep1TyConKey = mkPreludeTyConUnique 156
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
@@ -1238,6 +1393,9 @@ mapIdKey = mkPreludeMiscIdUnique 69
groupWithIdKey = mkPreludeMiscIdUnique 70
dollarIdKey = mkPreludeMiscIdUnique 71
+coercionTokenIdKey :: Unique
+coercionTokenIdKey = mkPreludeMiscIdUnique 72
+
-- Parallel array functions
singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
@@ -1280,7 +1438,8 @@ unboundKey = mkPreludeMiscIdUnique 101
fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
- failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey
+ failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+ fmapClassOpKey
:: Unique
fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
minusClassOpKey = mkPreludeMiscIdUnique 103
@@ -1295,6 +1454,7 @@ negateClassOpKey = mkPreludeMiscIdUnique 111
failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
+fmapClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
-- Recursive do notation
@@ -1325,6 +1485,14 @@ realToFracIdKey = mkPreludeMiscIdUnique 128
toIntegerClassOpKey = mkPreludeMiscIdUnique 129
toRationalClassOpKey = mkPreludeMiscIdUnique 130
+-- Monad comprehensions
+guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique
+guardMIdKey = mkPreludeMiscIdUnique 131
+liftMIdKey = mkPreludeMiscIdUnique 132
+groupMIdKey = mkPreludeMiscIdUnique 133
+mzipIdKey = mkPreludeMiscIdUnique 134
+
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
-----------------------------------------------------
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b37556be121dd409b60f506af99b7995c7f8db50..93cc576a81dee4cb5026777d2c132e57f8ed2d64 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
- (Lit 4) +# (Lit y) = Lit (x+#y)
+ (Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
@@ -527,7 +527,7 @@ For dataToTag#, we can reduce if either
dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
| tag_to_enum `hasKey` tagToEnumKey
- , ty1 `coreEqType` ty2
+ , ty1 `eqType` ty2
= Just tag -- dataToTag (tagToEnum x) ==> x
dataToTagRule id_unf [_, val_arg]
@@ -600,7 +600,7 @@ match_append_lit _ [Type ty1,
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
- = ASSERT( ty1 `coreEqType` ty2 )
+ = ASSERT( ty1 `eqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `appendFS` s2))
`App` c1
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 8c532ffc869157e6503cf66f1211d05b0a810664..29c5644346e8ea47e4f5b31d0d44fcf93b391776 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -18,8 +18,8 @@ module PrimOp (
tagToEnumKey,
- primOpOutOfLine, primOpNeedsWrapper,
- primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
+ primOpOutOfLine, primOpCodeSize,
+ primOpOkForSpeculation, primOpIsCheap,
getPrimOpResultInfo, PrimOpResultInfo(..),
@@ -363,18 +363,23 @@ primOpIsCheap op = primOpOkForSpeculation op
-- even if primOpIsCheap sometimes says 'True'.
\end{code}
-primOpIsDupable
-~~~~~~~~~~~~~~~
-primOpIsDupable means that the use of the primop is small enough to
-duplicate into different case branches. See CoreUtils.exprIsDupable.
+primOpCodeSize
+~~~~~~~~~~~~~~
+Gives an indication of the code size of a primop, for the purposes of
+calculating unfolding sizes; see CoreUnfold.sizeExpr.
\begin{code}
-primOpIsDupable :: PrimOp -> Bool
- -- See comments with CoreUtils.exprIsDupable
- -- We say it's dupable it isn't implemented by a C call with a wrapper
-primOpIsDupable op = not (primOpNeedsWrapper op)
-\end{code}
+primOpCodeSize :: PrimOp -> Int
+#include "primop-code-size.hs-incl"
+
+primOpCodeSizeDefault :: Int
+primOpCodeSizeDefault = 1
+ -- CoreUnfold.primOpSize already takes into account primOpOutOfLine
+ -- and adds some further costs for the args in that case.
+primOpCodeSizeForeignCall :: Int
+primOpCodeSizeForeignCall = 4
+\end{code}
\begin{code}
primOpCanFail :: PrimOp -> Bool
@@ -421,14 +426,6 @@ primOpHasSideEffects :: PrimOp -> Bool
#include "primop-has-side-effects.hs-incl"
\end{code}
-Inline primitive operations that perform calls need wrappers to save
-any live variables that are stored in caller-saves registers.
-
-\begin{code}
-primOpNeedsWrapper :: PrimOp -> Bool
-#include "primop-needs-wrapper.hs-incl"
-\end{code}
-
\begin{code}
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index ac3a528f367d5b5b942e61607c7975e6ed8cda35..d0495d7b29deecf231173b443a95357c2564a869 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -14,7 +14,22 @@ module TysPrim(
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
- primTyCons,
+ -- Kind constructors...
+ tySuperKindTyCon, tySuperKind,
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
+
+ tySuperKindTyConName, liftedTypeKindTyConName,
+ openTypeKindTyConName, unliftedTypeKindTyConName,
+ ubxTupleKindTyConName, argTypeKindTyConName,
+
+ -- Kinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+ mkArrowKind, mkArrowKinds, isCoercionKind,
+
+ funTyCon, funTyConName,
+ primTyCons,
charPrimTyCon, charPrimTy,
intPrimTyCon, intPrimTy,
@@ -44,7 +59,9 @@ module TysPrim(
word32PrimTyCon, word32PrimTy,
int64PrimTyCon, int64PrimTy,
- word64PrimTyCon, word64PrimTy,
+ word64PrimTyCon, word64PrimTy,
+
+ eqPredPrimTyCon, -- ty1 ~ ty2
-- * Any
anyTyCon, anyTyConOfKind, anyTypeOfKind
@@ -54,11 +71,9 @@ module TysPrim(
import Var ( TyVar, mkTyVar )
import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName ( mkTcOcc )
-import OccName ( mkTyVarOccFS, mkTcOccFS )
-import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
-import Type
-import Coercion
+import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import TyCon
+import TypeRep
import SrcLoc
import Unique ( mkAlphaTyVarUnique )
import PrelNames
@@ -102,6 +117,7 @@ primTyCons
, word32PrimTyCon
, word64PrimTyCon
, anyTyCon
+ , eqPredPrimTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
@@ -111,7 +127,7 @@ mkPrimTc fs unique tycon
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -122,8 +138,9 @@ word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word
addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
-statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
+statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
+eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon
+realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
@@ -193,109 +210,95 @@ argBetaTy = mkTyVarTy argBetaTyVar
%************************************************************************
%* *
- Any
+ FunTyCon
%* *
%************************************************************************
-Note [Any types]
-~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
-
- * It is defined in module GHC.Prim, and exported so that it is
- available to users. For this reason it's treated like any other
- primitive type:
- - has a fixed unique, anyTyConKey,
- - lives in the global name cache
- - built with TyCon.PrimTyCon
-
- * It is lifted, and hence represented by a pointer
-
- * It is inhabited by at least one value, namely bottom
-
- * You can unsafely coerce any lifted type to Ayny, and back.
-
- * It does not claim to be a *data* type, and that's important for
- the code generator, because the code gen may *enter* a data value
- but never enters a function value.
-
- * It is used to instantiate otherwise un-constrained type variables of kind *
- For example length Any []
- See Note [Strangely-kinded void TyCons]
-
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *. This is a bit
-like tuples; there is a potentially-infinite family. They have slightly
-different characteristics to Any::*:
-
- * They are built with TyCon.AnyTyCon
- * They have non-user-writable names like "Any(*->*)"
- * They are not exported by GHC.Prim
- * They are uninhabited (of course; not kind *)
- * They have a unique derived from their OccName (see Note [Uniques of Any])
- * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique. Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead. That should be unique,
- - both wrt each other, because their strings differ
-
- - and wrt any other Name, because Names get uniques with
- various 'char' tags, but the OccName of Any will
- get a Unique built with mkTcOccUnique, which has a particular 'char'
- tag; see Unique.mkTcOccUnique!
-
-Note [Strangely-kinded void TyCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #959 for more examples
+\begin{code}
+funTyConName :: Name
+funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+
+funTyCon :: TyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
+ -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+ -- But if we do that we get kind errors when saying
+ -- instance Control.Arrow (->)
+ -- becuase the expected kind is (*->*->*). The trouble is that the
+ -- expected/actual stuff in the unifier does not go contra-variant, whereas
+ -- the kind sub-typing does. Sigh. It really only matters if you use (->) in
+ -- a prefix way, thus: (->) Int# Int#. And this is unusual.
+ -- because they are never in scope in the source
+\end{code}
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void. Eg.
- length []
-===>
- length Any (Nil Any)
+%************************************************************************
+%* *
+ Kinds
+%* *
+%************************************************************************
-But in really obscure programs, the type variable might have a kind
-other than *, so we need to invent a suitably-kinded type.
+\begin{code}
+-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
+tySuperKindTyCon, liftedTypeKindTyCon,
+ openTypeKindTyCon, unliftedTypeKindTyCon,
+ ubxTupleKindTyCon, argTypeKindTyCon
+ :: TyCon
+tySuperKindTyConName, liftedTypeKindTyConName,
+ openTypeKindTyConName, unliftedTypeKindTyConName,
+ ubxTupleKindTyConName, argTypeKindTyConName
+ :: Name
+
+tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
+liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
+openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
+argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
+
+--------------------------
+-- ... and now their names
+
+tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
+openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
+unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
+ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
+argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
+
+mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
+mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
+ key
+ (ATyCon tycon)
+ BuiltInSyntax
+ -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
+ -- because they are never in scope in the source
+\end{code}
-This commit uses
- Any for kind *
- Any(*->*) for kind *->*
- etc
\begin{code}
-anyTyConName :: Name
-anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+kindTyConType :: TyCon -> Type
+kindTyConType kind = TyConApp kind []
-anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
-anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+liftedTypeKind = kindTyConType liftedTypeKindTyCon
+unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
+openTypeKind = kindTyConType openTypeKindTyCon
+argTypeKind = kindTyConType argTypeKindTyCon
+ubxTupleKind = kindTyConType ubxTupleKindTyCon
-anyTyConOfKind :: Kind -> TyCon
--- Map all superkinds of liftedTypeKind to liftedTypeKind
-anyTyConOfKind kind
- | liftedTypeKind `isSubKind` kind = anyTyCon
- | otherwise = tycon
- where
- -- Derive the name from the kind, thus:
- -- Any(*->*), Any(*->*->*)
- -- These are names that can't be written by the user,
- -- and are not allocated in the global name cache
- str = "Any" ++ showSDoc (pprParendKind kind)
+-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
+mkArrowKind :: Kind -> Kind -> Kind
+mkArrowKind k1 k2 = FunTy k1 k2
- occ = mkTcOcc str
- uniq = getUnique occ -- See Note [Uniques of Any]
- name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
- tycon = mkAnyTyCon name kind
-\end{code}
+-- | Iterated application of 'mkArrowKind'
+mkArrowKinds :: [Kind] -> Kind -> Kind
+mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+tySuperKind :: SuperKind
+tySuperKind = kindTyConType tySuperKindTyCon
+\end{code}
%************************************************************************
%* *
@@ -376,6 +379,22 @@ doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep
%* *
%************************************************************************
+Note [The (~) TyCon)
+~~~~~~~~~~~~~~~~~~~~
+There is a perfectly ordinary type constructor (~) that represents the type
+of coercions (which, remember, are values). For example
+ Refl Int :: Int ~ Int
+
+Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
+ Refl Maybe :: Maybe ~ Maybe
+
+So the true kind of (~) :: forall k. k -> k -> #. But we don't have
+polymorphic kinds (yet). However, (~) really only appears saturated in
+which case there is no problem in finding the kind of (ty1 ~ ty2). So
+we check that in CoreLint (and, in an assertion, in Kind.typeKind).
+
+Note [The State# TyCon]
+~~~~~~~~~~~~~~~~~~~~~~~
State# is the primitive, unlifted type of states. It has one type parameter,
thus
State# RealWorld
@@ -388,8 +407,13 @@ keep different state threads separate. It is represented by nothing at all.
\begin{code}
mkStatePrimTy :: Type -> Type
mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
-statePrimTyCon :: TyCon
+
+statePrimTyCon :: TyCon -- See Note [The State# TyCon]
statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
+
+eqPredPrimTyCon :: TyCon -- The representation type for equality predicates
+ -- See Note [The (~) TyCon]
+eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
@@ -408,7 +432,6 @@ realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld
Note: the ``state-pairing'' types are not truly primitive, so they are
defined in \tr{TysWiredIn.lhs}, not here.
-
%************************************************************************
%* *
\subsection[TysPrim-arrays]{The primitive array types}
@@ -551,3 +574,110 @@ threadIdPrimTy = mkTyConTy threadIdPrimTyCon
threadIdPrimTyCon :: TyCon
threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
\end{code}
+
+
+
+%************************************************************************
+%* *
+ Any
+%* *
+%************************************************************************
+
+Note [Any types]
+~~~~~~~~~~~~~~~~
+The type constructor Any::* has these properties
+
+ * It is defined in module GHC.Prim, and exported so that it is
+ available to users. For this reason it's treated like any other
+ primitive type:
+ - has a fixed unique, anyTyConKey,
+ - lives in the global name cache
+ - built with TyCon.PrimTyCon
+
+ * It is lifted, and hence represented by a pointer
+
+ * It is inhabited by at least one value, namely bottom
+
+ * You can unsafely coerce any lifted type to Ayny, and back.
+
+ * It does not claim to be a *data* type, and that's important for
+ the code generator, because the code gen may *enter* a data value
+ but never enters a function value.
+
+ * It is used to instantiate otherwise un-constrained type variables of kind *
+ For example length Any []
+ See Note [Strangely-kinded void TyCons]
+
+In addition, we have a potentially-infinite family of types, one for
+each kind /other than/ *, needed to instantiate otherwise
+un-constrained type variables of kinds other than *. This is a bit
+like tuples; there is a potentially-infinite family. They have slightly
+different characteristics to Any::*:
+
+ * They are built with TyCon.AnyTyCon
+ * They have non-user-writable names like "Any(*->*)"
+ * They are not exported by GHC.Prim
+ * They are uninhabited (of course; not kind *)
+ * They have a unique derived from their OccName (see Note [Uniques of Any])
+ * Their Names do not live in the global name cache
+
+Note [Uniques of Any]
+~~~~~~~~~~~~~~~~~~~~~
+Although Any(*->*), say, doesn't have a binding site, it still needs
+to have a Unique. Unlike tuples (which are also an infinite family)
+there is no convenient way to index them, so we use the Unique from
+their OccName instead. That should be unique,
+ - both wrt each other, because their strings differ
+
+ - and wrt any other Name, because Names get uniques with
+ various 'char' tags, but the OccName of Any will
+ get a Unique built with mkTcOccUnique, which has a particular 'char'
+ tag; see Unique.mkTcOccUnique!
+
+Note [Strangely-kinded void TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #959 for more examples
+
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void. Eg.
+
+ length []
+===>
+ length Any (Nil Any)
+
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
+
+This commit uses
+ Any for kind *
+ Any(*->*) for kind *->*
+ etc
+
+\begin{code}
+anyTyConName :: Name
+anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+
+anyTyCon :: TyCon
+anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+
+anyTypeOfKind :: Kind -> Type
+anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+
+anyTyConOfKind :: Kind -> TyCon
+-- Map all superkinds of liftedTypeKind to liftedTypeKind
+anyTyConOfKind kind
+ | isLiftedTypeKind kind = anyTyCon
+ | otherwise = tycon
+ where
+ -- Derive the name from the kind, thus:
+ -- Any(*->*), Any(*->*->*)
+ -- These are names that can't be written by the user,
+ -- and are not allocated in the global name cache
+ str = "Any" ++ showSDoc (pprParendKind kind)
+
+ occ = mkTcOcc str
+ uniq = getUnique occ -- See Note [Uniques of Any]
+ name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
+ tycon = mkAnyTyCon name kind
+\end{code}
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index db2ea1b55ed9f9b33cd5a8d5885f376ae7aafde9..5a80067160b555a78375e6c02a97ed22fc0130ca 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -64,23 +64,14 @@ import TysPrim
-- others:
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module )
+import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
+import Var
+import TyCon
+import TypeRep
import RdrName
import Name
-import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
-import Var
-import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
- mkTupleTyCon, mkAlgTyCon, tyConName,
- TyConParent(NoParentTyCon) )
-
-import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
-
-import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
- TyThing(..) )
-import Coercion ( unsafeCoercionTyCon, symCoercionTyCon,
- transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon )
-import TypeRep ( mkArrowKinds, liftedTypeKind, ubxTupleKind )
-import Unique ( incrUnique, mkTupleTyConUnique,
+import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
+import Unique ( incrUnique, mkTupleTyConUnique,
mkTupleDataConUnique, mkPArrDataConUnique )
import Data.Array
import FastString
@@ -124,12 +115,6 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, intTyCon
, listTyCon
, parrTyCon
- , unsafeCoercionTyCon
- , symCoercionTyCon
- , transCoercionTyCon
- , leftCoercionTyCon
- , rightCoercionTyCon
- , instCoercionTyCon
]
\end{code}
@@ -211,7 +196,6 @@ pcTyCon is_enum is_rec name tyvars cons
(DataTyCon cons is_enum)
NoParentTyCon
is_rec
- True -- All the wired-in tycons have generics
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
@@ -276,7 +260,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
modu = mkTupleModule boxity arity
tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
@@ -293,8 +277,6 @@ mk_tuple boxity arity = (tycon, tuple_con)
(ADataCon tuple_con) BuiltInSyntax
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
- gen_info = True -- Tuples all have generics..
- -- hmm: that's a *lot* of code
unitTyCon :: TyCon
unitTyCon = tupleTyCon Boxed 0
@@ -610,5 +592,3 @@ mkPArrFakeCon arity = data_con
isPArrFakeCon :: DataCon -> Bool
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
\end{code}
-
-
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 7d80db4fcc3df3e49e401a8e74c3e2a05b41980a..4dfe0195a968918dbbb6ad13cf9c22aa519c433a 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -43,7 +43,7 @@ defaults
has_side_effects = False
out_of_line = False
commutable = False
- needs_wrapper = False
+ code_size = { primOpCodeSizeDefault }
can_fail = False
strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
@@ -155,6 +155,7 @@ primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool
primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
primop OrdOp "ord#" GenPrimOp Char# -> Int#
+ with code_size = 0
------------------------------------------------------------------------
section "Int#"
@@ -212,9 +213,12 @@ primop IntNegOp "negateInt#" Monadic Int# -> Int#
primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Add with carry. First member of result is (wrapped) sum;
second member is 0 iff no overflow occured.}
+ with code_size = 2
+
primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Subtract with carry. First member of result is (wrapped) difference;
second member is 0 iff no overflow occured.}
+ with code_size = 2
primop IntGtOp ">#" Compare Int# -> Int# -> Bool
primop IntGeOp ">=#" Compare Int# -> Int# -> Bool
@@ -231,8 +235,11 @@ primop IntLtOp "<#" Compare Int# -> Int# -> Bool
primop IntLeOp "<=#" Compare Int# -> Int# -> Bool
primop ChrOp "chr#" GenPrimOp Int# -> Char#
+ with code_size = 0
primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word#
+ with code_size = 0
+
primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float#
primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double#
@@ -286,6 +293,7 @@ primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word#
in the range 0 to word size - 1 inclusive.}
primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int#
+ with code_size = 0
primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool
primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool
@@ -396,63 +404,72 @@ primop Double2FloatOp "double2Float#" GenPrimOp Double# -> Float#
primop DoubleExpOp "expDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleLogOp "logDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleSqrtOp "sqrtDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinOp "sinDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCosOp "cosDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanOp "tanDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleAsinOp "asinDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAcosOp "acosDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAtanOp "atanDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinhOp "sinhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCoshOp "coshDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanhOp "tanhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoublePowerOp "**##" Dyadic
Double# -> Double# -> Double#
{Exponentiation.}
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp
Double# -> (# Int#, Word#, Word#, Int# #)
@@ -506,58 +523,71 @@ primop Float2IntOp "float2Int#" GenPrimOp Float# -> Int#
primop FloatExpOp "expFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatLogOp "logFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatSqrtOp "sqrtFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinOp "sinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCosOp "cosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanOp "tanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatAsinOp "asinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAcosOp "acosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAtanOp "atanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinhOp "sinhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCoshOp "coshFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanhOp "tanhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatPowerOp "powerFloat#" Dyadic
Float# -> Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double#
@@ -599,6 +629,7 @@ primop WriteArrayOp "writeArray#" GenPrimOp
{Write to specified index of mutable array.}
with
has_side_effects = True
+ code_size = 2 -- card update too
primop SizeofArrayOp "sizeofArray#" GenPrimOp
Array# a -> Int#
@@ -626,6 +657,55 @@ primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp
out_of_line = True
has_side_effects = True
+primop CopyArrayOp "copyArray#" GenPrimOp
+ Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+ {Copy a range of the Array# to the specified region in the MutableArray#.
+ Both arrays must fully contain the specified ranges, but this is not checked.
+ The two arrays must not be the same array in different states, but this is not checked either.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp
+ MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+ {Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
+ Both arrays must fully contain the specified ranges, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CloneArrayOp "cloneArray#" GenPrimOp
+ Array# a -> Int# -> Int# -> Array# a
+ {Return a newly allocated Array# with the specified subrange of the provided Array#.
+ The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
+ MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+ {Return a newly allocated Array# with the specified subrange of the provided Array#.
+ The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop FreezeArrayOp "freezeArray#" GenPrimOp
+ MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
+ {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+ The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop ThawArrayOp "thawArray#" GenPrimOp
+ Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+ {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+ The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
------------------------------------------------------------------------
section "Byte Arrays"
{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
@@ -888,8 +968,10 @@ primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#
#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int#
{Coerce directly from address to int. Strongly deprecated.}
+ with code_size = 0
primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr#
{Coerce directly from int to address. Strongly deprecated.}
+ with code_size = 0
#endif
primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool
@@ -1106,6 +1188,7 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
{Write contents of {\tt MutVar\#}.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall } -- for the write barrier
primop SameMutVarOp "sameMutVar#" GenPrimOp
MutVar# s a -> MutVar# s a -> Bool
@@ -1338,7 +1421,6 @@ primop DelayOp "delay#" GenPrimOp
Int# -> State# s -> State# s
{Sleep specified number of microseconds.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1346,7 +1428,6 @@ primop WaitReadOp "waitRead#" GenPrimOp
Int# -> State# s -> State# s
{Block until input is available on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1354,7 +1435,6 @@ primop WaitWriteOp "waitWrite#" GenPrimOp
Int# -> State# s -> State# s
{Block until output is possible on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1363,7 +1443,6 @@ primop AsyncReadOp "asyncRead#" GenPrimOp
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously read bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1371,7 +1450,6 @@ primop AsyncWriteOp "asyncWrite#" GenPrimOp
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously write bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1379,7 +1457,6 @@ primop AsyncDoProcOp "asyncDoProc#" GenPrimOp
Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously perform procedure (first arg), passing it 2nd arg.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1496,6 +1573,7 @@ primop FinalizeWeakOp "finalizeWeak#" GenPrimOp
primop TouchOp "touch#" GenPrimOp
o -> State# RealWorld -> State# RealWorld
with
+ code_size = { 0 }
has_side_effects = True
------------------------------------------------------------------------
@@ -1515,7 +1593,6 @@ primop MakeStablePtrOp "makeStablePtr#" GenPrimOp
primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp
StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1527,7 +1604,6 @@ primop EqStablePtrOp "eqStablePtr#" GenPrimOp
primop MakeStableNameOp "makeStableName#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
@@ -1555,6 +1631,7 @@ primop ParOp "par#" GenPrimOp
-- Note that Par is lazy to avoid that the sparked thing
-- gets evaluted strictly, which it should *not* be
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall }
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
@@ -1644,6 +1721,8 @@ primtype BCO#
primop AddrToHValueOp "addrToHValue#" GenPrimOp
Addr# -> (# a #)
{Convert an {\tt Addr\#} to a followable type.}
+ with
+ code_size = 0
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
BCO# -> (# a #)
@@ -1738,9 +1817,19 @@ primtype Any a
but never enters a function value.
It's also used to instantiate un-constrained type variables after type
- checking. For example
+ checking. For example, {\tt length} has type
+
+ {\tt length :: forall a. [a] -> Int}
+
+ and the list datacon for the empty list has type
+
+ {\tt [] :: forall a. [a]}
+
+ In order to compose these two terms as {\tt length []} a type
+ application is required, but there is no constraint on the
+ choice. In this situation GHC uses {\tt Any}:
- {\tt length Any []}
+ {\tt length Any ([] Any)}
Annoyingly, we sometimes need {\tt Any}s of other kinds, such as {\tt (* -> *)} etc.
This is a bit like tuples. We define a couple of useful ones here,
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 6c57cb2aa887f2cd73e89d3be67491a832e5ea95..80a47a4ff6eb08fbbe6214ab8569559b0b7f94ff 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -26,7 +26,6 @@ module RnBinds (
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
@@ -306,7 +305,10 @@ rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
valbind' = ValBindsOut anal_binds sigs'
- valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
+ valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+ -- Put the sig uses *after* the bindings
+ -- so that the binders are removed from
+ -- the uses in the sigs
}
rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
@@ -455,7 +457,7 @@ rnBind :: (Name -> [Name]) -- Signature tyvar function
rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
- -- after processing the LHS
+ -- after processing the LHS
, bind_fvs = pat_fvs }))
= setSrcSpan loc $
do { let bndrs = collectPatBinders pat
@@ -475,7 +477,7 @@ rnBind sig_fn trim
, fun_infix = is_infix
, fun_matches = matches }))
-- invariant: no free vars here when it's a FunBind
- = setSrcSpan loc $
+ = setSrcSpan loc $
do { let plain_name = unLoc name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
@@ -583,23 +585,33 @@ a binder.
\begin{code}
rnMethodBinds :: Name -- Class name
-> (Name -> [Name]) -- Signature tyvar function
- -> [Name] -- Names for generic type variables
-> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
-rnMethodBinds cls sig_fn gen_tyvars binds
- = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+rnMethodBinds cls sig_fn binds
+ = do { checkDupRdrNames meth_names
+ -- Check that the same method is not given twice in the
+ -- same instance decl instance C T where
+ -- f x = ...
+ -- g y = ...
+ -- f x = ...
+ -- We must use checkDupRdrNames because the Name of the
+ -- method is the Name of the class selector, whose SrcSpan
+ -- points to the class declaration; and we use rnMethodBinds
+ -- for instance decls too
+
+ ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
+ meth_names = collectMethodBinders binds
do_one (binds,fvs) bind
- = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
+ = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
- -> [Name]
-> LHsBindLR RdrName RdrName
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars
+rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $ do
@@ -608,7 +620,7 @@ rnMethodBind cls sig_fn gen_tyvars
-- We use the selector name as the binder
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
+ mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
let new_group = MatchGroup new_matches placeHolderType
when is_infix $ checkPrecMatch plain_name new_group
@@ -617,24 +629,13 @@ rnMethodBind cls sig_fn gen_tyvars
, bind_fvs = fvs })),
fvs `addOneFV` plain_name)
-- The 'fvs' field isn't used for method binds
- where
- -- Truly gruesome; bring into scope the correct members of the generic
- -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
- rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
- = extendTyVarEnvFVRn gen_tvs $
- rnMatch info match
- where
- tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
- gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
-
- rn_match info match = rnMatch info match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
addErrAt loc (methodBindErr bind)
return (emptyBag, emptyFVs)
-rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
@@ -665,7 +666,12 @@ renameSigs mb_names ok_sig sigs
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
-
+ -- NB: in a class decl, a 'generic' sig is not considered
+ -- equal to an ordinary sig, so we allow, say
+ -- class C a where
+ -- op :: a -> a
+ -- default op :: Eq a => a -> a
+
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
@@ -692,6 +698,13 @@ renameSig mb_names sig@(TypeSig v ty)
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(GenericSig v ty)
+ = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+ ; unless defaultSigs_on (addErr (defaultSigErr sig))
+ ; new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (GenericSig new_v new_ty) }
+
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
@@ -699,7 +712,7 @@ renameSig _ (SpecInstSig ty)
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
-- we use lookupOccRn. If there's both an imported and a local 'f'
--- then the SPECIALISE pragma is ambiguous, unlike alll other signatures
+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
renameSig mb_names sig@(SpecSig v ty inl)
= do { new_v <- case mb_names of
Just {} -> lookupSigOccRn mb_names sig v
@@ -786,9 +799,9 @@ rnGRHS' ctxt (GRHS guards rhs)
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [L _ (ExprStmt _ _ _)] = True
- is_standard_guard _ = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (ExprStmt _ _ _ _)] = True
+ is_standard_guard _ = False
\end{code}
%************************************************************************
@@ -813,6 +826,11 @@ misplacedSigErr (L loc sig)
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+ 2 (ppr sig)
+ , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
+
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
= hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
@@ -827,4 +845,5 @@ nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
nonStdGuardErr guards
= hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
+
\end{code}
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 97f4ab3938d6bee2975ec1e7bbf6e5a9688ccc76..c4ad95a333dff71a461e960bd617a8af6e1b741c 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -12,7 +12,7 @@ module RnEnv (
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields,
- lookupSyntaxName, lookupSyntaxTable,
+ lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
@@ -754,6 +754,17 @@ We treat the orignal (standard) names as free-vars too, because the type checker
checks the type of the user thing against the type of the standard thing.
\begin{code}
+lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
+-- Different to lookupSyntaxName because in the non-rebindable
+-- case we desugar directly rather than calling an existing function
+-- Hence the (Maybe (SyntaxExpr Name)) return type
+lookupIfThenElse
+ = do { rebind <- xoptM Opt_RebindableSyntax
+ ; if not rebind
+ then return (Nothing, emptyFVs)
+ else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
+ ; return (Just (HsVar ite), unitFV ite) } }
+
lookupSyntaxName :: Name -- The standard name
-> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 9bb955131da382bead90c22a982cdcef9205b3a5..88e0462e74859b26d27a7ee778aaa789e5146cb7 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -40,7 +40,7 @@ import RdrName
import LoadIface ( loadInterfaceForName )
import UniqSet
import Data.List
-import Util ( isSingleton )
+import Util ( isSingleton, snocView )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
@@ -224,10 +224,9 @@ rnExpr (HsLet binds expr)
rnLExpr expr `thenM` \ (expr',fvExpr) ->
return (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts body _)
- = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
- rnLExpr body
- ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
+rnExpr (HsDo do_or_lc stmts _)
+ = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
+ ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
@@ -268,13 +267,10 @@ rnExpr (ExprWithTySig expr pty)
rnExpr (HsIf _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
- ; (b1', fvB1) <- rnLExpr b1
- ; (b2', fvB2) <- rnLExpr b2
- ; rebind <- xoptM Opt_RebindableSyntax
- ; if not rebind
- then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
- else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
- ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
+ ; (b1', fvB1) <- rnLExpr b1
+ ; (b2', fvB2) <- rnLExpr b2
+ ; (mb_ite, fvITE) <- lookupIfThenElse
+ ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnExpr (HsType a)
= rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
@@ -444,9 +440,9 @@ convertOpFormsCmd (HsIf f exp c1 c2)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
-convertOpFormsCmd (HsDo ctxt stmts body ty)
- = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
- (convertOpFormsLCmd body) ty
+convertOpFormsCmd (HsDo DoExpr stmts ty)
+ = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
+ -- Mark the HsDo as begin the body of an arrow command
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
@@ -456,8 +452,8 @@ convertOpFormsCmd c = c
convertOpFormsStmt :: StmtLR id id -> StmtLR id id
convertOpFormsStmt (BindStmt pat cmd _ _)
= BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
-convertOpFormsStmt (ExprStmt cmd _ _)
- = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (ExprStmt cmd _ _ _)
+ = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
= stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
convertOpFormsStmt stmt = stmt
@@ -498,14 +494,10 @@ methodNamesCmd (HsPar c) = methodNamesLCmd c
methodNamesCmd (HsIf _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsLet _ c) = methodNamesLCmd c
-
-methodNamesCmd (HsDo _ stmts body _)
- = methodNamesStmts stmts `plusFV` methodNamesLCmd body
-
-methodNamesCmd (HsApp c _) = methodNamesLCmd c
-
-methodNamesCmd (HsLam match) = methodNamesMatch match
+methodNamesCmd (HsLet _ c) = methodNamesLCmd c
+methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
+methodNamesCmd (HsApp c _) = methodNamesLCmd c
+methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
@@ -541,14 +533,14 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR Name Name -> FreeVars
-methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
+methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt _) = emptyFVs
-methodNamesStmt (ParStmt _) = emptyFVs
-methodNamesStmt (TransformStmt {}) = emptyFVs
-methodNamesStmt (GroupStmt {}) = emptyFVs
- -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
+methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
+methodNamesStmt (TransStmt {}) = emptyFVs
+ -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
-- here so we just do what's convenient
\end{code}
@@ -591,14 +583,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
\begin{code}
rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rnBracket (VarBr n) = do { name <- lookupOccRn n
- ; this_mod <- getModule
- ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
- do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
- ; return () } -- only way that is going to happen
- ; return (VarBr name, unitFV name) }
- where
- msg = ptext (sLit "Need interface for Template Haskell quoted Name")
+rnBracket (VarBr n)
+ = do { name <- lookupOccRn n
+ ; this_mod <- getModule
+ ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes
+ do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and
+ ; return () } -- this is the only way that is going
+ -- to happen
+ ; return (VarBr name, unitFV name) }
+ where
+ msg = ptext (sLit "Need interface for Template Haskell quoted Name")
rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
@@ -628,7 +622,8 @@ rnBracket (DecBrL decls)
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
- ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
+ ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
+ ppr (duUses (tcg_dus tcg_env))))
; return (DecBrG group', duUses (tcg_dus tcg_env)) }
rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
@@ -642,44 +637,74 @@ 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'
+ -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
+ -- Here "gd" is a guard
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
- ; (bind_op, fvs1) <- lookupSyntaxName bindMName
- ; (fail_op, fvs2) <- lookupSyntaxName failMName
+ ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+ ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
@@ -687,15 +712,13 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
-rnStmt ctxt (L loc (LetStmt binds)) thing_inside
- = do { checkLetStmt ctxt binds
- ; rnLocalBindsAndThen binds $ \binds' -> do
+rnStmt _ (L loc (LetStmt binds)) thing_inside
+ = do { rnLocalBindsAndThen binds $ \binds' -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
; return (([L loc (LetStmt binds')], thing), fvs) } }
rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
- = do { checkRecStmt ctxt
-
+ = do {
-- Step1: Bring all the binders of the mdo into scope
-- (Remember that this also removes the binders from the
-- finally-returned free-vars.)
@@ -710,9 +733,9 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
; (thing, fvs_later) <- thing_inside bndrs
- ; (return_op, fvs1) <- lookupSyntaxName returnMName
- ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
- ; (bind_op, fvs3) <- lookupSyntaxName bindMName
+ ; (return_op, fvs1) <- lookupStmtName ctxt returnMName
+ ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
+ ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
; let
-- Step 2: Fill in the fwd refs.
-- The segments are all singletons, but their fwd-ref
@@ -737,57 +760,51 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-rnStmt ctxt (L loc (ParStmt segs)) thing_inside
- = do { checkParStmt ctxt
- ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
- ; return (([L loc (ParStmt segs')], thing), fvs) }
-
-rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
- = do { checkTransformStmt ctxt
-
- ; (using', fvs1) <- rnLExpr using
-
- ; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
- do { (by', fvs_by) <- case by of
- Nothing -> return (Nothing, emptyFVs)
- Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
- ; (thing, fvs_thing) <- thing_inside bndrs
- ; let fvs = fvs_by `plusFV` fvs_thing
- used_bndrs = filter (`elemNameSet` fvs) bndrs
- -- The paper (Fig 5) has a bug here; we must treat any free varaible of
- -- the "thing inside", **or of the by-expression**, as used
- ; return ((by', used_bndrs, thing), fvs) }
-
- ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
- fvs1 `plusFV` fvs2) }
-
-rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
- = do { checkTransformStmt ctxt
-
- -- Rename the 'using' expression in the context before the transform is begun
- ; (using', fvs1) <- case using of
- Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
- Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
- ; return (Right e', fvs) }
+rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
+ = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
+ ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
+ ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+ ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
+ ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
+ , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+ , trS_using = using })) thing_inside
+ = do { -- Rename the 'using' expression in the context before the transform is begun
+ (using', fvs1) <- case form of
+ GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
+ ; return (noLoc e, fvs) }
+ _ -> rnLExpr using
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
+ -- The paper (Fig 5) has a bug here; we must treat any free varaible
+ -- of the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
- ; let all_fvs = fvs1 `plusFV` fvs2
+ -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+ ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+ ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
+ ; (fmap_op, fvs5) <- case form of
+ ThenForm -> return (noSyntaxExpr, emptyFVs)
+ _ -> lookupStmtName ctxt fmapName
+
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ `plusFV` fvs4 `plusFV` fvs5
bndr_map = used_bndrs `zip` used_bndrs
- -- See Note [GroupStmt binder map] in HsExpr
+ -- See Note [TransStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
- ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
-
+ ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+ , trS_by = by', trS_using = using', trS_form = form
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op })], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
@@ -823,6 +840,27 @@ rnParallelStmts ctxt segs thing_inside
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
<+> quotes (ppr (head vs)))
+
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
+-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+lookupStmtName ctxt n
+ = case ctxt of
+ ListComp -> not_rebindable
+ PArrComp -> not_rebindable
+ ArrowExpr -> not_rebindable
+ PatGuard {} -> not_rebindable
+
+ DoExpr -> rebindable
+ MDoExpr -> rebindable
+ MonadComp -> rebindable
+ GhciStmt -> rebindable -- I suppose?
+
+ ParStmtCtxt c -> lookupStmtName c n -- Look inside to
+ TransStmtCtxt c -> lookupStmtName c n -- the parent context
+ where
+ rebindable = lookupSyntaxName n
+ not_rebindable = return (HsVar n, emptyFVs)
\end{code}
Note [Renaming parallel Stmts]
@@ -904,9 +942,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR Name RdrName, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
- -- this is actually correct
- emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
+ = return [(L loc (ExprStmt expr a b c), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
+ = return [(L loc (LastStmt expr a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
= do
@@ -929,13 +969,10 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
= rn_rec_stmts_lhs fix_env stmts
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
-rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
@@ -960,11 +997,17 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
+rn_rec_stmt _ (L loc (LastStmt expr _)) _
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (ret_op, fvs1) <- lookupSyntaxName returnMName
+ ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+ L loc (LastStmt expr' ret_op))] }
+
+rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
= rnLExpr expr `thenM` \ (expr', fvs) ->
lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (ExprStmt expr' then_op placeHolderType))]
+ L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
= rnLExpr expr `thenM` \ (expr', fv_expr) ->
@@ -994,11 +1037,8 @@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
-rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
-
-rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
+rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
@@ -1144,44 +1184,151 @@ program.
%************************************************************************
\begin{code}
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt
+ = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
-----------------------
--- Checking when a particular Stmt is ok
-checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
-checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-checkLetStmt _ctxt _binds = return ()
- -- We do not allow implicit-parameter bindings in a parallel
- -- list comprehension. I'm not sure what it might mean.
+okEmpty :: HsStmtContext a -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _ = False
----------
-checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
-checkRecStmt DoExpr = return () -- and in 'do'
-checkRecStmt ctxt = addErr msg
- where
- msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
+emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
+emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
----------
-checkParStmt :: HsStmtContext Name -> RnM ()
-checkParStmt _
- = do { parallel_list_comp <- xoptM Opt_ParallelListComp
- ; checkErr parallel_list_comp msg }
+----------------------
+checkLastStmt :: HsStmtContext Name
+ -> LStmt RdrName
+ -> RnM (LStmt RdrName)
+checkLastStmt ctxt lstmt@(L loc stmt)
+ = case ctxt of
+ ListComp -> check_comp
+ MonadComp -> check_comp
+ PArrComp -> check_comp
+ ArrowExpr -> check_do
+ DoExpr -> check_do
+ MDoExpr -> check_do
+ _ -> check_other
where
- msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
+ check_do -- Expect ExprStmt, and change it to LastStmt
+ = case stmt of
+ ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
+ LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
+ -- LastStmt directly (unlike the parser)
+ _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+ last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
+ <+> ptext (sLit "must be an expression"))
+
+ check_comp -- Expect LastStmt; this should be enforced by the parser!
+ = case stmt of
+ LastStmt {} -> return lstmt
+ _ -> pprPanic "checkLastStmt" (ppr lstmt)
+
+ check_other -- Behave just as if this wasn't the last stmt
+ = do { checkStmt ctxt lstmt; return lstmt }
----------
-checkTransformStmt :: HsStmtContext Name -> RnM ()
-checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
- -- desugarer will break when we come to operate on a parallel array
- = do { transform_list_comp <- xoptM Opt_TransformListComp
- ; checkErr transform_list_comp msg }
- where
- msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
-checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt ctxt = addErr msg
+-- Checking when a particular Stmt is ok
+checkStmt :: HsStmtContext Name
+ -> LStmt RdrName
+ -> RnM ()
+checkStmt ctxt (L _ stmt)
+ = do { dflags <- getDOpts
+ ; case okStmt dflags ctxt stmt of
+ Nothing -> return ()
+ Just extra -> addErr (msg $$ extra) }
where
- msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
+ msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
+ , ptext (sLit "in") <+> pprAStmtContext ctxt ]
+
+pprStmtCat :: Stmt a -> SDoc
+pprStmtCat (TransStmt {}) = ptext (sLit "transform")
+pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
+pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
+pprStmtCat (BindStmt {}) = ptext (sLit "binding")
+pprStmtCat (LetStmt {}) = ptext (sLit "let")
+pprStmtCat (RecStmt {}) = ptext (sLit "rec")
+pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
+
+------------
+isOK, notOK :: Maybe SDoc
+isOK = Nothing
+notOK = Just empty
+
+okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+ :: DynFlags -> HsStmtContext Name
+ -> Stmt RdrName -> Maybe SDoc
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to an generic error message
+
+okStmt dflags ctxt stmt
+ = case ctxt of
+ PatGuard {} -> okPatGuardStmt stmt
+ ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
+ DoExpr -> okDoStmt dflags ctxt stmt
+ MDoExpr -> okDoStmt dflags ctxt stmt
+ ArrowExpr -> okDoStmt dflags ctxt stmt
+ GhciStmt -> okDoStmt dflags ctxt stmt
+ ListComp -> okCompStmt dflags ctxt stmt
+ MonadComp -> okCompStmt dflags ctxt stmt
+ PArrComp -> okPArrStmt dflags ctxt stmt
+ TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+
+-------------
+okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
+okPatGuardStmt stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+-------------
+okParStmt dflags ctxt stmt
+ = case stmt of
+ LetStmt (HsIPBinds {}) -> notOK
+ _ -> okStmt dflags ctxt stmt
+
+----------------
+okDoStmt dflags ctxt stmt
+ = case stmt of
+ RecStmt {}
+ | Opt_DoRec `xopt` dflags -> isOK
+ | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec'
+ | otherwise -> Just (ptext (sLit "Use -XDoRec"))
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ _ -> notOK
+
+----------------
+okCompStmt dflags _ stmt
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ ParStmt {}
+ | Opt_ParallelListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransStmt {}
+ | Opt_TransformListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+ RecStmt {} -> notOK
+ LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
+
+----------------
+okPArrStmt dflags _ stmt
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ ParStmt {}
+ | Opt_ParallelListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransStmt {} -> notOK
+ RecStmt {} -> notOK
+ LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 9226cb4668588dc9addc6ca080650dd7ca738a8e..478ba326556afbd030303ac4175414678d92dc38 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -11,9 +11,7 @@ module RnHsSyn(
extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
-- Free variables
- hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs,
-
- maybeGenericMatch
+ hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
) where
#include "HsVersions.h"
@@ -66,7 +64,6 @@ extractHsTyNames ty
get (HsParTy ty) = getl ty
get (HsBangTy _ ty) = getl ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
- get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _ fvs _) = fvs
get (HsQuasiQuoteTy {}) = emptyNameSet
@@ -120,10 +117,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars
hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
-hsSigFVs _ = emptyFVs
+hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
+hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
+hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
+hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
+hsSigFVs _ = emptyFVs
----------------
conDeclFVs :: LConDecl Name -> FreeVars
@@ -144,24 +142,3 @@ conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details))
bangTyFVs :: LHsType Name -> FreeVars
bangTyFVs bty = extractHsTyNames (getBangType bty)
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{A few functions on generic defintions
-%* *
-%************************************************************************
-
-These functions on generics are defined over Matches Name, which is
-why they are here and not in HsMatches.
-
-\begin{code}
-maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name)
- -- Tells whether a Match is for a generic definition
- -- and extract the type from a generic match and put it at the front
-
-maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss))
- = Just (ty, L loc (Match pats sig_ty grhss))
-
-maybeGenericMatch _ = Nothing
-\end{code}
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 3a20ac48b6c02a1101431763178647c58755f920..46058c4677f7611e6e29897324b84c404ddaf06e 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -18,7 +18,7 @@ import HsSyn
import TcEnv ( isBrackStage )
import RnEnv
import RnHsDoc ( rnHsDoc )
-import IfaceEnv ( ifaceExportNames )
+import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
import TcRnMonad
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 76be4519d301d74f5611dc7ce895976b8ad6baa8..844a1f90c24d1dbc0c725c91a8d86e78af97c2b3 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -367,10 +367,6 @@ rnPatAndThen mk (TuplePat pats boxed _)
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed placeHolderType) }
-rnPatAndThen _ (TypePat ty)
- = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty
- ; return (TypePat ty') }
-
#ifndef GHCI
rnPatAndThen _ p@(QuasiQuotePat {})
= pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 725baeb04f72fe77c1aad47cfaed23742977e32e..54dc378dd5572d6cf20b364ceaff1ca808275994 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -17,14 +17,14 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
-import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
+import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
+ lookupOccRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
@@ -443,24 +443,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_names `thenM_`
- -- Check that the same method is not given twice in the
- -- same instance decl instance C T where
- -- f x = ...
- -- g y = ...
- -- f x = ...
- -- We must use checkDupRdrNames because the Name of the
- -- method is the Name of the class selector, whose SrcSpan
- -- points to the class declaration
-
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
rnMethodBinds cls (\_ -> []) -- No scoped tyvars
- [] mbinds
+ mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the associated types
-- The typechecker (not the renamer) checks that all
@@ -826,15 +815,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
; (mbinds', meth_fvs)
- <- extendTyVarEnvForMethodBinds tyvars' $ do
- { name_env <- getLocalRdrEnv
- ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ <- extendTyVarEnvForMethodBinds tyvars' $
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
- ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
- ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+ rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
@@ -1252,4 +1237,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 138ffa29f2b2e85a5b1fcea37ec42ed2aca6d823..be90d7d0a99760447e7e54073c07e962abbbeb91 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -31,7 +31,7 @@ import RnEnv
import TcRnMonad
import RdrName
import PrelNames
-import TypeRep ( funTyConName )
+import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
@@ -139,13 +139,6 @@ rnHsType doc (HsRecTy flds)
= do { flds' <- rnConDeclFields doc flds
; return (HsRecTy flds') }
-rnHsType _ (HsNumTy i)
- | i == 1 = return (HsNumTy i)
- | otherwise = addErr err_msg >> return (HsNumTy i)
- where
- err_msg = ptext (sLit "Only unit numeric type pattern is valid")
-
-
rnHsType doc (HsFunTy ty1 ty2) = do
ty1' <- rnLHsType doc ty1
-- Might find a for-all as the arg of a function type
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 523431fec0829a348de260588c7702c13ac37f6a..5bec8f0c3d7705dbaf78cce28f9886013004477d 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -207,6 +207,7 @@ do_one env (id, rhs)
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE _ (Type t) = Type t
+tryForCSE _ (Coercion c) = Coercion c
tryForCSE env expr = case lookupCSEnv env expr' of
Just smaller_expr -> smaller_expr
Nothing -> expr'
@@ -215,6 +216,7 @@ tryForCSE env expr = case lookupCSEnv env expr' of
cseExpr :: CSEnv -> CoreExpr -> CoreExpr
cseExpr _ (Type t) = Type t
+cseExpr _ (Coercion co) = Coercion co
cseExpr _ (Lit lit) = Lit lit
cseExpr env (Var v) = Var (lookupSubst env v)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index c527d820c569e3b3c272307899a207880f64cccf..6ddcff2b26559611eef29d1bad5ec46ae609cffc 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -370,13 +370,21 @@ getCoreToDo dflags
simpl_phase phase names iter
= CoreDoPasses
- [ maybe_strictness_before phase
+ $ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
- , maybe_rule_check (Phase phase)
- ]
+ , maybe_rule_check (Phase phase) ]
+
+ -- Vectorisation can introduce a fair few common sub expressions involving
+ -- DPH primitives. For example, see the Reverse test from dph-examples.
+ -- We need to eliminate these common sub expressions before their definitions
+ -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
+ -- so we also run simpl_gently to inline them.
+ ++ (if dopt Opt_Vectorise dflags && phase == 3
+ then [CoreCSE, simpl_gently]
+ else [])
vectorisation
= runWhen (dopt Opt_Vectorise dflags) $
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index b9f44c95c12854e9c54f1be1d5d71b62daf639c0..48daf7853b422c41c8075c2b4e39830e73346912 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -126,14 +126,15 @@ fiExpr :: FloatingBinds -- Binds we're trying to drop
-> CoreExprWithFVs -- Input expr
-> CoreExpr -- Result
-fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
-
-fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
- Type ty
-fiExpr to_drop (_, AnnCast expr co)
- = Cast (fiExpr to_drop expr) co -- Just float in past coercion
-
-fiExpr _ (_, AnnLit lit) = Lit lit
+fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit
+fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
+fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
+fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co)
+fiExpr to_drop (_, AnnCast expr (fvs_co, co))
+ = mkCoLets' (drop_here ++ co_drop) $
+ Cast (fiExpr e_drop expr) co
+ where
+ [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop
\end{code}
Applications: we do float inside applications, mainly because we
@@ -198,7 +199,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
go seen_one_shot_id [] = seen_one_shot_id
go seen_one_shot_id (b:bs)
- | isTyCoVar b = go seen_one_shot_id bs
+ | isTyVar b = go seen_one_shot_id bs
| isOneShotBndr b = go True bs
| otherwise = False -- Give up at a non-one-shot Id
\end{code}
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index 2a51a2100e5a546e397cea5fd2122b071c0bf989..e5db7d93cefaa538b2e4ccad3aa47aa7d56840b9 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -225,6 +225,7 @@ floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
-----------------
floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co)
floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
floatExpr lvl (App e a)
diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 2b190621d658b75fc7507af77d85898001434f47..fe1f7585516d7548e2e85cf5a701048ea1b9e1c8 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -199,6 +199,7 @@ libCase :: LibCaseEnv
libCase env (Var v) = libCaseId env v
libCase _ (Lit lit) = Lit lit
libCase _ (Type ty) = Type ty
+libCase _ (Coercion co) = Coercion co
libCase env (App fun arg) = App (libCase env fun) (libCase env arg)
libCase env (Note note body) = Note note (libCase env body)
libCase env (Cast e co) = Cast (libCase env e) co
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 7692b628abef16a25f7a4131a5b87dbdb039ee79..ba7d19295b83da21329ef12b160828fb3e4698a5 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -19,17 +19,18 @@ module OccurAnal (
import CoreSyn
import CoreFVs
-import Type ( tyVarsOfType )
-import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
-import Coercion ( CoercionI(..), mkSymCoI )
+import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
import Id
import NameEnv
import NameSet
import Name ( Name, localiseName )
import BasicTypes
+import Coercion
+
import VarSet
import VarEnv
-import Var ( varUnique )
+import Var
+
import Maybes ( orElse )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
@@ -97,7 +98,7 @@ occAnalBind :: OccEnv -- The incoming OccEnv
[CoreBind])
occAnalBind env _ (NonRec binder rhs) body_usage
- | isTyCoVar binder -- A type let; we don't gather usage info
+ | isTyVar binder -- A type let; we don't gather usage info
= (body_usage, [NonRec binder rhs])
| not (binder `usedIn` body_usage) -- It's not mentioned
@@ -381,7 +382,7 @@ occAnalBind _ env (Rec pairs) body_usage
make_node (bndr, rhs)
= (details, varUnique bndr, keysUFM out_edges)
- where
+ where
details = ND { nd_bndr = bndr, nd_rhs = rhs'
, nd_uds = rhs_usage3, nd_inl = inl_fvs}
@@ -872,33 +873,27 @@ occAnal :: OccEnv
-> (UsageDetails, -- Gives info only about the "interesting" Ids
CoreExpr)
-occAnal _ (Type t) = (emptyDetails, Type t)
-occAnal env (Var v) = (mkOneOcc env v False, Var v)
+occAnal _ expr@(Type _) = (emptyDetails, expr)
+occAnal _ expr@(Lit _) = (emptyDetails, expr)
+occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
-- But that went wrong right after specialisation, when
-- the *occurrences* of the overloaded function didn't have any
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
-\end{code}
-We regard variables that occur as constructor arguments as "dangerousToDup":
-
-\begin{verbatim}
-module A where
-f x = let y = expensive x in
- let z = (True,y) in
- (case z of {(p,q)->q}, case z of {(p,q)->q})
-\end{verbatim}
-
-We feel free to duplicate the WHNF (True,y), but that means
-that y may be duplicated thereby.
+occAnal _ (Coercion co)
+ = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
+ -- See Note [Gather occurrences of coercion veriables]
+\end{code}
-If we aren't careful we duplicate the (expensive x) call!
-Constructors are rather like lambdas in this way.
+Note [Gather occurrences of coercion veriables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather info about what coercion variables appear, so that
+we can sort them into the right place when doing dependency analysis.
\begin{code}
-occAnal _ expr@(Lit _) = (emptyDetails, expr)
\end{code}
\begin{code}
@@ -914,7 +909,10 @@ occAnal env (Note note body)
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- (markManyIf (isRhsEnv env) usage, Cast expr' co)
+ let usage1 = markManyIf (isRhsEnv env) usage
+ usage2 = addIdOccs usage1 (coVarsOfCo co)
+ -- See Note [Gather occurrences of coercion veriables]
+ in (usage2, Cast expr' co)
-- If we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
@@ -929,7 +927,7 @@ occAnal env app@(App _ _)
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-occAnal env (Lam x body) | isTyCoVar x
+occAnal env (Lam x body) | isTyVar x
= case occAnal env body of { (body_usage, body') ->
(body_usage, Lam x body')
}
@@ -1021,6 +1019,18 @@ occAnalArgs env args
Applications are dealt with specially because we want
the "build hack" to work.
+Note [Arguments of let-bound constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = let y = expensive x in
+ let z = (True,y) in
+ (case z of {(p,q)->q}, case z of {(p,q)->q})
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
\begin{code}
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr])
@@ -1036,6 +1046,7 @@ occAnalApp env (Var fun, args)
-- arguments are just variables, or trivial expressions.
--
-- This is the *whole point* of the isRhsEnv predicate
+ -- See Note [Arguments of let-bound constructors]
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
@@ -1146,7 +1157,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
where
(body_usg', tagged_bndr) = tagBinder body_usg bndr
rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
- rhs = mkCoerceI co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+ rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
\end{code}
@@ -1355,7 +1366,7 @@ extendFvs env s
data ProxyEnv -- See Note [ProxyEnv]
= PE (IdEnv -- Domain = scrutinee variables
(Id, -- The scrutinee variable again
- [(Id,CoercionI)])) -- The case binders that it maps to
+ [(Id,Coercion)])) -- The case binders that it maps to
VarSet -- Free variables of both range and domain
\end{code}
@@ -1572,7 +1583,7 @@ binder-swap unconditionally and still get occurrence analysis
information right.
\begin{code}
-extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
+extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
-- (extendPE x co y) typically arises from
-- case (x |> co) of y { ... }
-- It extends the proxy env with the binding
@@ -1585,7 +1596,7 @@ extendProxyEnv pe scrut co case_bndr
env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
single cb_co = (scrut1, [cb_co])
add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
- fvs2 = fvs1 `unionVarSet` freeVarsCoI co
+ fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co
`extendVarSet` case_bndr
`extendVarSet` scrut1
@@ -1596,7 +1607,7 @@ extendProxyEnv pe scrut co case_bndr
-- Also we don't want any INLINE or NOINLINE pragmas!
-----------
-type ProxyBind = (Id, Id, CoercionI)
+type ProxyBind = (Id, Id, Coercion)
-- (scrut variable, case-binder variable, coercion)
getProxies :: OccEnv -> Id -> Bag ProxyBind
@@ -1607,7 +1618,7 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
= -- pprTrace "wrapProxies" (ppr case_bndr) $
go_fwd case_bndr
where
- fwd_pe :: IdEnv (Id, CoercionI)
+ fwd_pe :: IdEnv (Id, Coercion)
fwd_pe = foldVarEnv add1 emptyVarEnv pe
where
add1 (x,ycos) env = foldr (add2 x) env ycos
@@ -1621,23 +1632,23 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
go_fwd' case_bndr
| Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
- = unitBag (scrut, case_bndr, mkSymCoI co)
+ = unitBag (scrut, case_bndr, mkSymCo co)
`unionBags` go_fwd scrut
`unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
, cb /= case_bndr]
| otherwise
= emptyBag
- lookup_bwd :: Id -> [(Id, CoercionI)]
+ lookup_bwd :: Id -> [(Id, Coercion)]
-- Return case_bndrs that are connected to scrut
lookup_bwd scrut = case lookupVarEnv pe scrut of
Nothing -> []
Just (_, cb_cos) -> cb_cos
- go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
+ go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
- go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
+ go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
go_bwd1 scrut (case_bndr, co)
= -- pprTrace "go_bwd1" (ppr case_bndr) $
unitBag (case_bndr, scrut, co)
@@ -1652,9 +1663,9 @@ mkAltEnv env scrut cb
where
pe = occ_proxy env
pe' = case scrut of
- Var v -> extendProxyEnv pe v (IdCo (idType v)) cb
- Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
- _other -> trimProxyEnv pe [cb]
+ Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb
+ Cast (Var v) co -> extendProxyEnv pe v co cb
+ _other -> trimProxyEnv pe [cb]
-----------
trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
@@ -1675,12 +1686,7 @@ trimProxyEnv (PE pe fvs) bndrs
trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
| otherwise = (scrut, filterOut discard cb_cos)
discard (cb,co) = bndr_set `intersectsVarSet`
- extendVarSet (freeVarsCoI co) cb
-
------------
-freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI (IdCo t) = tyVarsOfType t
-freeVarsCoI (ACo co) = tyVarsOfType co
+ extendVarSet (tyCoVarsOfCo co) cb
\end{code}
@@ -1747,7 +1753,7 @@ tagBinder usage binder
setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
- | isTyCoVar bndr = bndr
+ | isTyVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
_ -> setIdOccInfo bndr NoOccInfo
diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs
index d39805574493767139ac719814765cb615076f2c..61182895cf84da31913b04e0fbaca50af7da5fb6 100644
--- a/compiler/simplCore/SAT.lhs
+++ b/compiler/simplCore/SAT.lhs
@@ -56,6 +56,7 @@ import Var
import CoreSyn
import CoreUtils
import Type
+import Coercion
import Id
import Name
import VarEnv
@@ -112,7 +113,7 @@ satBind (Rec pairs) interesting_ids = do
return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
\end{code}
\begin{code}
-data App = VarApp Id | TypeApp Type
+data App = VarApp Id | TypeApp Type | CoApp Coercion
data Staticness a = Static a | NotStatic
type IdAppInfo = (Id, SATInfo)
@@ -133,6 +134,7 @@ pprSATInfo staticness = hcat $ map pprStaticness staticness
pprStaticness :: Staticness App -> SDoc
pprStaticness (Static (VarApp _)) = ptext (sLit "SV")
pprStaticness (Static (TypeApp _)) = ptext (sLit "ST")
+pprStaticness (Static (CoApp _)) = ptext (sLit "SC")
pprStaticness NotStatic = ptext (sLit "NS")
@@ -142,7 +144,8 @@ mergeSATInfo _ [] = []
mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps
mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps
mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps
-mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `coreEqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps
mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ")
<> ptext (sLit "Right:") <> pprSATInfo r
@@ -154,9 +157,9 @@ mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
bindersToSATInfo :: [Id] -> SATInfo
bindersToSATInfo vs = map (Static . binderToApp) vs
- where binderToApp v = if isId v
- then VarApp v
- else TypeApp $ mkTyVarTy v
+ where binderToApp v | isId v = VarApp v
+ | isTyVar v = TypeApp $ mkTyVarTy v
+ | otherwise = CoApp $ mkCoVarCo v
finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Nothing id_sat_info = id_sat_info
@@ -195,9 +198,10 @@ satExpr (App fn arg) interesting_ids = do
-- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
in case arg of
- Type t -> satRemainderWithStaticness $ Static (TypeApp t)
- Var v -> satRemainderWithStaticness $ Static (VarApp v)
- _ -> satRemainderWithStaticness $ NotStatic
+ Type t -> satRemainderWithStaticness $ Static (TypeApp t)
+ Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+ Var v -> satRemainderWithStaticness $ Static (VarApp v)
+ _ -> satRemainderWithStaticness $ NotStatic
where
boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
boring fn' sat_info_fn app_info =
@@ -229,6 +233,9 @@ satExpr (Note note expr) interesting_ids = do
satExpr ty@(Type _) _ = do
return (ty, emptyIdSATInfo, Nothing)
+
+satExpr co@(Coercion _) _ = do
+ return (co, emptyIdSATInfo, Nothing)
satExpr (Cast expr coercion) interesting_ids = do
(expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 6871faa79832aa66a7b3c801952575e88e8ef7b8..21dca615c3a1d230bfde2c8ff1b0c9e2534f94d6 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -243,6 +243,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well.
\begin{code}
lvlExpr _ _ ( _, AnnType ty) = return (Type ty)
+lvlExpr _ _ ( _, AnnCoercion co) = return (Coercion co)
lvlExpr _ env (_, AnnVar v) = return (lookupVar env v)
lvlExpr _ _ (_, AnnLit lit) = return (Lit lit)
@@ -287,7 +288,7 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr) = do
expr' <- lvlExpr ctxt_lvl env expr
return (Note note expr')
-lvlExpr ctxt_lvl env (_, AnnCast expr co) = do
+lvlExpr ctxt_lvl env (_, AnnCast expr (_, co)) = do
expr' <- lvlExpr ctxt_lvl env expr
return (Cast expr' co)
@@ -414,7 +415,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e)
= do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
; return (Note n e') }
-lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e (_, co))
= do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
; return (Cast e' co) }
@@ -423,7 +424,9 @@ lvlMFE True ctxt_lvl env e@(_, AnnCase {})
= lvlExpr ctxt_lvl env e -- Don't share cases
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
- | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
+ | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
+ -- This includes coercions, which we don't
+ -- want to float anyway
|| notWorthFloating ann_expr abs_vars
|| not good_destination
= -- Don't float it out
@@ -491,6 +494,7 @@ notWorthFloating e abs_vars
go (_, AnnCast e _) n = go e n
go (_, AnnApp e arg) n
| (_, AnnType {}) <- arg = go e n
+ | (_, AnnCoercion {}) <- arg = go e n
| n==0 = False
| is_triv arg = go e (n-1)
| otherwise = False
@@ -500,6 +504,7 @@ notWorthFloating e abs_vars
is_triv (_, AnnVar {}) = True -- (ie not worth floating)
is_triv (_, AnnCast e _) = is_triv e
is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
+ is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
is_triv _ = False
\end{code}
@@ -563,7 +568,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isTyCoVar bndr -- Don't do anything for TyVar binders
+ | isTyVar bndr -- Don't do anything for TyVar binders
-- (simplifier gets rid of them pronto)
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
@@ -883,7 +888,7 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
(False, True) -> False
_ -> v1 <= v2 -- Same family
- is_tv v = isTyCoVar v && not (isCoVar v)
+ is_tv v = isTyVar v
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
@@ -914,9 +919,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
absVarsOf id_env v
| isId v = [av2 | av1 <- lookup_avs v
, av2 <- add_tyvars av1]
- | isCoVar v = add_tyvars v
- | otherwise = [v]
-
+ | otherwise = ASSERT( isTyVar v ) [v]
where
lookup_avs v = case lookupVarEnv id_env v of
Just (abs_vars, _) -> abs_vars
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index d9eea39ed69e7bb1d76820ee0af5e4e532dc9086..677a1e9d02cc60edd7a2f8a5d18e824099bd8e7c 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -16,7 +16,7 @@ module SimplEnv (
-- Environments
SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
- mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
+ mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules,
@@ -24,8 +24,10 @@ module SimplEnv (
SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addBndrRules,
- substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substTy, substTyVar, getTvSubst,
+ getCvSubst, substCo, substCoVar,
+ mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -49,9 +51,10 @@ import Id
import MkCore
import TysWiredIn
import qualified CoreSubst
-import qualified Type ( substTy, substTyVarBndr, substTyVar )
+import qualified Type
import Type hiding ( substTy, substTyVarBndr, substTyVar )
-import Coercion
+import qualified Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
import BasicTypes
import MonadUtils
import Outputable
@@ -107,8 +110,9 @@ data SimplEnv
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
-- The current substitution
- seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
- seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
+ seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
+ seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion
+ seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
@@ -143,13 +147,14 @@ data SimplSR
= DoneEx OutExpr -- Completed term
| DoneId OutId -- Completed term variable
| ContEx TvSubstEnv -- A suspended substitution
+ CvSubstEnv
SimplIdSubst
InExpr
instance Outputable SimplSR where
ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
- ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
+ ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
ppr (filter_env tv), ppr (filter_env id) -}]
-- where
-- fvs = exprFreeVars e
@@ -227,6 +232,7 @@ mkSimplEnv mode
, seInScope = init_in_scope
, seFloats = emptyFloats
, seTvSubst = emptyVarEnv
+ , seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
@@ -273,12 +279,17 @@ setEnclosingCC env cc = env {seCC = cc}
---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
- = env {seIdSubst = extendVarEnv subst var res}
+ = ASSERT2( isId var && not (isCoVar var), ppr var )
+ env {seIdSubst = extendVarEnv subst var res}
extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
= env {seTvSubst = extendVarEnv subst var res}
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
+ = env {seCvSubst = extendVarEnv subst var res}
+
---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope env = seInScope env
@@ -318,13 +329,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v
---------------------
zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
-setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
-setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
mkContEx :: SimplEnv -> InExpr -> SimplSR
-mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
\end{code}
@@ -503,7 +514,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
Just (DoneId v) -> DoneId (refine in_scope v)
Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
Just res -> res -- DoneEx non-var, or ContEx
- where
-- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in
@@ -549,7 +559,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBinder env bndr
- | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
+ | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
| otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
@@ -586,9 +596,17 @@ simplRecBndrs env@(SimplEnv {}) ids
; seqIds ids1 `seq` return env1 }
---------------
-substIdBndr :: SimplEnv
- -> InBndr -- Env and binder to transform
- -> (SimplEnv, OutBndr)
+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr env bndr
+ | isCoVar bndr = substCoVarBndr env bndr
+ | otherwise = substNonCoVarIdBndr env bndr
+
+---------------
+substNonCoVarIdBndr
+ :: SimplEnv
+ -> InBndr -- Env and binder to transform
+ -> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
-- * Type substituted
@@ -606,10 +624,10 @@ substIdBndr :: SimplEnv
-- Similar to CoreSubst.substIdBndr, except that
-- the type of id_subst differs
-- all fragile info is zapped
-
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
- old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
+substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+ old_id
+ = ASSERT2( not (isCoVar old_id), ppr old_id )
+ (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
id1 = uniqAway in_scope old_id
@@ -714,6 +732,10 @@ getTvSubst :: SimplEnv -> TvSubst
getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
= mkTvSubst in_scope tv_env
+getCvSubst :: SimplEnv -> CvSubst
+getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = CvSubst in_scope tv_env cv_env
+
substTy :: SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getTvSubst env) ty
@@ -724,7 +746,19 @@ substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr env tv
= case Type.substTyVarBndr (getTvSubst env) tv of
(TvSubst in_scope' tv_env', tv')
- -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+ = case Coercion.substCoVarBndr (getCvSubst env) cv of
+ (CvSubst in_scope' tv_env' cv_env', cv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
+
+substCo :: SimplEnv -> Coercion -> Coercion
+substCo env co = Coercion.substCo (getCvSubst env) co
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
@@ -732,19 +766,19 @@ substTyVarBndr env tv
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
-mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
+mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
+ = mk_subst tv_env cv_env id_env
where
- mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
+ mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
- fiddle (DoneEx e) = e
- fiddle (DoneId v) = Var v
- fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
+ fiddle (DoneEx e) = e
+ fiddle (DoneId v) = Var v
+ fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
-- Don't shortcut here
------------------
substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
| isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
| otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-- The tyVarsOfType is cheaper than it looks
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7e9a010051ee64822a2604bf0d628125e5b5df63..7d5d764fc6e3283ee1d5499d39483d2de0038e0c 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -36,6 +36,7 @@ import StaticFlags
import CoreSyn
import qualified CoreSubst
import PprCore
+import DataCon ( dataConCannotMatch )
import CoreFVs
import CoreUtils
import CoreArity
@@ -45,17 +46,16 @@ import Id
import Var
import Demand
import SimplMonad
-import TcType ( isDictLikeTy )
import Type hiding( substTy )
-import Coercion ( coercionKind )
+import Coercion hiding( substCo )
import TyCon
-import Unify ( dataConCannotMatch )
import VarSet
import BasicTypes
import Util
import MonadUtils
import Outputable
import FastString
+import Pair
import Data.List
\end{code}
@@ -99,6 +99,7 @@ data SimplCont
| CoerceIt -- C `cast` co
OutCoercion -- The coercion simplified
+ -- Invariant: never an identity coercion
SimplCont
| ApplyTo -- C arg
@@ -208,6 +209,7 @@ contIsDupable _ = False
contIsTrivial :: SimplCont -> Bool
contIsTrivial (Stop {}) = True
contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
+contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont
contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
contIsTrivial _ = False
@@ -216,17 +218,19 @@ contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
contResultType env ty cont
= go cont ty
where
- subst_ty se ty = substTy (se `setInScope` env) ty
+ subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
+ subst_co se co = SimplEnv.substCo (se `setInScope` env) co
go (Stop {}) ty = ty
- go (CoerceIt co cont) _ = go cont (snd (coercionKind co))
+ go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co))
go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body)))
go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai))
go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts))
go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se)
- apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
- apply_to_arg ty _ _ = funResultTy ty
+ apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
+ apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
+ apply_to_arg ty _ _ = funResultTy ty
argInfoResultTy :: ArgInfo -> OutType
argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
@@ -235,6 +239,7 @@ argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
-------------------
countValArgs :: SimplCont -> Int
countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont
countValArgs _ = 0
@@ -784,6 +789,11 @@ Don't inline top-level Ids that are bottoming, even if they are used just
once, because FloatOut has gone to some trouble to extract them out.
Inlining them won't make the program run faster!
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and have a separate
+substitution, so don't inline them via the IdSubst!
+
\begin{code}
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally env top_lvl bndr rhs
@@ -791,6 +801,7 @@ preInlineUnconditionally env top_lvl bndr rhs
| isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally]
| isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
| opt_SimplNoPreInlining = False
+ | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally]
| otherwise = case idOccInfo bndr of
IAmDead -> True -- Happens in ((\x.1) v)
OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
@@ -888,6 +899,7 @@ story for now.
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId -- The binder (an InId would be fine too)
+ -- (*not* a CoVar)
-> OccInfo -- From the InId
-> OutExpr
-> Unfolding
@@ -1032,9 +1044,9 @@ mkLam _env bndrs body
| not (any bad bndrs)
-- Note [Casts and lambdas]
= do { lam <- mkLam' dflags bndrs body
- ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+ ; return (mkCoerce (mkPiCos bndrs co) lam) }
where
- co_vars = tyVarsOfType co
+ co_vars = tyCoVarsOfCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
mkLam' dflags bndrs body@(Lam {})
@@ -1048,7 +1060,7 @@ mkLam _env bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | otherwise
+ | otherwise
= return (mkLams bndrs body)
\end{code}
@@ -1091,9 +1103,6 @@ because the latter is not well-kinded.
%* *
%************************************************************************
-When we meet a let-binding we try eta-expansion. To find the
-arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis]
-
\begin{code}
tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
-- See Note [Eta-expanding at let bindings]
@@ -1336,9 +1345,7 @@ abstractFloats main_tvs body_env body
; return (subst', (NonRec poly_id poly_rhs)) }
where
rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
- tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
- | otherwise
- = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
+ tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
-- Abstract only over the type variables free in the rhs
-- wrt which the new binding is abstracted. But the naive
@@ -1550,9 +1557,8 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
[con] -> -- It matches exactly one constructor, so fill it in
do { tick (FillInCaseDefault case_bndr)
; us <- getUniquesM
- ; let (ex_tvs, co_tvs, arg_ids) =
- dataConRepInstPat us con inst_tys
- ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
+ ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+ ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] }
_ -> return [(DEFAULT, [], deflt_rhs)]
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 8249c89425193d83ad8ec772e8ea4301990a2d35..b187897f890de47ba85b2ea78df75135b47b55a9 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -17,10 +17,9 @@ import FamInstEnv ( FamInstEnv )
import Id
import MkId ( seqId, realWorldPrimId )
import MkCore ( mkImpossibleExpr )
-import Var
import IdInfo
import Name ( mkSystemVarName, isExternalName )
-import Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
@@ -42,6 +41,7 @@ import Maybes ( orElse, isNothing )
import Data.List ( mapAccumL )
import Outputable
import FastString
+import Pair
\end{code}
@@ -369,8 +369,11 @@ simplNonRecX :: SimplEnv
-> SimplM SimplEnv
simplNonRecX env bndr new_rhs
- | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
- = return env -- Here b is dead, and we avoid creating
+ | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+ = return env -- Here c is dead, and we avoid creating
+ -- the binding c = (a,b)
+ | Coercion co <- new_rhs
+ = return (extendCvSubst env bndr co)
| otherwise -- the binding b = (a,b)
= do { (env', bndr') <- simplBinder env bndr
; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
@@ -438,7 +441,7 @@ That's what the 'go' loop in prepareRhs does
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
- | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
; return (env', Cast rhs' co) }
@@ -626,6 +629,12 @@ completeBind :: SimplEnv
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
+ | isCoVar old_bndr
+ = case new_rhs of
+ Coercion co -> return (extendCvSubst env old_bndr co)
+ _ -> return (addNonRec env new_bndr new_rhs)
+
+ | otherwise
= ASSERT( isId new_bndr )
do { let old_info = idInfo old_bndr
old_unf = unfoldingInfo old_info
@@ -641,9 +650,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
then do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally"
- -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
- return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
+ ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
else
@@ -658,7 +665,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
final_id = new_bndr `setIdInfo` info3
- ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+ ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
return (addNonRec env final_id final_rhs) } }
-- The addNonRec adds it to the in-scope set too
@@ -870,18 +877,21 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont
simplExprF env e cont
= -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
- simplExprF' env e cont
+ simplExprF1 env e cont
-simplExprF' :: SimplEnv -> InExpr -> SimplCont
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-simplExprF' env (Var v) cont = simplVarF env v cont
-simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
-simplExprF' env (Note n expr) cont = simplNote env n expr cont
-simplExprF' env (Cast body co) cont = simplCast env body co cont
-simplExprF' env (App fun arg) cont = simplExprF env fun $
+simplExprF1 env (Var v) cont = simplIdF env v cont
+simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF1 env (Note n expr) cont = simplNote env n expr cont
+simplExprF1 env (Cast body co) cont = simplCast env body co cont
+simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
+simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
+ rebuild env (Type (substTy env ty)) cont
+simplExprF1 env (App fun arg) cont = simplExprF env fun $
ApplyTo NoDup arg env cont
-simplExprF' env expr@(Lam _ _) cont
+simplExprF1 env expr@(Lam {}) cont
= simplLam env zapped_bndrs body cont
-- The main issue here is under-saturated lambdas
-- (\x1. \x2. e) arg1
@@ -898,17 +908,12 @@ simplExprF' env expr@(Lam _ _) cont
n_args = countArgs cont
-- NB: countArgs counts all the args (incl type args)
-- and likewise drop counts all binders (incl type lambdas)
-
- zappable_bndr b = isId b && not (isOneShotBndr b)
- zap b | isTyCoVar b = b
- | otherwise = zapLamIdInfo b
-simplExprF' env (Type ty) cont
- = ASSERT( contIsRhsOrArg cont )
- do { ty' <- simplCoercion env ty
- ; rebuild env (Type ty') cont }
+ zappable_bndr b = isId b && not (isOneShotBndr b)
+ zap b | isTyVar b = b
+ | otherwise = zapLamIdInfo b
-simplExprF' env (Case scrut bndr _ alts) cont
+simplExprF1 env (Case scrut bndr _ alts) cont
| sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
@@ -920,7 +925,7 @@ simplExprF' env (Case scrut bndr _ alts) cont
(Select NoDup bndr alts env mkBoringStop)
; rebuild env case_expr' cont }
-simplExprF' env (Let (Rec pairs) body) cont
+simplExprF1 env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
@@ -928,7 +933,7 @@ simplExprF' env (Let (Rec pairs) body) cont
; env'' <- simplRecBind env' NotTopLevel pairs
; simplExprF env'' body cont }
-simplExprF' env (Let (NonRec bndr rhs) body) cont
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
= simplNonRecE env bndr (rhs, env) ([], body) cont
---------------------------------
@@ -941,13 +946,30 @@ simplType env ty
new_ty = substTy env ty
---------------------------------
-simplCoercion :: SimplEnv -> InType -> SimplM OutType
--- The InType isn't *necessarily* a coercion, but it might be
--- (in a type application, say) and optCoercion is a no-op on types
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
+-- We are simplifying a term of form (Coercion co)
+-- Simplify the InCoercion, and then try to combine with the
+-- context, to implememt the rule
+-- (Coercion co) |> g
+-- = Coercion (syn (nth 0 g) ; co ; nth 1 g)
+simplCoercionF env co cont
+ = do { co' <- simplCoercion env co
+ ; simpl_co co' cont }
+ where
+ simpl_co co (CoerceIt g cont)
+ = simpl_co new_co cont
+ where
+ new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1
+ [g0, g1] = decomposeCo 2 g
+
+ simpl_co co cont
+ = seqCo co `seq` rebuild env (Coercion co) cont
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
- = seqType new_co `seq` return new_co
- where
- new_co = optCoercion (getTvSubst env) co
+ = let opt_co = optCoercion (getCvSubst env) co
+ in opt_co `seq` return opt_co
\end{code}
@@ -964,7 +986,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
rebuild env expr cont
= case cont of
Stop {} -> return (env, expr)
- CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
+ CoerceIt co cont -> rebuild env (Cast expr co) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
@@ -991,11 +1013,11 @@ simplCast env body co0 cont0
where
addCoerce co cont = add_coerce co (coercionKind co) cont
- add_coerce _co (s1, k1) cont -- co :: ty~ty
- | s1 `coreEqType` k1 = cont -- is a no-op
+ add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
+ | s1 `eqType` k1 = cont -- is a no-op
- add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
- | (_l1, t1) <- coercionKind co2
+ add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
+ | (Pair _l1 t1) <- coercionKind co2
-- e |> (g1 :: S1~L) |> (g2 :: L~T1)
-- ==>
-- e, if S1=T1
@@ -1005,28 +1027,40 @@ simplCast env body co0 cont0
-- we may find (coerce T (coerce S (\x.e))) y
-- and we'd like it to simplify to e[y/x] in one round
-- of simplification
- , s1 `coreEqType` t1 = cont -- The coerces cancel out
- | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
+ , s1 `eqType` t1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt (mkTransCo co1 co2) cont
- add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
- -- This implements the PushT and PushC rules from the paper
+ -- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
- = let
- (new_arg_ty, new_cast)
- | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule
- | otherwise = (ty', mkInstCoercion co ty') -- PushT rule
- in
- ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ = ASSERT( isTyVar tyvar )
+ ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ where
+ new_cast = mkInstCo co arg_ty'
+ arg_ty' | isSimplified dup = arg_ty
+ | otherwise = substTy (arg_se `setInScope` env) arg_ty
+
+{-
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont)
+ -- This implements the PushC rule from the paper
+ | Just (covar,_) <- splitForAllTy_maybe s1s2
+ = ASSERT( isCoVar covar )
+ ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont)
where
- ty' = substTy (arg_se `setInScope` env) arg_ty
- new_arg_co = mkCsel1Coercion co `mkTransCoercion`
- ty' `mkTransCoercion`
- mkSymCoercion (mkCsel2Coercion co)
-
- add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
- | not (isTypeArg arg) -- This implements the Push rule from the paper
- , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
+ [co0, co1] = decomposeCo 2 co
+ [co00, co01] = decomposeCo 2 co0
+
+ arg_co' | isSimplified dup = arg_co
+ | otherwise = substCo (arg_se `setInScope` env) arg_co
+ new_arg_co = co00 `mkTransCo`
+ arg_co' `mkTransCo`
+ mkSymCo co01
+-}
+
+ add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
+ | isFunTy s1s2 -- This implements the Push rule from the paper
+ , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
-- (e |> (g :: s1s2 ~ t1->t2)) f
-- ===>
-- (e (f |> (arg g :: t1~s1))
@@ -1047,7 +1081,7 @@ simplCast env body co0 cont0
-- t2 ~ s2 with left and right on the curried form:
-- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
- new_arg = mkCoerce (mkSymCoercion co1) arg'
+ new_arg = mkCoerce (mkSymCo co1) arg'
arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
@@ -1120,7 +1154,7 @@ simplNonRecE :: SimplEnv
-- First deal with type applications and type lets
-- (/\a. e) (Type ty) and (let a = Type ty in e)
simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
- = ASSERT( isTyCoVar bndr )
+ = ASSERT( isTyVar bndr )
do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
@@ -1130,12 +1164,12 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
- | isStrictId bndr
+ | isStrictId bndr -- Includes coercions
= do { simplExprF (rhs_se `setFloats` env) rhs
(StrictBind bndr bndrs body env cont) }
| otherwise
- = ASSERT( not (isTyCoVar bndr) )
+ = ASSERT( not (isTyVar bndr) )
do { (env1, bndr1) <- simplNonRecBndr env bndr
; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
@@ -1177,20 +1211,20 @@ simplNote env (CoreNote s) e cont
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
-- Look up an InVar in the environment
simplVar env var
- | isTyCoVar var
- = return (Type (substTyVar env var))
+ | isTyVar var = return (Type (substTyVar env var))
+ | isCoVar var = return (Coercion (substCoVar env var))
| otherwise
= case substId env var of
- DoneId var1 -> return (Var var1)
- DoneEx e -> return e
- ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
+ DoneId var1 -> return (Var var1)
+ DoneEx e -> return e
+ ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
-simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
-simplVarF env var cont
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplIdF env var cont
= case substId env var of
- DoneEx e -> simplExprF (zapSubstEnv env) e cont
- ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
- DoneId var1 -> completeCall env var1 cont
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+ DoneId var1 -> completeCall env var1 cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
@@ -1237,10 +1271,10 @@ completeCall env var cont
| not (dopt Opt_D_dump_inlinings dflags) = stuff
| not (dopt Opt_D_verbose_core2core dflags)
= if isExternalName (idName var) then
- pprTrace "Inlining done:" (ppr var) stuff
+ pprDefiniteTrace "Inlining done:" (ppr var) stuff
else stuff
| otherwise
- = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+ = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
(vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr cont])
stuff
@@ -1266,13 +1300,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
res = mkApps (Var fun) (reverse rev_args)
res_ty = exprType res
cont_ty = contResultType env res_ty cont
- co = mkUnsafeCoercion res_ty cont_ty
- mk_coerce expr | cont_ty `coreEqType` res_ty = expr
+ co = mkUnsafeCo res_ty cont_ty
+ mk_coerce expr | cont_ty `eqType` res_ty = expr
| otherwise = mkCoerce co expr
-rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
- = do { ty' <- simplCoercion (se `setInScope` env) arg_ty
- ; rebuildCall env (info `addArgTo` Type ty') cont }
+rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
+ = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
+ else simplType (se `setInScope` env) arg_ty
+ ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
@@ -1280,7 +1315,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
= rebuildCall env (addArgTo info' arg) cont
- | str -- Strict argument
+ | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
(StrictArg info' cci cont)
@@ -1393,10 +1428,10 @@ tryRules env rules fn args call_cont
, not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
| not (dopt Opt_D_dump_rule_rewrites dflags)
- = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
+ = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff
| otherwise
- = pprTrace "Rule fired"
+ = pprDefiniteTrace "Rule fired"
(vcat [text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
@@ -1771,7 +1806,7 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
| not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
- ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
@@ -1834,7 +1869,7 @@ simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)
= go vs the_strs
where
go [] [] = []
- go (v:vs') strs | isTyCoVar v = v : go vs' strs
+ go (v:vs') strs | isTyVar v = v : go vs' strs
go (v:vs') (str:strs)
| isMarkedStrict str = evald_v : go vs' strs
| otherwise = zapped_v : go vs' strs
@@ -1933,7 +1968,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
bind_args env' [] _ = return env'
bind_args env' (b:bs') (Type ty : args)
- = ASSERT( isTyCoVar b )
+ = ASSERT( isTyVar b )
bind_args (extendTvSubst env' b ty) bs' args
bind_args env' (b:bs') (arg : args)
@@ -2151,7 +2186,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
| otherwise = bndrs' ++ [case_bndr_w_unf]
abstract_over bndr
- | isTyCoVar bndr = True -- Abstract over all type variables just in case
+ | isTyVar bndr = True -- Abstract over all type variables just in case
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 3205542c8e991263b6a8a0e404edcc72a27cbf8a..f9d02e5ab727f8b8a77612eb15cea4a547873898 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -37,10 +37,10 @@ import CoreUtils ( exprType, eqExpr )
import PprCore ( pprRules )
import Type ( Type )
import TcType ( tcSplitTyConApp_maybe )
+import Coercion
import CoreTidy ( tidyRules )
import Id
import IdInfo ( SpecInfo( SpecInfo ) )
-import Var ( Var )
import VarEnv
import VarSet
import Name ( Name, NamedThing(..) )
@@ -56,7 +56,6 @@ import Util
import Data.List
\end{code}
-
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* After the desugarer:
@@ -184,8 +183,9 @@ roughTopNames args = map roughTopName args
roughTopName :: CoreExpr -> Maybe Name
roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
- Just (tc,_) -> Just (getName tc)
- Nothing -> Nothing
+ Just (tc,_) -> Just (getName tc)
+ Nothing -> Nothing
+roughTopName (Coercion _) = Nothing
roughTopName (App f _) = roughTopName f
roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName]
, isDataConWorkId f || idArity f > 0
@@ -625,10 +625,7 @@ match :: RuleEnv
-- succeed in matching what looks like the template variable 'a' against 3.
-- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1) e2
- | Just subst <- match_var renv subst v1 e2
- = Just subst
-
+match renv subst (Var v1) e2 = match_var renv subst v1 e2
match renv subst (Note _ e1) e2 = match renv subst e1 e2
match renv subst e1 (Note _ e2) = match renv subst e1 e2
-- Ignore notes in both template and thing to be matched
@@ -714,15 +711,29 @@ match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
match renv subst (Type ty1) (Type ty2)
= match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+ = match_co renv subst co1 co2
match renv subst (Cast e1 co1) (Cast e2 co2)
- = do { subst1 <- match_ty renv subst co1 co2
+ = do { subst1 <- match_co renv subst co1 co2
; match renv subst1 e1 e2 }
-- Everything else fails
match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
Nothing
+-------------
+match_co :: RuleEnv
+ -> RuleSubst
+ -> Coercion
+ -> Coercion
+ -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+ = match_var renv subst cv (Coercion co)
+match_co _ _ co1 _
+ = pprTrace "match_co baling out" (ppr co1) Nothing
+
+-------------
rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
rnMatchBndr2 renv subst x1 x2
= renv { rv_lcl = rnBndr2 rn_env x1 x2
@@ -1038,6 +1049,7 @@ ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck _ (Var _) = emptyBag
ruleCheck _ (Lit _) = emptyBag
ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
ruleCheck env (App f a) = ruleCheckApp env (App f a) []
ruleCheck env (Note _ e) = ruleCheck env e
ruleCheck env (Cast e _) = ruleCheck env e
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 4fa42046e8de853ec72fd0f0505bfd86c2fcae9f..6cc05a3dc652d6289ad68ac14e314959a7a6e6f3 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -33,9 +33,9 @@ import CoreMonad
import HscTypes ( ModGuts(..) )
import WwLib ( mkWorkerArgs )
import DataCon
-import Coercion
+import Coercion hiding( substTy, substCo )
import Rules
-import Type hiding( substTy )
+import Type hiding ( substTy )
import Id
import MkCore ( mkImpossibleExpr )
import Var
@@ -50,6 +50,7 @@ import Demand
import DmdAnal ( both )
import Serialized ( deserializeWithData )
import Util
+import Pair
import UniqSupply
import Outputable
import FastString
@@ -699,6 +700,9 @@ scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty
+scSubstCo :: ScEnv -> Coercion -> Coercion
+scSubstCo env co = substCo (sc_subst env) co
+
zapScSubst :: ScEnv -> ScEnv
zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
@@ -777,7 +781,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
varsToCoreExprs alt_bndrs
- zap v | isTyCoVar v = v -- See NB2 above
+ zap v | isTyVar v = v -- See NB2 above
| otherwise = zapIdOccInfo v
@@ -997,11 +1001,12 @@ scExpr' env (Var v) = case scSubstId env v of
e' -> scExpr (zapScSubst env) e'
scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
scExpr' _ e@(Lit {}) = return (nullUsage, e)
scExpr' env (Note n e) = do (usg,e') <- scExpr env e
return (usg, Note n e')
scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
- return (usg, Cast e' (scSubstTy env co))
+ return (usg, Cast e' (scSubstCo env co))
scExpr' env e@(App _ _) = scApp env (collectArgs e)
scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
(usg, e') <- scExpr env' e
@@ -1047,7 +1052,7 @@ scExpr' env (Case scrut b ty alts)
; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
- | isTyCoVar bndr -- Type-lets may be created by doBeta
+ | isTyVar bndr -- Type-lets may be created by doBeta
= scExpr' (extendScSubst env bndr rhs) body
| otherwise
@@ -1308,8 +1313,10 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
spec_count' = n_pats + spec_count
; case sc_count env of
Just max | not (sc_force env) && spec_count' > max
- -> pprTrace "SpecConstr" msg $
- return (nullUsage, spec_info)
+ -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for
+ then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125
+ return (nullUsage, spec_info)
+ else return (nullUsage, spec_info)
where
msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
, nest 2 (ptext (sLit "has") <+>
@@ -1417,6 +1424,7 @@ calcSpecStrictness fn qvars pats
dmd_env = go emptyVarEnv dmds pats
go env ds (Type {} : pats) = go env ds pats
+ go env ds (Coercion {} : pats) = go env ds pats
go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
go env _ _ = env
@@ -1517,7 +1525,7 @@ callToPats env bndr_occs (con_env, args)
-- at the call site
-- See Note [Shadowing] at the top
- (tvs, ids) = partition isTyCoVar qvars
+ (tvs, ids) = partition isTyVar qvars
qvars' = tvs ++ ids
-- Put the type variables first; the type of a term
-- variable may mention a type variable
@@ -1552,6 +1560,9 @@ argToPat :: ScEnv
argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
= return (False, arg)
+
+argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ
+ = return (False, arg)
argToPat env in_scope val_env (Note _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
@@ -1577,8 +1588,8 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
-}
argToPat env in_scope val_env (Cast arg co) arg_occ
- | isIdentityCoercion co -- Substitution in the SpecConstr itself
- -- can lead to identity coercions
+ | isReflCo co -- Substitution in the SpecConstr itself
+ -- can lead to identity coercions
= argToPat env in_scope val_env arg arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
@@ -1588,10 +1599,10 @@ argToPat env in_scope val_env (Cast arg co) arg_occ
{ -- Make a wild-card pattern for the coercion
uniq <- getUniqueUs
; let co_name = mkSysTvName uniq (fsLit "sg")
- co_var = mkCoVar co_name (mkCoKind ty1 ty2)
- ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
+ co_var = mkCoVar co_name (mkCoType ty1 ty2)
+ ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
where
- (ty1, ty2) = coercionKind co
+ Pair ty1 ty2 = coercionKind co
@@ -1699,7 +1710,7 @@ isValue env (Var v)
-- as well, for let-bound constructors!
isValue env (Lam b e)
- | isTyCoVar b = case isValue env e of
+ | isTyVar b = case isValue env e of
Just _ -> Just LambdaVal
Nothing -> Nothing
| otherwise = Just LambdaVal
@@ -1734,6 +1745,7 @@ samePat (vs1, as1) (vs2, as2)
same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
same (Type {}) (Type {}) = True -- Note [Ignore type differences]
+ same (Coercion {}) (Coercion {}) = True
same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
same (Cast e1 _) e2 = same e1 e2
same e1 (Note _ e2) = same e1 e2
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 415378ac479b4632889ed23ef5ab5b09b0141d1c..c192b3f60afcc6c110a3032b24230876da77df68 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -709,11 +709,12 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
---------------- First the easy cases --------------------
specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs)
+specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs)
specExpr subst (Var v) = return (specVar subst v, emptyUDs)
specExpr _ (Lit lit) = return (Lit lit, emptyUDs)
specExpr subst (Cast e co) = do
(e', uds) <- specExpr subst e
- return ((Cast e' (CoreSubst.substTy subst co)), uds)
+ return ((Cast e' (CoreSubst.substCo subst co)), uds)
specExpr subst (Note note body) = do
(body', uds) <- specExpr subst body
return (Note (specNote subst note) body', uds)
@@ -1518,7 +1519,7 @@ instance Ord CallKey where
cmp Nothing Nothing = EQ
cmp Nothing (Just _) = LT
cmp (Just _) Nothing = GT
- cmp (Just t1) (Just t2) = tcCmpType t1 t2
+ cmp (Just t1) (Just t2) = cmpType t1 t2
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2
@@ -1603,7 +1604,9 @@ interestingDict :: CoreExpr -> Bool
interestingDict (Var v) = hasSomeUnfolding (idUnfolding v)
|| isDataConWorkId v
interestingDict (Type _) = False
+interestingDict (Coercion _) = False
interestingDict (App fn (Type _)) = interestingDict fn
+interestingDict (App fn (Coercion _)) = interestingDict fn
interestingDict (Note _ a) = interestingDict a
interestingDict (Cast e _) = interestingDict e
interestingDict _ = True
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 2059937e0b5ab080b571a7f49dd434d839245533..df8fabe7108a73065581e7a3f28213aa798a2e2e 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -18,8 +18,8 @@ import StgSyn
import Type
import TyCon
+import MkId ( coercionTokenId )
import Id
-import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
- = WARN( not (exact || is_sat_thing) , ppr id )
+ = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
safe
where
safe = id_marked_caffy || not binding_is_caffy
@@ -312,8 +312,9 @@ on these components, but it in turn is not scrutinised as the basis for any
decisions. Hence no black holes.
\begin{code}
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
-coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
coreToStgExpr expr@(App _ _)
= coreToStgApp Nothing f args
@@ -572,6 +573,10 @@ coreToStgArgs (Type _ : args) = do -- Type argument
(args', fvs) <- coreToStgArgs args
return (args', fvs)
+coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
+ = do { (args', fvs) <- coreToStgArgs args
+ ; return (StgVarArg coercionTokenId : args', fvs) }
+
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, args_fvs) <- coreToStgArgs args
(arg', arg_fvs, _escs) <- coreToStgExpr arg
@@ -1124,7 +1129,7 @@ myCollectArgs expr
go (Cast e _) as = go e as
go (Note _ e) as = go e as
go (Lam b e) as
- | isTyCoVar b = go e as -- Note [Collect args]
+ | isTyVar b = go e as -- Note [Collect args]
go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index 3bce28148a38f4153d647b4a3fe5734070b0d243..dd026eb80c9e0c990b588992a3a0a574b5b8ad6a 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -68,7 +68,8 @@ import FastString
#if mingw32_TARGET_OS
import Packages ( isDllName )
-
+import Type ( typePrimRep )
+import TyCon ( PrimRep(..) )
#endif
\end{code}
@@ -118,8 +119,27 @@ isDllConApp this_pkg con args
= isDllName this_pkg (dataConName con) || any is_dll_arg args
where
is_dll_arg ::StgArg -> Bool
- is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v)
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
+ && isDllName this_pkg (idName v)
is_dll_arg _ = False
+
+isAddrRep :: PrimRep -> Bool
+-- True of machine adddresses; these are the things that don't
+-- work across DLLs.
+-- The key point here is that VoidRep comes out False, so that
+-- a top level nullary GADT construtor is False for isDllConApp
+-- data T a where
+-- T1 :: T Int
+-- gives
+-- T1 :: forall a. (a~Int) -> T a
+-- and hence the top-level binding
+-- $WT1 :: T Int
+-- $WT1 = T1 Int (Coercion (Refl Int))
+-- The coercion argument here gets VoidRep
+isAddrRep AddrRep = True
+isAddrRep PtrRep = True
+isAddrRep _ = False
+
#else
isDllConApp _ _ _ = False
#endif
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 192d06f563a3d72ad204b70f72b71acea002c475..afa722fa8aa24142a4d6df0d5453b792a8cd8851 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -18,6 +18,7 @@ import StaticFlags ( opt_MaxWorkerArgs )
import Demand -- All of it
import CoreSyn
import PprCore
+import Coercion ( isCoVarType )
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon, dataConRepStrictness )
@@ -28,19 +29,20 @@ import Id ( Id, idType, idInlineActivation,
setIdStrictness, idDemandInfo, idUnfolding,
idDemandInfo_maybe, setIdDemandInfo
)
-import Var ( Var )
+import Var ( Var, isTyVar )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
minusUFM, filterUFM )
-import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
+import Type ( isUnLiftedType, eqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import Util ( mapAndUnzip, lengthIs, zipEqual )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec, isMarkedStrict )
import Maybes ( orElse, expectJust )
import Outputable
+import Pair
import Data.List
import FastString
\end{code}
@@ -144,6 +146,7 @@ dmdAnal env dmd e
dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact
+dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co)
dmdAnal env dmd (Var var)
= (dmdTransform env var dmd, Var var)
@@ -152,7 +155,7 @@ dmdAnal env dmd (Cast e co)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal env dmd' e
- to_co = snd (coercionKind co)
+ to_co = pSnd (coercionKind co)
dmd'
| Just (tc, _) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
@@ -173,6 +176,11 @@ dmdAnal env dmd (App fun (Type ty))
where
(fun_ty, fun') = dmdAnal env dmd fun
+dmdAnal sigs dmd (App fun (Coercion co))
+ = (fun_ty, App fun' (Coercion co))
+ where
+ (fun_ty, fun') = dmdAnal sigs dmd fun
+
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
dmdAnal env dmd (App fun arg) -- Non-type arguments
@@ -184,7 +192,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments
(res_ty `bothType` arg_ty, App fun' arg')
dmdAnal env dmd (Lam var body)
- | isTyCoVar var
+ | isTyVar var
= let
(body_ty, body') = dmdAnal env dmd body
in
@@ -328,7 +336,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs)
-- ; print len }
io_hack_reqd = con == DataAlt unboxedPairDataCon &&
- idType (head bndrs) `coreEqType` realWorldStatePrimTy
+ idType (head bndrs) `eqType` realWorldStatePrimTy
in
(final_alt_ty, (con, bndrs', rhs'))
@@ -838,7 +846,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
-- The returned var is annotated with demand info
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
- | isTyCoVar var = (dmd_ty, var)
+ | isTyVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
@@ -888,10 +896,15 @@ removeFV fv id res = (fv', zapUnlifted id dmd)
zapUnlifted :: Id -> Demand -> Demand
-- For unlifted-type variables, we are only
-- interested in Bot/Abs/Box Abs
-zapUnlifted _ Bot = Bot
-zapUnlifted _ Abs = Abs
-zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
- | otherwise = dmd
+zapUnlifted id dmd
+ = case dmd of
+ _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally
+ Bot -> Bot
+ Abs -> Abs
+ _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness
+ | otherwise -> dmd
+ where
+ ty = idType id
\end{code}
Note [Lamba-bound unfoldings]
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 5cf5e9269266b4c4bfebc2b2f8a2f1660e427d39..ac10b1b7737bd84347e76282d05e16b1df56fd63 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -100,6 +100,7 @@ matching by looking for strict arguments of the correct type.
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type {}) = return e
+wwExpr e@(Coercion {}) = return e
wwExpr e@(Lit {}) = return e
wwExpr e@(Var {}) = return e
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index e7d0edf0f8c24f7c01f8047962cadc5fdb5f7c81..391c07c0894595954e1b9f42112cae71a68e9765 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -23,10 +23,9 @@ import MkId ( realWorldPrimId, voidArgId,
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type
-import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
+import Coercion ( mkSymCo, splitNewTypeRepCo_maybe )
import BasicTypes ( Boxity(..) )
import Literal ( absentLiteralOf )
-import Var ( Var )
import UniqSupply
import Unique
import Util ( zipWithEqual )
@@ -244,7 +243,7 @@ mkWWargs subst fun_ty arg_info
= do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
<- mkWWargs subst rep_ty arg_info
; return (wrap_args,
- \e -> Cast (wrap_fn_args e) (mkSymCoercion co),
+ \e -> Cast (wrap_fn_args e) (mkSymCo co),
\e -> work_fn_args (Cast e co),
res_ty) }
@@ -271,7 +270,7 @@ mkWWargs subst fun_ty arg_info
<- mkWWargs subst fun_ty' arg_info'
; return (id : wrap_args,
Lam id . wrap_fn_args,
- work_fn_args . (`App` Var id),
+ work_fn_args . (`App` varToCoreExpr id),
res_ty) }
| otherwise
@@ -291,18 +290,12 @@ mk_wrap_arg uniq ty dmd one_shot
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-mkWWargs may be given a type like (a~b) => <blah>
-Which really means forall (co:a~b). <blah>
-Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
-nested coercion foralls may all use the same variable; and sometimes do
-see Var.mkWildCoVar.
-
-However, when we do a worker/wrapper split, we must not use shadowed names,
+Wen we do a worker/wrapper split, we must not use shadowed names,
else we'll get
- f = /\ co /\co. fw co co
-which is obviously wrong. Actually, the same is true of type variables, which
-can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
-But type variables *are* mentioned in <blah>, so we must substitute.
+ f = /\ a /\a. fw a a
+which is obviously wrong. Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a). But type
+variables *are* mentioned in <blah>, so we must substitute.
That's why we carry the TvSubst through mkWWargs
@@ -339,7 +332,7 @@ mkWWstr (arg : args) = do
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one arg
- | isTyCoVar arg
+ | isTyVar arg
= return ([arg], nop_fn, nop_fn)
| otherwise
@@ -525,7 +518,7 @@ mk_absent_let arg
| Just (tc, _) <- splitTyConApp_maybe arg_ty
, Just lit <- absentLiteralOf tc
= Just (Let (NonRec arg (Lit lit)))
- | arg_ty `coreEqType` realWorldStatePrimTy
+ | arg_ty `eqType` realWorldStatePrimTy
= Just (Let (NonRec arg (Var realWorldPrimId)))
| otherwise
= WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 45584d9b411aa11039aab9b0ef571c26dfa6c051..ccdbf579dcadf662509654061fb67b86a64e2aab 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -7,6 +7,7 @@ module FamInst (
import HscTypes
import FamInstEnv
+import LoadIface
import TcMType
import TcRnMonad
import TyCon
@@ -82,20 +83,17 @@ checkFamInstConsistency famInstMods directlyImpMods
; (eps, hpt) <- getEpsAndHpt
; let { -- Fetch the iface of a given module. Must succeed as
- -- all imported modules must already have been loaded.
+ -- all directly imported modules must already have been loaded.
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; hmiModule = mi_module . hm_iface
- ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
- ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
- ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
- | hmi <- eltsUFM hpt]
- ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
- `extendModuleEnvList` -- plus
- hptModInsts -- home package modules
+ ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+ . md_fam_insts . hm_details
+ ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+ | hmi <- eltsUFM hpt]
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
@@ -106,22 +104,27 @@ checkFamInstConsistency famInstMods directlyImpMods
-- the difference gives us the pairs we need to check now
}
- ; mapM_ (check modInstsEnv) toCheckPairs
+ ; mapM_ (check hpt_fam_insts) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
- -- The modules are guaranteed to be in the environment, as they are either
- -- already loaded in the EPS or they are in the HPT.
- --
- check modInstsEnv (ModulePair m1 m2)
- = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
- ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
- ; insts1 = famInstEnvElts instEnv1
- }
- in
- mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+ check hpt_fam_insts (ModulePair m1 m2)
+ = do { env1 <- getFamInsts hpt_fam_insts m1
+ ; env2 <- getFamInsts hpt_fam_insts m2
+ ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
+ (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+ | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+ | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+ ; eps <- getEps
+ ; return (expectJust "checkFamInstConsistency" $
+ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+ where
+ doc = ppr mod <+> ptext (sLit "is a family-instance module")
\end{code}
%************************************************************************
@@ -196,17 +199,11 @@ addFamInstLoc famInst thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
-\end{code}
-
-\begin{code}
tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
- ; return (eps_fam_inst_env eps, tcg_fam_inst_env env)
- }
-
-
+ ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
\end{code}
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index bbdf21bc3c06cee114db649147e37567899edd0d..378bbd607d09e823316ef97ab0117954be99a7fc 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -46,11 +46,10 @@ import TcMType
import TcType
import Class
import Unify
-import Coercion
import HscTypes
import Id
import Name
-import Var
+import Var ( Var, TyVar, EvVar, varType, setVarType )
import VarEnv
import VarSet
import PrelNames
@@ -212,11 +211,8 @@ instCallConstraints _ [] = return idHsWrapper
instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut
= do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
- ; coi <- unifyType ty1 ty2
+ ; co <- unifyType ty1 ty2
; co_fn <- instCallConstraints origin preds
- ; let co = case coi of
- IdCo ty -> ty
- ACo co -> co
; return (co_fn <.> WpEvApp (EvCoercion co)) }
instCallConstraints origin (pred : preds)
@@ -551,7 +547,7 @@ tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
-tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
+tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
@@ -595,8 +591,8 @@ substFlavoredEvVar subst (EvVarX v fl)
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
-substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
-substFlavor _ fl = fl
+substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
+substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
@@ -605,4 +601,4 @@ substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
substSkolemInfo _ info = info
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index ae4a1e876125158fdc0d92e17e46b935503ed3ff..7ce5fc1a575abb70d1993b1cd2b2efe8a37ed078 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -7,7 +7,7 @@ Typecheck arrow notation
\begin{code}
module TcArrows ( tcProc ) where
-import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
import HsSyn
import TcMatches
@@ -17,7 +17,9 @@ import TcBinds
import TcPat
import TcUnify
import TcRnMonad
+import TcEnv
import Coercion
+import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
@@ -41,17 +43,17 @@ import Control.Monad
\begin{code}
tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr
-> TcRhoType -- Expected type of whole proc expression
- -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI)
+ -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion)
tcProc pat cmd exp_ty
= newArrowScope $
do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
+ ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
tcCmdTop cmd_env cmd [] res_ty
- ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty))
- ; return (pat', cmd', res_coi) }
+ ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty))
+ ; return (pat', cmd', res_coi) }
\end{code}
@@ -83,20 +85,12 @@ tcCmdTop :: CmdEnv
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
= setSrcSpan loc $
- do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty
+ do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
----------------------------------------
-tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
- -> TcTauType -> TcM (LHsExpr TcId)
--- A wrapper that deals with the refinement (if any)
-tcGuardedCmd env expr stk res_ty
- = do { body <- tcCmd env expr (stk, res_ty)
- ; return body
- }
-
tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
tcCmd env (L loc expr) res_ty
@@ -123,7 +117,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
- mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
+ mc_body body res_ty' = tcCmd env body (stk, res_ty')
tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
= do { pred_ty <- newFlexiTyVarTy openTypeKind
@@ -187,8 +181,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
-- Check the patterns, and the GRHSs inside
; (pats', grhss') <- setSrcSpan mtch_loc $
- tcPats LambdaExpr pats cmd_stk $
- tc_grhss grhss res_ty
+ tcPats LambdaExpr pats cmd_stk $
+ tc_grhss grhss res_ty
; let match' = L mtch_loc (Match pats' Nothing grhss')
; return (HsLam (MatchGroup [match'] res_ty))
@@ -206,22 +200,18 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
; return (GRHSs grhss' binds') }
tc_grhs res_ty (GRHS guards body)
- = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
- tcGuardedCmd env body stk'
+ = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+ \ res_ty -> tcCmd env body (stk', res_ty)
; return (GRHS guards' rhs') }
-------------------------------------------
-- Do notation
-tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $
- tcGuardedCmd env body []
- ; return (HsDo do_or_lc stmts' body' res_ty) }
+ ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty
+ ; return (HsDo do_or_lc stmts' res_ty) }
where
- tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
- ; rhs' <- tcCmd env rhs ([], ty)
- ; return (rhs', ty) }
-----------------------------------------------------------------
@@ -249,7 +239,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
e_res_ty
-- Check expr
- ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
+ ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
escapeArrowScope (tcMonoExpr expr e_ty)
-- OK, now we are in a position to unscramble
@@ -279,7 +269,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
-- Check that it has the right shape:
-- ((w,s1) .. sn)
-- where the si do not mention w
- ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv &&
+ ; checkTc (corner_ty `eqType` mkTyVarTy w_tv &&
not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
(badFormFun i tup_ty')
@@ -305,6 +295,69 @@ tc_cmd _ cmd _
\end{code}
+%************************************************************************
+%* *
+ Stmts
+%* *
+%************************************************************************
+
+\begin{code}
+--------------------------------
+-- Mdo-notation
+-- The distinctive features here are
+-- (a) RecStmts, and
+-- (b) no rebindable syntax
+
+tcArrDoStmt :: CmdEnv -> TcStmtChecker
+tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
+ = do { rhs' <- tcCmd env rhs ([], res_ty)
+ ; thing <- thing_inside (panic "tcArrDoStmt")
+ ; return (LastStmt rhs' noSyntaxExpr, thing) }
+
+tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside
+ = do { (rhs', elt_ty) <- tc_arr_rhs env rhs
+ ; thing <- thing_inside res_ty
+ ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
+
+tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+ = do { (rhs', pat_ty) <- tc_arr_rhs env rhs
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
+ thing_inside res_ty
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
+ , recS_rec_ids = recNames }) res_ty thing_inside
+ = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
+ ; let rec_ids = zipWith mkLocalId recNames rec_tys
+ ; tcExtendIdEnv rec_ids $ do
+ { (stmts', (later_ids, rec_rets))
+ <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' ->
+ -- ToDo: res_ty not really right
+ do { rec_rets <- zipWithM tcCheckId recNames rec_tys
+ ; later_ids <- tcLookupLocalIds laterNames
+ ; return (later_ids, rec_rets) }
+
+ ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part. This binding may shadow
+ -- some of them with polymorphic things with the same Name
+ -- (see note [RecStmt] in HsExpr)
+
+ ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
+ , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+ , recS_ret_ty = res_ty }, thing)
+ }}
+
+tcArrDoStmt _ _ stmt _ _
+ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
+
+tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType)
+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs' <- tcCmd env rhs ([], ty)
+ ; return (rhs', ty) }
+\end{code}
+
+
%************************************************************************
%* *
Helpers
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 8a6a3b7fc0447901336eb926a5d09c3ad1217377..8462403813df07474831eec2088e0be14b536467 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -25,7 +25,6 @@ import TcHsType
import TcPat
import TcMType
import TcType
-import RnBinds( misplacedSigErr )
import Coercion
import TysPrim
import Id
@@ -44,7 +43,6 @@ import BasicTypes
import Outputable
import FastString
-import Data.List( partition )
import Control.Monad
#include "HsVersions.h"
@@ -559,24 +557,16 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
tcImpPrags prags
= do { this_mod <- getModule
- ; let is_imp prag
- = case sigName prag of
- Nothing -> False
- Just name -> not (nameIsLocalOrFrom this_mod name)
- (spec_prags, others) = partition isSpecLSig $
- filter is_imp prags
- ; mapM_ misplacedSigErr others
- -- Messy that this misplaced-sig error comes here
- -- but the others come from the renamer
- ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags }
-
-tcImpSpec :: Sig Name -> TcM TcSpecPrag
-tcImpSpec prag@(SpecSig (L _ name) _ _)
+ ; mapAndRecoverM (wrapLocM tcImpSpec)
+ [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ] }
+
+tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
+tcImpSpec (name, prag)
= do { id <- tcLookupId name
; checkTc (isAnyInlinePragma (idInlinePragma id))
(impSpecErr name)
; tcSpec id prag }
-tcImpSpec p = pprPanic "tcImpSpec" (ppr p)
impSpecErr :: Name -> SDoc
impSpecErr name
@@ -854,7 +844,7 @@ unifyCtxts (sig1 : sigs)
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoI cois)
+ checkTc (all isReflCo cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
\end{code}
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 59cc736083e5883ac4a0da65fd178856c59fa04a..2cb38a908aba5a41baf25ba54868e97bb3a9b915 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -8,12 +8,13 @@ module TcCanonical(
#include "HsVersions.h"
import BasicTypes
-import Type
+import Id ( evVarPred )
+import TcErrors
import TcRnTypes
import FunDeps
import qualified TcMType as TcM
import TcType
-import TcErrors
+import Type
import Coercion
import Class
import TyCon
@@ -92,7 +93,9 @@ expansions contain any type function applications would speed things
up a bit; right now we waste a lot of energy traversing the same types
multiple times.
+
\begin{code}
+
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type
@@ -111,35 +114,35 @@ flatten ctxt ty
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
- ; if isEmptyCCan ccs then
- return (ty, ty, emptyCCan)
+ ; if isReflCo co then
+ return (ty, mkReflCo ty, emptyCCan)
else
return (xi, co, ccs) }
flatten _ v@(TyVarTy _)
- = return (v, v, emptyCCan)
+ = return (v, mkReflCo v, emptyCCan)
flatten ctxt (AppTy ty1 ty2)
= do { (xi1,co1,c1) <- flatten ctxt ty1
; (xi2,co2,c2) <- flatten ctxt ty2
- ; return (mkAppTy xi1 xi2, mkAppCoercion co1 co2, c1 `andCCan` c2) }
+ ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) }
flatten ctxt (FunTy ty1 ty2)
= do { (xi1,co1,c1) <- flatten ctxt ty1
; (xi2,co2,c2) <- flatten ctxt ty2
- ; return (mkFunTy xi1 xi2, mkFunCoercion co1 co2, c1 `andCCan` c2) }
+ ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) }
flatten fl (TyConApp tc tys)
-- For a normal type constructor or data family application, we just
-- recursively flatten the arguments.
| not (isSynFamilyTyCon tc)
= do { (xis,cos,ccs) <- flattenMany fl tys
- ; return (mkTyConApp tc xis, mkTyConCoercion tc cos, ccs) }
+ ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) }
-- Otherwise, it's a type function application, and we have to
-- flatten it away as well, and generate a new given equality constraint
-- between the application and a newly generated flattening skolem variable.
- | otherwise
+ | otherwise
= ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated
do { (xis, cos, ccs) <- flattenMany fl tys
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
@@ -147,35 +150,41 @@ flatten fl (TyConApp tc tys)
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
- fam_ty = mkTyConApp tc xi_args
- fam_co = fam_ty -- identity
-
- ; (ret_co, rhs_var, ct) <-
- if isGiven fl then
- do { rhs_var <- newFlattenSkolemTy fam_ty
- ; cv <- newGivenCoVar fam_ty rhs_var fam_co
- ; let ct = CFunEqCan { cc_id = cv
- , cc_flavor = fl -- Given
- , cc_fun = tc
- , cc_tyargs = xi_args
- , cc_rhs = rhs_var }
- ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
- else -- Derived or Wanted: make a new *unification* flatten variable
- do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
- ; cv <- newCoVar fam_ty rhs_var
- ; let ct = CFunEqCan { cc_id = cv
- , cc_flavor = mkWantedFlavor fl
- -- Always Wanted, not Derived
- , cc_fun = tc
- , cc_tyargs = xi_args
- , cc_rhs = rhs_var }
- ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
-
+ fam_ty = mkTyConApp tc xi_args
+ ; (ret_co, rhs_var, ct) <-
+ do { is_cached <- lookupFlatCacheMap tc xi_args fl
+ ; case is_cached of
+ Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
+ Nothing
+ | isGivenOrSolved fl ->
+ do { rhs_var <- newFlattenSkolemTy fam_ty
+ ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
+ ; let ct = CFunEqCan { cc_id = cv
+ , cc_flavor = fl -- Given
+ , cc_fun = tc
+ , cc_tyargs = xi_args
+ , cc_rhs = rhs_var }
+ ; let ret_co = mkCoVarCo cv
+ ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+ ; return $ (ret_co, rhs_var, singleCCan ct) }
+ | otherwise ->
+ -- Derived or Wanted: make a new *unification* flatten variable
+ do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
+ ; cv <- newCoVar fam_ty rhs_var
+ ; let ct = CFunEqCan { cc_id = cv
+ , cc_flavor = mkWantedFlavor fl
+ -- Always Wanted, not Derived
+ , cc_fun = tc
+ , cc_tyargs = xi_args
+ , cc_rhs = rhs_var }
+ ; let ret_co = mkCoVarCo cv
+ ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+ ; return $ (ret_co, rhs_var, singleCCan ct) } }
; return ( foldl AppTy rhs_var xi_rest
- , foldl AppTy (mkSymCoercion ret_co
- `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
- , ccs `extendCCans` ct) }
-
+ , foldl AppCo (mkSymCo ret_co
+ `mkTransCo` mkTyConAppCo tc cos_args)
+ cos_rest
+ , ccs `andCCan` ct) }
flatten ctxt (PredTy pred)
= do { (pred', co, ccs) <- flattenPred ctxt pred
@@ -193,22 +202,20 @@ flatten ctxt ty@(ForAllTy {})
tv_set = mkVarSet tvs
; unless (isEmptyBag bad_eqs)
(flattenForAllErrorTcS ctxt ty bad_eqs)
- ; return (mkForAllTys tvs rho', mkForAllTys tvs co, ccs) }
+ ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs) }
---------------
flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts)
flattenPred ctxt (ClassP cls tys)
= do { (tys', cos, ccs) <- flattenMany ctxt tys
- ; return (ClassP cls tys', mkClassPPredCo cls cos, ccs) }
+ ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) }
flattenPred ctxt (IParam nm ty)
= do { (ty', co, ccs) <- flatten ctxt ty
- ; return (IParam nm ty', mkIParamPredCo nm co, ccs) }
--- TODO: Handling of coercions between EqPreds must be revisited once the New Coercion API is ready!
+ ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) }
flattenPred ctxt (EqPred ty1 ty2)
= do { (ty1', co1, ccs1) <- flatten ctxt ty1
; (ty2', co2, ccs2) <- flatten ctxt ty2
- ; return (EqPred ty1' ty2', mkEqPredCo co1 co2, ccs1 `andCCan` ccs2) }
-
+ ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) }
\end{code}
%************************************************************************
@@ -222,7 +229,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList
canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
-canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
+canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
; return (unionWorkLists ccs) }
mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
@@ -238,6 +245,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
canon_one fev wl = do { wl' <- mkCanonicalFEV fev
; return (unionWorkList wl' wl) }
+
mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
mkCanonical fl ev = case evVarPred ev of
ClassP clas tys -> canClassToWorkList fl ev clas tys
@@ -248,15 +256,15 @@ mkCanonical fl ev = case evVarPred ev of
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
- ; let no_flattening_happened = isEmptyCCan ccs
- dict_co = mkTyConCoercion (classTyCon cn) cos
- ; v_new <- if no_flattening_happened then return v
- else if isGiven fl then return v
+ ; let no_flattening_happened = all isReflCo cos
+ dict_co = mkTyConAppCo (classTyCon cn) cos
+ ; v_new <- if no_flattening_happened then return v
+ else if isGivenOrSolved fl then return v
-- The cos are all identities if fl=Given,
-- hence nothing to do
else do { v' <- newDictVar cn xis -- D xis
; when (isWanted fl) $ setDictBind v (EvCast v' dict_co)
- ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
+ ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
-- NB: No more setting evidence for derived now
; return v' }
@@ -320,7 +328,7 @@ For Deriveds:
Here's an example that demonstrates why we chose to NOT add
superclasses during simplification: [Comes from ticket #4497]
-
+
class Num (RealOf t) => Normed t
type family RealOf x
@@ -346,14 +354,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis
= return emptyWorkList -- Deriveds don't yield more superclasses because we will
-- add them transitively in the case of wanteds.
- | isGiven orig_flavor
- = do { let sc_theta = immSuperClasses cls xis
- flavor = orig_flavor
- ; sc_vars <- mapM newEvVar sc_theta
- ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
- ; mkCanonicals flavor sc_vars }
-
- | isEmptyVarSet (tyVarsOfTypes xis)
+ | Just gk <- isGiven_maybe orig_flavor
+ = case gk of
+ GivenOrig -> do { let sc_theta = immSuperClasses cls xis
+ flavor = orig_flavor
+ ; sc_vars <- mapM newEvVar sc_theta
+ ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
+ ; mkCanonicals flavor sc_vars }
+ GivenSolved -> return emptyWorkList
+ -- Seems very dangerous to add the superclasses for dictionaries that may be
+ -- partially solved because we may end up with evidence loops.
+
+ | isEmptyVarSet (tyVarsOfTypes xis)
= return emptyWorkList -- Wanteds with no variables yield no deriveds.
-- See Note [Improvement from Ground Wanteds]
@@ -391,9 +403,9 @@ canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2
canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts
canEq fl cv ty1 ty2
- | tcEqType ty1 ty2 -- Dealing with equality here avoids
+ | eqType ty1 ty2 -- Dealing with equality here avoids
-- later spurious occurs checks for a~a
- = do { when (isWanted fl) (setCoBind cv ty1)
+ = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1))
; return emptyCCan }
-- If one side is a variable, orient and flatten,
@@ -407,47 +419,6 @@ canEq fl cv ty1 ty2@(TyVarTy {})
; canEqLeaf untch fl cv (classify ty1) (classify ty2) }
-- NB: don't use VarCls directly because tv1 or tv2 may be scolems!
-canEq fl cv (TyConApp fn tys) ty2
- | isSynFamilyTyCon fn, length tys == tyConArity fn
- = do { untch <- getUntouchables
- ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
-canEq fl cv ty1 (TyConApp fn tys)
- | isSynFamilyTyCon fn, length tys == tyConArity fn
- = do { untch <- getUntouchables
- ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
-
-canEq fl cv s1 s2
- | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe s1,
- Just (t2a,t2b,t2c) <- splitCoPredTy_maybe s2
- = do { (v1,v2,v3)
- <- if isWanted fl then -- Wanted
- do { v1 <- newCoVar t1a t2a
- ; v2 <- newCoVar t1b t2b
- ; v3 <- newCoVar t1c t2c
- ; let res_co = mkCoPredCo (mkCoVarCoercion v1)
- (mkCoVarCoercion v2) (mkCoVarCoercion v3)
- ; setCoBind cv res_co
- ; return (v1,v2,v3) }
- else if isGiven fl then -- Given
- let co_orig = mkCoVarCoercion cv
- coa = mkCsel1Coercion co_orig
- cob = mkCsel2Coercion co_orig
- coc = mkCselRCoercion co_orig
- in do { v1 <- newGivenCoVar t1a t2a coa
- ; v2 <- newGivenCoVar t1b t2b cob
- ; v3 <- newGivenCoVar t1c t2c coc
- ; return (v1,v2,v3) }
- else -- Derived
- do { v1 <- newDerivedId (EqPred t1a t2a)
- ; v2 <- newDerivedId (EqPred t1b t2b)
- ; v3 <- newDerivedId (EqPred t1c t2c)
- ; return (v1,v2,v3) }
- ; cc1 <- canEq fl v1 t1a t2a
- ; cc2 <- canEq fl v2 t1b t2b
- ; cc3 <- canEq fl v3 t1c t2c
- ; return (cc1 `andCCan` cc2 `andCCan` cc3) }
-
-
-- Split up an equality between function types into two equalities.
canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
= do { (argv, resv) <-
@@ -455,11 +426,10 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
do { argv <- newCoVar s1 s2
; resv <- newCoVar t1 t2
; setCoBind cv $
- mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv)
+ mkFunCo (mkCoVarCo argv) (mkCoVarCo resv)
; return (argv,resv) }
-
- else if isGiven fl then
- let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv)
+ else if isGivenOrSolved fl then
+ let [arg,res] = decomposeCo 2 (mkCoVarCo cv)
in do { argv <- newGivenCoVar s1 s2 arg
; resv <- newGivenCoVar t1 t2 res
; return (argv,resv) }
@@ -473,33 +443,17 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
; cc2 <- canEq fl resv t1 t2
; return (cc1 `andCCan` cc2) }
-canEq fl cv (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2))
- | n1 == n2
- = if isWanted fl then
- do { v <- newCoVar t1 t2
- ; setCoBind cv $ mkIParamPredCo n1 (mkCoVarCoercion cv)
- ; canEq fl v t1 t2 }
- else return emptyCCan -- DV: How to decompose given IP coercions?
-
-canEq fl cv (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2))
- | c1 == c2
- = if isWanted fl then
- do { vs <- zipWithM newCoVar tys1 tys2
- ; setCoBind cv $ mkClassPPredCo c1 (map mkCoVarCoercion vs)
- ; andCCans <$> zipWith3M (canEq fl) vs tys1 tys2
- }
- else return emptyCCan
- -- How to decompose given dictionary (and implicit parameter) coercions?
- -- You may think that the following is right:
- -- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
- -- in zipWith3M newGivOrDerCoVar tys1 tys2 cos
- -- But this assumes that the coercion is a type constructor-based
- -- coercion, and not a PredTy (ClassP cn cos) coercion. So we chose
- -- to not decompose these coercions. We have to get back to this
- -- when we clean up the Coercion API.
+canEq fl cv (TyConApp fn tys) ty2
+ | isSynFamilyTyCon fn, length tys == tyConArity fn
+ = do { untch <- getUntouchables
+ ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
+canEq fl cv ty1 (TyConApp fn tys)
+ | isSynFamilyTyCon fn, length tys == tyConArity fn
+ = do { untch <- getUntouchables
+ ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- | isAlgTyCon tc1 && isAlgTyCon tc2
+ | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
, tc1 == tc2
, length tys1 == length tys2
= -- Generate equalities for each of the corresponding arguments
@@ -507,11 +461,10 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
<- if isWanted fl then
do { argsv <- zipWithM newCoVar tys1 tys2
; setCoBind cv $
- mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
- ; return argsv }
-
- else if isGiven fl then
- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
+ mkTyConAppCo tc1 (map mkCoVarCo argsv)
+ ; return argsv }
+ else if isGivenOrSolved fl then
+ let cos = decomposeCo (length tys1) (mkCoVarCo cv)
in zipWith3M newGivenCoVar tys1 tys2 cos
else -- Derived
@@ -524,28 +477,24 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
canEq fl cv ty1 ty2
| Just (s1,t1) <- tcSplitAppTy_maybe ty1
, Just (s2,t2) <- tcSplitAppTy_maybe ty2
- = do { (cv1,cv2) <-
- if isWanted fl
- then do { cv1 <- newCoVar s1 s2
- ; cv2 <- newCoVar t1 t2
- ; setCoBind cv $
- mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2)
- ; return (cv1,cv2) }
-
- else if isGiven fl then
- let co1 = mkLeftCoercion $ mkCoVarCoercion cv
- co2 = mkRightCoercion $ mkCoVarCoercion cv
- in do { cv1 <- newGivenCoVar s1 s2 co1
- ; cv2 <- newGivenCoVar t1 t2 co2
- ; return (cv1,cv2) }
- else -- Derived
- do { cv1 <- newDerivedId (EqPred s1 s2)
- ; cv2 <- newDerivedId (EqPred t1 t2)
- ; return (cv1,cv2) }
-
- ; cc1 <- canEq fl cv1 s1 s2
- ; cc2 <- canEq fl cv2 t1 t2
- ; return (cc1 `andCCan` cc2) }
+ = if isWanted fl
+ then do { cv1 <- newCoVar s1 s2
+ ; cv2 <- newCoVar t1 t2
+ ; setCoBind cv $
+ mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2)
+ ; cc1 <- canEq fl cv1 s1 s2
+ ; cc2 <- canEq fl cv2 t1 t2
+ ; return (cc1 `andCCan` cc2) }
+
+ else if isDerived fl
+ then do { cv1 <- newDerivedId (EqPred s1 s2)
+ ; cv2 <- newDerivedId (EqPred t1 t2)
+ ; cc1 <- canEq fl cv1 s1 s2
+ ; cc2 <- canEq fl cv2 t1 t2
+ ; return (cc1 `andCCan` cc2) }
+
+ else return emptyCCan -- We cannot decompose given applications
+ -- because we no longer have 'left' and 'right'
canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {})
| tcIsForAllTy s1, tcIsForAllTy s2,
@@ -749,10 +698,10 @@ canEqLeaf _untch fl cv cls1 cls2
| cls1 `re_orient` cls2
= do { cv' <- if isWanted fl
then do { cv' <- newCoVar s2 s1
- ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv')
+ ; setCoBind cv $ mkSymCo (mkCoVarCo cv')
; return cv' }
- else if isGiven fl then
- newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv))
+ else if isGivenOrSolved fl then
+ newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
else -- Derived
newDerivedId (EqPred s2 s1)
; canEqLeafOriented fl cv' cls2 s1 }
@@ -783,18 +732,18 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
- no_flattening_happened = isEmptyCCan ccs
- ; cv_new <- if no_flattening_happened then return cv
- else if isGiven fl then return cv
+ no_flattening_happened = all isReflCo (co2:cos1)
+ ; cv_new <- if no_flattening_happened then return cv
+ else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
-- cv' : F xis ~ xi2
; let -- fun_co :: F xis1 ~ F tys1
- fun_co = mkTyConCoercion fn cos1
+ fun_co = mkTyConAppCo fn cos1
-- want_co :: F tys1 ~ s2
- want_co = mkSymCoercion fun_co
- `mkTransCoercion` mkCoVarCoercion cv'
- `mkTransCoercion` co2
+ want_co = mkSymCo fun_co
+ `mkTransCo` mkCoVarCo cv'
+ `mkTransCo` co2
; setCoBind cv want_co
; return cv' }
else -- Derived
@@ -829,12 +778,12 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
- do { let no_flattening_happened = isEmptyCCan ccs2
- ; cv_new <- if no_flattening_happened then return cv
- else if isGiven fl then return cv
+ do { let no_flattening_happened = isReflCo co
+ ; cv_new <- if no_flattening_happened then return cv
+ else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2
- ; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co)
+ ; setCoBind cv (mkCoVarCo cv' `mkTransCo` co)
; return cv' }
else -- Derived
newDerivedId (EqPred (mkTyVarTy tv) xi2')
@@ -898,7 +847,7 @@ expandAway tv (FunTy ty1 ty2)
expandAway tv ty@(ForAllTy {})
= let (tvs,rho) = splitForAllTys ty
tvs_knds = map tyVarKind tvs
- in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
+ in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
-- Can't expand away the kinds unless we create
-- fresh variables which we don't want to do at this point.
Nothing
@@ -1057,15 +1006,15 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
; mapM (do_one subst) eqs }
where
fl' = case fl of
- Given _ -> panic "mkFunDepEqns"
+ Given {} -> panic "mkFunDepEqns"
Wanted loc -> Wanted (push_ctx loc)
Derived loc -> Derived (push_ctx loc)
push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
- = do { let sty1 = substTy subst ty1
- sty2 = substTy subst ty2
+ = do { let sty1 = Type.substTy subst ty1
+ sty2 = Type.substTy subst ty2
; ev <- newCoVar sty1 sty2
; return (i, mkEvVarX ev fl') }
@@ -1077,8 +1026,8 @@ rewriteDictParams param_eqs tys
where
do_one :: Type -> Int -> (Type,Coercion)
do_one ty n = case lookup n param_eqs of
- Just wev -> (get_fst_ty wev, mkCoVarCoercion (evVarOf wev))
- Nothing -> (ty,ty) -- Identity
+ Just wev -> (get_fst_ty wev, mkCoVarCo (evVarOf wev))
+ Nothing -> (ty, mkReflCo ty) -- Identity
get_fst_ty wev = case evVarOfPred wev of
EqPred ty1 _ -> ty1
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 8db89b9c07abffd1168f8a3aa43bfc1e390ab4ea..8fc8a24e7a522ecce3e255912cc634f8eacee143 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -8,19 +8,15 @@ Typechecking class declarations
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
- mkGenericDefMethBind, getGenericInstances,
+ mkGenericDefMethBind,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
import HsSyn
-import RnHsSyn
-import RnExpr
-import Inst
-import InstEnv
-import TcPat( addInlinePrags )
import TcEnv
+import TcPat( addInlinePrags )
import TcBinds
import TcUnify
import TcHsType
@@ -28,21 +24,15 @@ import TcMType
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
-import Generics
import Class
-import TyCon
-import MkId
import Id
import Name
-import Var
import NameEnv
import NameSet
+import Var
import Outputable
-import PrelNames
import DynFlags
import ErrUtils
-import Util
-import ListSetOps
import SrcLoc
import Maybes
import BasicTypes
@@ -50,7 +40,6 @@ import Bag
import FastString
import Control.Monad
-import Data.List
\end{code}
@@ -94,51 +83,43 @@ Death to "ExpandingDicts".
%************************************************************************
\begin{code}
-tcClassSigs :: Name -- Name of the class
+tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
- -> TcM [TcMethInfo]
-
+ -> TcM ([TcMethInfo], -- Exactly one for each method
+ NameEnv Type) -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
- = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
- (bagToList def_methods)
- ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
- where
- op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
- op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs]
-
-checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
- -- Check default bindings
- -- a) must be for a class op for this class
- -- b) must be all generic or all non-generic
-checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
- = do { -- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op)
-
- -- Check that all the defns ar generic, or none are
- ; case (none_generic, all_generic) of
- (True, _) -> return (op, VanillaDM)
- (_, True) -> return (op, GenericDM)
- _ -> failWith (mixedGenericErr op)
- }
- where
- n_generic = count (isJust . maybeGenericMatch) matches
- none_generic = n_generic == 0
- all_generic = matches `lengthIs` n_generic
+ = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+ ; let gen_dm_env = mkNameEnv gen_dm_prs
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+ ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+ ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+ ; sequence_ [ failWithTc (badMethodErr clas n)
+ | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
+ -- Value binding for non class-method (ie no TypeSig)
-tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
- -> LSig Name
- -> TcM TcMethInfo
+ ; sequence_ [ failWithTc (badGenericMethod clas n)
+ | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+ -- Generic signature without value binding
-tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
- = setSrcSpan loc $ do
- { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
- ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
- ; return (op_name, dm, op_ty) }
-tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
+ ; return (op_info, gen_dm_env) }
+ where
+ vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs]
+ gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
+ dm_bind_names :: [Name] -- These ones have a value binding in the class decl
+ dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+ tc_sig genop_env (L _ op_name, op_hs_ty)
+ = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
+ ; let dm | op_name `elemNameEnv` genop_env = GenericDM
+ | op_name `elem` dm_bind_names = VanillaDM
+ | otherwise = NoDM
+ ; return (op_name, dm, op_ty) }
+
+ tc_gen_sig (L _ op_name, gen_hs_ty)
+ = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+ ; return (op_name, gen_op_ty) }
\end{code}
@@ -174,20 +155,21 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
+ ; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
- this_dict default_binds
+ this_dict default_binds
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
- ; return (listToBag (catMaybes dm_binds)) }
+ ; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> SigFun -> PragFun -> ClassOpItem
- -> TcM (Maybe (LHsBind Id))
+ -> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic
@@ -196,40 +178,45 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
- NoDefMeth -> return Nothing
- GenDefMeth -> return Nothing
- DefMeth dm_name -> do
- { let sel_name = idName sel_id
- ; local_dm_name <- newLocalName sel_name
- -- Base the local_dm_name on the selector name, because
- -- type errors from tcInstanceMethodBody come from here
-
- -- See Note [Silly default-method bind]
- -- (possibly out of date)
-
- ; let meth_bind = findMethodBind sel_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- -- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
- dm_sig_fn _ = sig_fn sel_name
- dm_id = mkDefaultMethodId sel_id dm_name
- local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
- local_dm_id = mkLocalId local_dm_name local_dm_type
- prags = prag_fn sel_name
-
- ; dm_id_w_inline <- addInlinePrags dm_id prags
- ; spec_prags <- tcSpecPrags dm_id prags
-
- ; warnTc (not (null spec_prags))
- (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
- <+> quotes (ppr sel_name))
-
- ; liftM Just $
- tcInstanceMethodBody (ClsSkol clas)
- tyvars
- [this_dict]
- dm_id_w_inline local_dm_id
- dm_sig_fn IsDefaultMethod meth_bind }
+ NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+ ; return emptyBag }
+ DefMeth dm_name -> tc_dm dm_name
+ GenDefMeth dm_name -> tc_dm dm_name
+ where
+ sel_name = idName sel_id
+ prags = prag_fn sel_name
+ dm_sig_fn _ = sig_fn sel_name
+ dm_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+ -- Eg. class C a where
+ -- op :: forall b. Eq b => a -> [b] -> a
+ -- gen_op :: a -> a
+ -- generic gen_op :: D a => a -> a
+ -- The "local_dm_ty" is precisely the type in the above
+ -- type signatures, ie with no "forall a. C a =>" prefix
+
+ tc_dm dm_name
+ = do { dm_id <- tcLookupId dm_name
+ ; local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+ local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+ ; dm_id_w_inline <- addInlinePrags dm_id prags
+ ; spec_prags <- tcSpecPrags dm_id prags
+
+ ; warnTc (not (null spec_prags))
+ (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+ <+> quotes (ppr sel_name))
+
+ ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+ dm_id_w_inline local_dm_id dm_sig_fn
+ IsDefaultMethod dm_bind
+
+ ; return (unitBag tc_bind) }
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
@@ -246,7 +233,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
-
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $
@@ -359,179 +346,22 @@ gives rise to the instance declarations
op Unit = ...
\begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
- -- If the method is defined generically, we can only do the job if the
- -- instance declaration is for a single-parameter type class with
- -- a type constructor applied to type arguments in the instance decl
- -- (checkTc, so False provokes the error)
- do { checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys))
- ; checkTc (tyConHasGenerics tycon)
- (badGenericInstance sel_id (notGeneric tycon))
-
- ; dflags <- getDOpts
+ -- If the method is defined generically, we only have to call the
+ -- dm_name.
+ do { dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
- -- Rename it before returning it
- ; (rn_rhs, _) <- rnLExpr rhs
; return (noLoc $ mkFunBind (noLoc (idName sel_id))
- [mkSimpleMatch [] rn_rhs]) }
+ [mkSimpleMatch [] rhs]) }
where
- rhs = mkGenericRhs sel_id clas_tyvar tycon
-
- -- The tycon is only used in the generic case, and in that
- -- case we require that the instance decl is for a single-parameter
- -- type class with type variable arguments:
- -- instance (...) => C (T a b)
- clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
- Just tycon = maybe_tycon
- maybe_tycon = case inst_tys of
- [ty] -> case tcSplitTyConApp_maybe ty of
- Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
- _ -> Nothing
- _ -> Nothing
-
-
----------------------------
-getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
-getGenericInstances class_decls
- = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
- ; let { gen_inst_info = concat gen_inst_infos }
-
- -- Return right away if there is no generic stuff
- ; if null gen_inst_info then return []
- else do
-
- -- Otherwise print it out
- { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
- 2 (vcat (map pprInstInfoDetails gen_inst_info))
- ; return gen_inst_info }}
-
-get_generics :: TyClDecl Name -> TcM [InstInfo Name]
-get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
- | null generic_binds
- = return [] -- The comon case: no generic default methods
-
- | otherwise -- A source class decl with generic default methods
- = recoverM (return []) $
- tcAddDeclCtxt decl $ do
- clas <- tcLookupLocatedClass class_name
-
- -- Group by type, and
- -- make an InstInfo out of each group
- let
- groups = groupWith listToBag generic_binds
-
- inst_infos <- mapM (mkGenericInstance clas) groups
-
- -- Check that there is only one InstInfo for each type constructor
- -- The main way this can fail is if you write
- -- f {| a+b |} ... = ...
- -- f {| x+y |} ... = ...
- -- Then at this point we'll have an InstInfo for each
- --
- -- The class should be unary, which is why simpleInstInfoTyCon should be ok
- let
- tc_inst_infos :: [(TyCon, InstInfo Name)]
- tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
- bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
- group `lengthExceeds` 1]
- get_uniq (tc,_) = getUnique tc
-
- mapM_ (addErrTc . dupGenericInsts) bad_groups
-
- -- Check that there is an InstInfo for each generic type constructor
- let
- missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
-
- checkTc (null missing) (missingGenericInstances missing)
-
- return inst_infos
- where
- generic_binds :: [(HsType Name, LHsBind Name)]
- generic_binds = getGenericBinds def_methods
-get_generics decl = pprPanic "get_generics" (ppr decl)
-
-
----------------------------------
-getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
- -- Takes a group of method bindings, finds the generic ones, and returns
- -- them in finite map indexed by the type parameter in the definition.
-getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-
-getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
-getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
- = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
- where
- wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
-getGenericBind _
- = []
-
-groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
-groupWith _ [] = []
-groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
- where
- vs = map snd this
- (this,rest) = partition same_t prs
- same_t (t', _v) = t `eqPatType` t'
-
-eqPatLType :: LHsType Name -> LHsType Name -> Bool
-eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
-
-eqPatType :: HsType Name -> HsType Name -> Bool
--- A very simple equality function, only for
--- type patterns in generic function definitions.
-eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
-eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
-eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
-eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
-eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
-eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
-eqPatType _ _ = False
-
----------------------------------
-mkGenericInstance :: Class
- -> (HsType Name, LHsBinds Name)
- -> TcM (InstInfo Name)
-
-mkGenericInstance clas (hs_ty, binds) = do
- -- Make a generic instance declaration
- -- For example: instance (C a, C b) => C (a+b) where { binds }
-
- -- Extract the universally quantified type variables
- -- and wrap them as forall'd tyvars, so that kind inference
- -- works in the standard way
- let
- sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
- extractHsTyVars (noLoc hs_ty)
- hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-
- -- Type-check the instance type, and check its form
- forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
- let
- (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
-
- checkTc (validGenericInstanceType inst_ty)
- (badGenericInstanceType binds)
-
- -- Make the dictionary function.
- span <- getSrcSpanM
- overlap_flag <- getOverlapFlag
- dfun_name <- newDFunName clas [inst_ty] span
- let
- inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
- dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
- ispec = mkLocalInstance dfun_id overlap_flag
-
- return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
+ rhs = nlHsVar dm_name
\end{code}
-
%************************************************************************
%* *
Error messages
@@ -562,6 +392,11 @@ badMethodErr clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have a method"), quotes (ppr op)]
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+ = hsep [ptext (sLit "Class"), quotes (ppr clas),
+ ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
badATErr :: Class -> Name -> SDoc
badATErr clas at
= hsep [ptext (sLit "Class"), quotes (ppr clas),
@@ -570,23 +405,7 @@ badATErr clas at
omittedATWarn :: Name -> SDoc
omittedATWarn at
= ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
- = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
- because]
-
-notSimple :: [Type] -> SDoc
-notSimple inst_tys
- = vcat [ptext (sLit "because the instance type(s)"),
- nest 2 (ppr inst_tys),
- ptext (sLit "is not a simple type of form (T a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
- = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
- ptext (sLit "was not compiled with -XGenerics")]
-
+{-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
= vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
@@ -604,8 +423,10 @@ dupGenericInsts tc_inst_infos
]
where
ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
- = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+-}
+badDmPrag :: Id -> Sig Name -> TcM ()
+badDmPrag sel_id prag
+ = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
+ <+> quotes (ppr sel_id)
+ <+> ptext (sLit "lacks an accompanying binding"))
\end{code}
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 2988f08a38f76aa6718907368a9d29788a2bd3c3..fab7c61ff07cd2e388a1bf4a0d7141255c112e18 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -40,10 +40,13 @@ import Name
import NameSet
import TyCon
import TcType
+import BuildTyCl
+import BasicTypes
import Var
import VarSet
import PrelNames
import SrcLoc
+import UniqSupply
import Util
import ListSetOps
import Outputable
@@ -125,6 +128,9 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+ ppr = pprDerivSpec
\end{code}
@@ -292,17 +298,21 @@ both of them. So we gather defs/uses from deriving just like anything else.
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> [LInstDecl Name] -- All instance declarations
-> [LDerivDecl Name] -- All stand-alone deriving declarations
- -> TcM ([InstInfo Name], -- The generated "instance decls"
- HsValBinds Name, -- Extra generated top-level bindings
- DefUses)
+ -> TcM ([InstInfo Name] -- The generated "instance decls"
+ ,HsValBinds Name -- Extra generated top-level bindings
+ ,DefUses
+ ,[TyCon] -- Extra generated top-level types
+ ,[TyCon]) -- Extra generated type family instances
tcDeriving tycl_decls inst_decls deriv_decls
- = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
+ = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
; traceTc "tcDeriving" (ppr is_boot)
- ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; (early_specs, genericsExtras)
+ <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
@@ -313,20 +323,44 @@ tcDeriving tycl_decls inst_decls deriv_decls
; insts2 <- mapM (genInst False overlap_flag) final_specs
- -- Generate the generic to/from functions from each type declaration
- ; gen_binds <- mkGenericBinds is_boot tycl_decls
- ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
+ -- We no longer generate the old generic to/from functions
+ -- from each type declaration, so this is emptyBag
+ ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+
+ ; (inst_info, rn_binds, rn_dus)
+ <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
+ ; dflags <- getDOpts
+ ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+ (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
+{-
; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-
- ; return (inst_info, rn_binds, rn_dus) }
+-}
+ ; return ( inst_info, rn_binds, rn_dus
+ , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
where
- ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
- ddump_deriving inst_infos extra_binds
- = hang (ptext (sLit "Derived instances"))
- 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
- $$ ppr extra_binds)
+ ddump_deriving :: [InstInfo Name] -> HsValBinds Name
+ -> [MetaTyCons] -- ^ Empty data constructors
+ -> [TyCon] -- ^ Rep type family instances
+ -> [[(InstInfo RdrName, DerivAuxBinds)]]
+ -- ^ Instances for the repMetaTys
+ -> SDoc
+ ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+ = hang (ptext (sLit "Derived instances"))
+ 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+ $$ ppr extra_binds)
+ $$ hangP "Generic representation" (
+ hangP "Generated datatypes for meta-information"
+ (vcat (map ppr repMetaTys))
+ -- The Outputable instance for TyCon unfortunately only prints the name...
+ $$ hangP "Representation types"
+ (vcat (map ppr repTyCons))
+ $$ hangP "Meta-information instances"
+ (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
+
+ hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+
renameDeriv :: Bool -> LHsBinds RdrName
-> [(InstInfo RdrName, DerivAuxBinds)]
@@ -379,26 +413,12 @@ renameDeriv is_boot gen_binds insts
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
- do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas
-
------------------------------------------
-mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
-mkGenericBinds is_boot tycl_decls
- | is_boot
- = return emptyBag
- | otherwise
- = do { tcs <- mapM tcLookupTyCon [ tcdName d
- | L _ d <- tycl_decls, isDataDecl d ]
- ; return (unionManyBags [ mkTyConGenericBinds tc
- | tc <- tcs, tyConHasGenerics tc ]) }
- -- We are only interested in the data type declarations,
- -- and then only in the ones whose 'has-generics' flag is on
- -- The predicate tyConHasGenerics finds both of these
\end{code}
Note [Newtype deriving and unused constructors]
@@ -430,34 +450,93 @@ stored in NewTypeDerived.
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
+-- Make the "extras" for the generic representation
+mkGenDerivExtras :: TyCon
+ -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
+mkGenDerivExtras tc = do
+ { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
+ ; metaInsts <- genDtMeta (tc, metaTyCons)
+ ; return (metaTyCons, rep0TyInst, metaInsts) }
+
makeDerivSpecs :: Bool
-> [LTyClDecl Name]
- -> [LInstDecl Name]
+ -> [LInstDecl Name]
-> [LDerivDecl Name]
- -> TcM [EarlyDerivSpec]
-
+ -> TcM ( [EarlyDerivSpec]
+ , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
- | is_boot -- No 'deriving' at all in hs-boot files
- = do { mapM_ add_deriv_err deriv_locs
- ; return [] }
+ | is_boot -- No 'deriving' at all in hs-boot files
+ = do { mapM_ add_deriv_err deriv_locs
+ ; return ([],[]) }
| otherwise
- = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
- ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
- ; return (eqns1 ++ eqns2) }
+ = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
+ ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
+
+ -- Generic representation stuff: we might need to add some "extras"
+ -- to the instances
+ ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
+ ; generic_extras_deriv <- if not xDerRep
+ -- No extras if the flag is off
+ then (return [])
+ else do {
+ let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+ -- Select only those types that derive Generic
+ ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+ , getClassName c == Just genClassName ]
+ ; let sel_deriv_decls = catMaybes [ getTypeName t
+ | L _ (DerivDecl (L _ t)) <- deriv_decls
+ , getClassName t == Just genClassName ]
+ ; derTyDecls <- mapM tcLookupTyCon $
+ filter (needsExtras xDerRep
+ (sel_tydata ++ sel_deriv_decls)) allTyNames
+ -- We need to generate the extras to add to what has
+ -- already been derived
+ ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
+ pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
+ pprTrace "derTyDecls" (ppr derTyDecls) $
+ pprTrace "deriv_decls" (ppr deriv_decls) $ -}
+ mapM mkGenDerivExtras derTyDecls }
+
+ -- Merge and return
+ ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
where
+ -- We need extras if the flag DeriveGeneric is on and this type is
+ -- deriving Generic
+ needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
+
+ -- Extracts the name of the class in the deriving
+ getClassName :: HsType Name -> Maybe Name
+ getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
+ getClassName (HsPredTy (HsClassP n _)) = Just n
+ getClassName _ = Nothing
+
+ -- Extracts the name of the type in the deriving
+ -- This function (and also getClassName above) is not really nice, and I
+ -- might not have covered all possible cases. I wonder if there is no easier
+ -- way to extract class and type name from a LDerivDecl...
+ getTypeName :: HsType Name -> Maybe Name
+ getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n
+ getTypeName (HsTyVar n) = Just n
+ getTypeName (HsOpTy _ (L _ n) _) = Just n
+ getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+ getTypeName (HsAppTy (L _ n) _) = getTypeName n
+ getTypeName (HsParTy (L _ n)) = getTypeName n
+ getTypeName (HsKindSig (L _ n) _) = getTypeName n
+ getTypeName _ = Nothing
+
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
all_tydata :: [(LHsType Name, LTyClDecl Name)]
- -- Derived predicate paired with its data type declaration
+ -- Derived predicate paired with its data type declaration
all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
deriv_locs = map (getLoc . snd) all_tydata
- ++ map getLoc deriv_decls
+ ++ map getLoc deriv_decls
add_deriv_err loc = setSrcSpan loc $
- addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
- 2 (ptext (sLit "Use an instance declaration instead")))
+ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+ 2 (ptext (sLit "Use an instance declaration instead")))
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
@@ -727,6 +806,11 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints _ cls inst_tys rep_tc rep_tc_args
+ -- Generic constraints are easy
+ | cls `hasKey` genClassKey
+ = []
+ -- The others are a bit more complicated
+ | otherwise
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
stupid_constraints ++ extra_constraints
++ sc_constraints ++ con_arg_constraints
@@ -830,6 +914,8 @@ sideConditions mtheta cls
cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
| cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
cond_functorOK False)
+ | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
+ checkFlag Opt_DeriveGeneric)
| otherwise = Nothing
where
cls_key = getUnique cls
@@ -848,7 +934,7 @@ orCond c1 c2 tc
Nothing -> Nothing -- c1 succeeds
Just x -> case c2 tc of -- c1 fails
Nothing -> Nothing
- Just y -> Just (x $$ ptext (sLit " and") $$ y)
+ Just y -> Just (x $$ ptext (sLit " or") $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
@@ -874,11 +960,14 @@ cond_stdOK Nothing (_, rep_tc)
check_con con
| isVanillaDataCon con
, all isTauTy (dataConOrigArgTys con) = Nothing
- | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
+ | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
no_cons_why :: TyCon -> SDoc
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "has no data constructors")
+ ptext (sLit "must have at least one data constructor")
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) = canDoGenerics t
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond`
@@ -893,7 +982,7 @@ cond_noUnliftedArgs (_, tc)
where
bad_cons = [ con | con <- tyConDataCons tc
, any isUnLiftedType (dataConOrigArgTys con) ]
- why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
+ why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
cond_isEnumeration :: Condition
cond_isEnumeration (_, rep_tc)
@@ -901,7 +990,7 @@ cond_isEnumeration (_, rep_tc)
| otherwise = Just why
where
why = sep [ quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "is not an enumeration type")
+ ptext (sLit "must be an enumeration type")
, ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
-- See Note [Enumeration types] in TyCon
@@ -911,7 +1000,7 @@ cond_isProduct (_, rep_tc)
| otherwise = Just why
where
why = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "does not have precisely one constructor")
+ ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
@@ -924,9 +1013,9 @@ cond_typeableOK (_, tc)
| otherwise = Nothing
where
too_many = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has too many arguments")
+ ptext (sLit "must have 7 or fewer arguments")
bad_kind = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has arguments of kind other than `*'")
+ ptext (sLit "must only have arguments of kind `*'")
functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
@@ -941,11 +1030,11 @@ cond_functorOK :: Bool -> Condition
cond_functorOK allowFunctions (_, rep_tc)
| null tc_tvs
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has no parameters"))
+ <+> ptext (sLit "must have some type parameters"))
| not (null bad_stupid_theta)
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+ <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
| otherwise
= msum (map check_con data_cons) -- msum picks the first 'Just', if any
@@ -972,10 +1061,10 @@ cond_functorOK allowFunctions (_, rep_tc)
, ft_bad_app = Just (badCon con wrong_arg)
, ft_forall = \_ x -> x }
- existential = ptext (sLit "has existential arguments")
- covariant = ptext (sLit "uses the type variable in a function argument")
- functions = ptext (sLit "contains function types")
- wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
+ existential = ptext (sLit "must not have existential arguments")
+ covariant = ptext (sLit "must not use the type variable in a function argument")
+ functions = ptext (sLit "must not contain function types")
+ wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last")
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
@@ -999,11 +1088,11 @@ std_class_via_iso clas
non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
- = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
- typeableClassKeys)
+ = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+ , genClassKey] ++ typeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
@@ -1282,7 +1371,7 @@ inferInstanceContexts oflag infer_specs
gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
, ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
= setSrcSpan loc $
- addErrCtxt (derivInstCtxt clas inst_tys) $
+ addErrCtxt (derivInstCtxt the_pred) $
do { -- Check for a bizarre corner case, when the derived instance decl should
-- have form instance C a b => D (T a) where ...
-- Note that 'b' isn't a parameter of T. This gives rise to all sorts
@@ -1294,10 +1383,10 @@ inferInstanceContexts oflag infer_specs
; let tv_set = mkVarSet tyvars
weird_preds = [pred | pred <- deriv_rhs
- , not (tyVarsOfPred pred `subVarSet` tv_set)]
+ , not (tyVarsOfPred pred `subVarSet` tv_set)]
; mapM_ (addErrTc . badDerivedPred) weird_preds
- ; theta <- simplifyDeriv orig tyvars deriv_rhs
+ ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
@@ -1307,6 +1396,8 @@ inferInstanceContexts oflag infer_specs
-- Hence no need to call:
-- checkValidInstance tyvars theta clas inst_tys
; return (sortLe (<=) theta) } -- Canonicalise before returning the solution
+ where
+ the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
@@ -1423,14 +1514,12 @@ genInst standalone_deriv oflag
where
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
- Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+ Just co_con -> mkAxInstCo co_con rep_tc_args
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
- co2 = case newTyConCo_maybe rep_tycon of
- Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
- Nothing -> id_co -- The newtype is transparent; no need for a cast
- co = co1 `mkTransCoI` co2
- id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
+ co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
+ co = co1 `mkTransCo` co2
+ id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
-- Example: newtype instance N [a] = N1 (Tree a)
-- deriving instance Eq b => Eq (N [(b,b)])
@@ -1451,20 +1540,159 @@ genDerivBinds loc fix_env clas tycon
Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
- gen_list = [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds fix_env)
- ,(readClassKey, gen_Read_binds fix_env)
- ,(dataClassKey, gen_Data_binds)
- ,(functorClassKey, gen_Functor_binds)
- ,(foldableClassKey, gen_Foldable_binds)
- ,(traversableClassKey, gen_Traversable_binds)
+ gen_list = [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ,(showClassKey, gen_Show_binds fix_env)
+ ,(readClassKey, gen_Read_binds fix_env)
+ ,(dataClassKey, gen_Data_binds)
+ ,(functorClassKey, gen_Functor_binds)
+ ,(foldableClassKey, gen_Foldable_binds)
+ ,(traversableClassKey, gen_Traversable_binds)
+ ,(genClassKey, genGenericBinds)
]
\end{code}
+%************************************************************************
+%* *
+\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
+%* *
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@genGenericBinds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericAll@ does all of them
+
+\begin{code}
+genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
+
+genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc =
+ do uniqS <- newUniqueSupply
+ let
+ -- Uniques for everyone
+ (uniqD:uniqs) = uniqsFromSupply uniqS
+ (uniqsC,us) = splitAt (length tc_cons) uniqs
+ uniqsS :: [[Unique]] -- Unique supply for the S datatypes
+ uniqsS = mkUniqsS tc_arits us
+ mkUniqsS [] _ = []
+ mkUniqsS (n:t) us = case splitAt n us of
+ (us1,us2) -> us1 : mkUniqsS t us2
+
+ tc_name = tyConName tc
+ tc_cons = tyConDataCons tc
+ tc_arits = map dataConSourceArity tc_cons
+
+ tc_occ = nameOccName tc_name
+ d_occ = mkGenD tc_occ
+ c_occ m = mkGenC tc_occ m
+ s_occ m n = mkGenS tc_occ m n
+ mod_name = nameModule (tyConName tc)
+ d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
+ c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
+ | (u,m) <- zip uniqsC [0..] ]
+ s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
+ | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
+
+ mkTyCon name = ASSERT( isExternalName name )
+ buildAlgTyCon name [] [] mkAbstractTyConRhs
+ NonRecursive False NoParentTyCon Nothing
+
+ metaDTyCon <- mkTyCon d_name
+ metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
+ metaSTyCons <- mapM sequence
+ [ [ mkTyCon s_name
+ | s_name <- s_namesC ] | s_namesC <- s_names ]
+
+ let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
+
+ rep0_tycon <- tc_mkRepTyCon tc metaDts
+
+ -- pprTrace "rep0" (ppr rep0_tycon) $
+ return (metaDts, rep0_tycon)
+{-
+genGenericAll :: TyCon
+ -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericAll tc =
+ do (metaDts, rep0_tycon) <- genGenericRepExtras tc
+ clas <- tcLookupClass genClassName
+ dfun_name <- new_dfun_name clas tc
+ let
+ mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
+ , [ {- No DerivAuxBinds -} ])
+ inst = mkLocalInstance dfun NoOverlap
+ binds = VanillaInst (mkBindsRep tc) [] False
+
+ tvs = tyConTyVars tc
+ tc_ty = mkTyConApp tc (mkTyVarTys tvs)
+
+ dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
+ return (mkInstRep, metaDts, rep0_tycon)
+-}
+genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
+genDtMeta (tc,metaDts) =
+ do dClas <- tcLookupClass datatypeClassName
+ d_dfun_name <- new_dfun_name dClas tc
+ cClas <- tcLookupClass constructorClassName
+ c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
+ sClas <- tcLookupClass selectorClassName
+ s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
+ | _ <- x ]
+ | x <- metaS metaDts ])
+ fix_env <- getFixityEnv
+
+ let
+ (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+
+ -- Datatype
+ d_metaTycon = metaD metaDts
+ d_inst = mkLocalInstance d_dfun NoOverlap
+ d_binds = VanillaInst dBinds [] False
+ d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
+ [ mkTyConTy d_metaTycon ]
+ d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
+
+ -- Constructor
+ c_metaTycons = metaC metaDts
+ c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap
+ | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
+ c_binds = [ VanillaInst c [] False | c <- cBinds ]
+ c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
+ [ mkTyConTy c ]
+ c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, [])
+ | (is,bs) <- myZip1 c_insts c_binds ]
+
+ -- Selector
+ s_metaTycons = metaS metaDts
+ s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
+ (myZip2 s_metaTycons s_dfun_names)
+ s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
+ s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
+ [ mkTyConTy s ]
+ s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
+ (myZip2 s_insts s_binds)
+
+ myZip1 :: [a] -> [b] -> [(a,b)]
+ myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
+
+ myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
+ myZip2 l1 l2 =
+ ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
+ [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
+
+ return (d_mkInst : c_mkInst ++ concat s_mkInst)
+\end{code}
+
%************************************************************************
%* *
@@ -1511,9 +1739,9 @@ standaloneCtxt :: LHsType Name -> SDoc
standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
2 (quotes (ppr ty))
-derivInstCtxt :: Class -> [Type] -> Message
-derivInstCtxt clas inst_tys
- = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+derivInstCtxt :: PredType -> Message
+derivInstCtxt pred
+ = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
badDerivedPred :: PredType -> Message
badDerivedPred pred
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 354e4b238aa07cabc3b11d3360c7ea3d203d791e..96dc2614e359dfce4fc437d6df51b62ace923c5d 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -211,7 +211,7 @@ tcLookupFamInst tycon tys
}
tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
--- Find the instance of a data famliy
+-- Find the instance of a data family
-- Note [Looking up family instances for deriving]
tcLookupDataFamInst tycon tys
| not (isFamilyTyCon tycon)
@@ -461,7 +461,7 @@ tcExtendGlobalTyVars gtv_var extra_global_tvs
\begin{code}
tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
-- Just pop the new rules into the EPS and envt resp
- -- All the rules come from an interface file, not soruce
+ -- All the rules come from an interface file, not source
-- Nevertheless, some may be for this module, if we read
-- its interface instead of its source code
tcExtendRules lcl_rules thing_inside
@@ -626,7 +626,7 @@ data InstBindings a
-- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
- CoercionI -- The coercion maps from newtype to the representation type
+ Coercion -- The coercion maps from newtype to the representation type
-- (mentioning type variables bound by the forall'd iSpec variables)
-- E.g. newtype instance N [a] = N1 (Tree a)
-- co : N [a] ~ Tree a
@@ -640,7 +640,7 @@ data InstBindings a
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = hang (ptext (sLit "instance"))
2 (sep [ ifPprDebug (pprForAll tvs)
- , pprThetaArrow theta, ppr tau
+ , pprThetaArrowTy theta, ppr tau
, ptext (sLit "where")])
where
(tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
@@ -681,7 +681,7 @@ newDFunName clas tys loc
\end{code}
Make a name for the representation tycon of a family instance. It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
newGlobalBinder.
\begin{code}
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index f714943227dad386d0f552b15a438a2a04e7394c..b199053ac2e5bbebe6452a0298035b51919ce651 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -15,14 +15,14 @@ import TcMType
import TcSMonad
import TcType
import TypeRep
-
+import Type( isTyVarTy )
+import Unify ( tcMatchTys )
import Inst
import InstEnv
-
import TyCon
import Name
import NameEnv
-import Id ( idType )
+import Id ( idType, evVarPred )
import Var
import VarSet
import VarEnv
@@ -105,7 +105,7 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
-- because they are unconditionally wrong
-- Moreover, if any of the insolubles are givens, stop right there
-- ignoring nested errors, because the code is inaccessible
- = do { let (given, other) = partitionBag (isGiven . evVarX) insols
+ = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
insol_implics = filterBag ic_insol implics
; if isEmptyBag given
then do { mapBagM_ (reportInsoluble ctxt) other
@@ -153,7 +153,8 @@ reportInsoluble ctxt (EvVarX ev flav)
| otherwise
= pprPanic "reportInsoluble" (pprEvVarWithType ev)
where
- inaccessible_msg | Given loc <- flav
+ inaccessible_msg | Given loc GivenOrig <- flav
+ -- If a GivenSolved then we should not report inaccessible code
= hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
| otherwise = empty
@@ -222,7 +223,7 @@ pprWithArising ev_vars
where
first_loc = evVarX (head ev_vars)
ppr_one (EvVarX v loc)
- = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
+ = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
@@ -299,8 +300,8 @@ getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp
ty1 ty2
-- If the types in the error message are the same as the types we are unifying,
-- don't add the extra expected/actual message
- | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
- | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
+ | act `eqType` ty1 && exp `eqType` ty2 = empty
+ | exp `eqType` ty1 && act `eqType` ty2 = empty
| otherwise = mkExpectedActualMsg act exp
getWantedEqExtra orig _ _ = pprArising orig
@@ -320,15 +321,10 @@ reportEqErr ctxt ty1 ty2
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
-- tv1 and ty2 are already tidied
reportTyVarEqErr ctxt tv1 ty2
- | not is_meta1
- , Just tv2 <- tcGetTyVar_maybe ty2
- , isMetaTyVar tv2
- = -- sk ~ alpha: swap
- reportTyVarEqErr ctxt tv2 ty1
-
- | (not is_meta1)
- = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
- addErrorReport (addExtraInfo ctxt ty1 ty2)
+ | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would
+ -- be oriented the other way round; see TcCanonical.reOrient
+ || isSigTyVar tv1 && not (isTyVarTy ty2)
+ = addErrorReport (addExtraInfo ctxt ty1 ty2)
(misMatchOrCND ctxt ty1 ty2)
-- So tv is a meta tyvar, and presumably it is
@@ -376,21 +372,26 @@ reportTyVarEqErr ctxt tv1 ty2
, ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
- | otherwise -- This can happen, by a recursive decomposition of frozen
- -- occurs check constraints
- -- Example: alpha ~ T Int alpha has frozen.
- -- Then alpha gets unified to T beta gamma
- -- So now we have T beta gamma ~ T Int (T beta gamma)
- -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
- -- The (gamma ~ T beta gamma) is the occurs check, but
- -- the (beta ~ Int) isn't an error at all. So return ()
- = return ()
-
+ | otherwise
+ = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
+ return ()
+ -- I don't think this should happen, and if it does I want to know
+ -- Trac #5130 happened because an actual type error was not
+ -- reported at all! So not reporting is pretty dangerous.
+ --
+ -- OLD, OUT OF DATE COMMENT
+ -- This can happen, by a recursive decomposition of frozen
+ -- occurs check constraints
+ -- Example: alpha ~ T Int alpha has frozen.
+ -- Then alpha gets unified to T beta gamma
+ -- So now we have T beta gamma ~ T Int (T beta gamma)
+ -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
+ -- The (gamma ~ T beta gamma) is the occurs check, but
+ -- the (beta ~ Int) isn't an error at all. So return ()
where
- is_meta1 = isMetaTyVar tv1
- k1 = tyVarKind tv1
- k2 = typeKind ty2
- ty1 = mkTyVarTy tv1
+ k1 = tyVarKind tv1
+ k2 = typeKind ty2
+ ty1 = mkTyVarTy tv1
mkTyFunInfoMsg :: TcType -> TcType -> SDoc
-- See Note [Non-injective type functions]
@@ -419,18 +420,18 @@ couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig)
= vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
2 (pprArising orig)
- , vcat pp_givens ]
- where
- pp_givens
- = case givens of
+ , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens
+ = case givens of
[] -> []
(g:gs) -> ppr_given (ptext (sLit "from the context")) g
: map (ppr_given (ptext (sLit "or from"))) gs
-
- ppr_given herald (gs,loc)
- = hang (herald <+> pprEvVarTheta gs)
- 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
- , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+ where ppr_given herald (gs,loc)
+ = hang (herald <+> pprEvVarTheta gs)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
@@ -458,12 +459,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc
-- Shows a bit of extra info about skolem constants
typeExtraInfoMsg implics ty
| Just tv <- tcGetTyVar_maybe ty
- , isTcTyVar tv
- , isSkolemTyVar tv
- = pprSkolTvBinding implics tv
- where
-typeExtraInfoMsg _ _ = empty -- Normal case
-
+ , isTcTyVar tv, isSkolemTyVar tv
+ , let pp_tv = quotes (ppr tv)
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
+ FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
+ RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
+ MetaTv {} -> empty
+
+ | otherwise -- Normal case
+ = empty
+
+ where
+ ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful
+ ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"),
+ sep [ppr info, ptext (sLit "at") <+> ppr loc]]
+
--------------------
unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
@@ -563,9 +574,21 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
mk_overlap_msg (matches, unifiers)
= ASSERT( not (null matches) )
vcat [ addArising orig (ptext (sLit "Overlapping instances for")
- <+> pprPred pred)
+ <+> pprPredTy pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+ , if not (null overlapping_givens) then
+ sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+ else empty
+
+ , if null overlapping_givens && isSingleton matches && null unifiers then
+ -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
+ -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+ -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+ sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+ else empty
+
, if not (isSingleton matches)
then -- Two or more matches
empty
@@ -573,11 +596,39 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
- ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
- ptext (sLit "when compiling the other instance declarations")])]
+ if null (overlapping_givens) then
+ vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+ ptext (sLit "when compiling the other instance declarations")]
+ else empty])]
where
ispecs = [ispec | (ispec, _) <- matches]
+ givens = getUserGivens ctxt
+ overlapping_givens = unifiable_givens givens
+
+ unifiable_givens [] = []
+ unifiable_givens (gg:ggs)
+ | Just ggdoc <- matchable gg
+ = ggdoc : unifiable_givens ggs
+ | otherwise
+ = unifiable_givens ggs
+
+ matchable (evvars,gloc)
+ = case ev_vars_matching of
+ [] -> Nothing
+ _ -> Just $ hang (pprTheta ev_vars_matching)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+ where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+ ev_var_matches (ClassP clas' tys')
+ | clas' == clas
+ , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+ = True
+ ev_var_matches (ClassP clas' tys') =
+ any ev_var_matches (immSuperClasses clas' tys')
+ ev_var_matches _ = False
+
+
reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
----------------------
@@ -659,7 +710,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
- ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
; return (tidy_env, mk_msg dflags docs) }
where
@@ -685,28 +735,6 @@ monomorphism_fix dflags
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
-
-pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
--- Print info about the binding of a skolem tyvar,
--- or nothing if we don't have anything useful to say
-pprSkolTvBinding implics tv
- | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
- | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv)
- where
- ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv)
- ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
- ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem")
- ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
- <+> quotes (ppr n)
- ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable")
-
-
- ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
- ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
- ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
- sep [ppr info,
- ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
-
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
= WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
@@ -846,9 +874,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
\end{code}
%************************************************************************
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 6bb08208233fb685de711d9f51d096f2df969750..ee6a34ac065cbb6ee010f6a6c05ec5cba0c3af27 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -45,6 +45,7 @@ import Type
import Coercion
import Var
import VarSet
+import VarEnv
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
@@ -55,6 +56,7 @@ import SrcLoc
import Util
import ListSetOps
import Maybes
+import ErrUtils
import Outputable
import FastString
import Control.Monad
@@ -286,8 +288,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
; co_res <- unifyType op_res_ty res_ty
; op_id <- tcLookupId op_name
; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
- ; return $ mkHsWrapCoI co_res $
- OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
| otherwise
= do { traceTc "Non Application rule" (ppr op)
@@ -295,8 +297,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType op_res_ty res_ty
; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
- ; return $ mkHsWrapCoI co_res $
- OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
@@ -306,8 +308,8 @@ tcExpr (SectionR op arg2) res_ty
; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op (arg2, arg2_ty, 2)
- ; return $ mkHsWrapCoI co_res $
- SectionR (mkLHsWrapCoI co_fn op') arg2' }
+ ; return $ mkHsWrapCo co_res $
+ SectionR (mkLHsWrapCo co_fn op') arg2' }
tcExpr (SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
@@ -318,15 +320,15 @@ tcExpr (SectionL arg1 op) res_ty
; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op (arg1, arg1_ty, 1)
- ; return $ mkHsWrapCoI co_res $
- SectionL arg1' (mkLHsWrapCoI co_fn op') }
+ ; return $ mkHsWrapCo co_res $
+ SectionL arg1' (mkLHsWrapCo co_fn op') }
tcExpr (ExplicitTuple tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let tup_tc = tupleTyCon boxity (length tup_args)
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
| otherwise
= -- The tup_args are a mixture of Present and Missing (for tuple sections)
@@ -345,19 +347,19 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
-- Handle tuple sections where
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
tcExpr (ExplicitList _ exprs) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
\end{code}
@@ -415,12 +417,12 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
-- and it maintains uniformity with other rebindable syntax
; return (HsIf (Just fun') pred' b1' b2') }
-tcExpr (HsDo do_or_lc stmts body _) res_ty
- = tcDoStmts do_or_lc stmts body res_ty
+tcExpr (HsDo do_or_lc stmts _) res_ty
+ = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
- ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
+ ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
@@ -467,7 +469,7 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
; co_res <- unifyType actual_res_ty res_ty
; rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordCon (L loc con_id) con_expr rbinds' }
\end{code}
@@ -603,7 +605,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-- Take apart a representative constructor
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
- (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
+ (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
con1_flds = dataConFieldLabels con1
con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
@@ -641,10 +643,10 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
- ; let rec_res_ty = substTy result_inst_env con1_res_ty
- con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+ ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
- scrut_ty = substTy scrut_subst con1_res_ty
+ scrut_ty = TcType.substTy scrut_subst con1_res_ty
; co_res <- unifyType rec_res_ty res_ty
@@ -659,11 +661,11 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
- = WpCast $ mkTyConApp co_con scrut_inst_tys
+ = WpCast $ mkAxInstCo co_con scrut_inst_tys
| otherwise
= idHsWrapper
-- Phew!
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys }
where
@@ -703,7 +705,7 @@ tcExpr (ArithSeq _ seq@(From expr)) res_ty
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName elt_ty
- ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
+ ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
@@ -711,7 +713,7 @@ tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_then (FromThen expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
@@ -720,7 +722,7 @@ tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
@@ -730,7 +732,7 @@ tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
@@ -739,7 +741,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
(enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(PArrSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
@@ -749,7 +751,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
(enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
@@ -820,15 +822,15 @@ tcApp fun args res_ty
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
- ; co_res <- addErrCtxt (funResCtxt fun) $
+ ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
-- Assemble the result
- ; let fun2 = mkLHsWrapCoI co_fun fun1
- app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
+ ; let fun2 = mkLHsWrapCo co_fun fun1
+ app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
; return (unLoc app) }
@@ -850,7 +852,7 @@ tcInferApp fun args
; (co_fun, expected_arg_tys, actual_res_ty)
<- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
; args1 <- tcArgs fun args expected_arg_tys
- ; let fun2 = mkLHsWrapCoI co_fun fun1
+ ; let fun2 = mkLHsWrapCo co_fun fun1
app = foldl mkHsApp fun2 args1
; return (unLoc app, actual_res_ty) }
@@ -899,7 +901,7 @@ tcTupArgs args tys
----------------
unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
- -> TcM (CoercionI, [TcSigmaType], TcRhoType)
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
-- A wrapper for matchExpectedFunTys
unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
where
@@ -1010,7 +1012,7 @@ instantiateOuter orig id
; let theta' = substTheta subst theta
; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
; wrap <- instCall orig tys theta'
- ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
+ ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
where
(tvs, theta, tau) = tcSplitSigmaTy (idType id)
\end{code}
@@ -1134,7 +1136,7 @@ tcTagToEnum loc fun_name arg res_ty
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
rep_ty = mkTyConApp rep_tc rep_args
- ; return (mkHsWrapCoI coi $ HsApp fun' arg') }
+ ; return (mkHsWrapCo coi $ HsApp fun' arg') }
where
doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
, ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
@@ -1142,18 +1144,18 @@ tcTagToEnum loc fun_name arg res_ty
doc3 = ptext (sLit "No family instance for this type")
get_rep_ty :: TcType -> TyCon -> [TcType]
- -> TcM (CoercionI, TyCon, [TcType])
+ -> TcM (Coercion, TyCon, [TcType])
-- Converts a family type (eg F [a]) to its rep type (eg FList a)
-- and returns a coercion between the two
get_rep_ty ty tc tc_args
| not (isFamilyTyCon tc)
- = return (IdCo ty, tc, tc_args)
+ = return (mkReflCo ty, tc, tc_args)
| otherwise
= do { mb_fam <- tcLookupFamInst tc tc_args
; case mb_fam of
Nothing -> failWithTc (tagToEnumError ty doc3)
Just (rep_tc, rep_args)
- -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
+ -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
, rep_tc, rep_args )
where
co_tc = expectJust "tcTagToEnum" $
@@ -1386,9 +1388,23 @@ funAppCtxt fun arg arg_no
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
-funResCtxt :: LHsExpr Name -> SDoc
-funResCtxt fun
- = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+funResCtxt :: LHsExpr Name -> TcType -> TcType
+ -> TidyEnv -> TcM (TidyEnv, Message)
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+funResCtxt fun fun_res_ty res_ty env0
+ = do { fun_res' <- zonkTcType fun_res_ty
+ ; res' <- zonkTcType res_ty
+ ; let n_fun = length (fst (tcSplitFunTys fun_res'))
+ n_res = length (fst (tcSplitFunTys res'))
+ what | n_fun > n_res = ptext (sLit "few")
+ | otherwise = ptext (sLit "many")
+ extra | n_fun == n_res = empty
+ | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+ <+> ptext (sLit "is applied to too") <+> what
+ <+> ptext (sLit "arguments")
+ msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+ ; return (env0, msg $$ extra) }
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 73fd449d32ce7e9bcb87fe255e238664e130af6b..8f53d6e7b8bd5b49e1544e62d74a8193ce8e73d1 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.
\begin{code}
-module TcForeign
- (
- tcForeignImports
+module TcForeign
+ (
+ tcForeignImports
, tcForeignExports
- ) where
+ ) where
#include "HsVersions.h"
@@ -43,18 +43,18 @@ import FastString
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _ = False
+isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _ = False
+isForeignExport _ = False
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Imports}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -64,22 +64,22 @@ tcForeignImports decls
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo) $
- do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- ; let
- -- Drop the foralls before inspecting the
- -- structure of the foreign type.
- (_, t_ty) = tcSplitForAllTys sig_ty
- (arg_tys, res_ty) = tcSplitFunTys t_ty
- id = mkLocalId nm sig_ty
- -- Use a LocalId to obey the invariant that locally-defined
- -- things are LocalIds. However, it does not need zonking,
- -- (so TcHsSyn.zonkForeignExports ignores it).
-
- ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
- -- Can't use sig_ty here because sig_ty :: Type and
- -- we need HsType Id hence the undefined
- ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+ = addErrCtxt (foreignDeclCtxt fo) $
+ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ ; let
+ -- Drop the foralls before inspecting the
+ -- structure of the foreign type.
+ (_, t_ty) = tcSplitForAllTys sig_ty
+ (arg_tys, res_ty) = tcSplitFunTys t_ty
+ id = mkLocalId nm sig_ty
+ -- Use a LocalId to obey the invariant that locally-defined
+ -- things are LocalIds. However, it does not need zonking,
+ -- (so TcHsSyn.zonkForeignExports ignores it).
+
+ ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+ -- Can't use sig_ty here because sig_ty :: Type and
+ -- we need HsType Id hence the undefined
+ ; return (id, ForeignImport (L loc id) undefined imp_decl') }
tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
@@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
do { checkCg checkCOrAsmOrLlvmOrInterp
; checkSafety safety
; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
- ; return idecl } -- NB check res_ty not sig_ty!
- -- In case sig_ty is (forall a. ForeignPtr a)
+ ; return idecl } -- NB check res_ty not sig_ty!
+ -- In case sig_ty is (forall a. ForeignPtr a)
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
- -- Foreign wrapper (former f.e.d.)
- -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
- -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
- -- as ft -> IO Addr is accepted, too. The use of the latter two forms
- -- is DEPRECATED, though.
+ -- Foreign wrapper (former f.e.d.)
+ -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+ -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
+ -- as ft -> IO Addr is accepted, too. The use of the latter two forms
+ -- is DEPRECATED, though.
checkCg checkCOrAsmOrLlvmOrInterp
checkCConv cconv
checkSafety safety
@@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Exports}
-%* *
+%* *
%************************************************************************
\begin{code}
-tcForeignExports :: [LForeignDecl Name]
- -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
= foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
@@ -190,25 +190,25 @@ tcForeignExports decls
return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
- addErrCtxt (foreignDeclCtxt fo) $ do
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+ = addErrCtxt (foreignDeclCtxt fo) $ do
- sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+ sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ rhs <- tcPolyExpr (nlHsVar nm) sig_ty
- tcCheckFEType sig_ty spec
+ tcCheckFEType sig_ty spec
- -- we're exporting a function, but at a type possibly more
- -- constrained than its declared/inferred type. Hence the need
- -- to create a local binding which will call the exported function
- -- at a particular type (and, maybe, overloading).
+ -- we're exporting a function, but at a type possibly more
+ -- constrained than its declared/inferred type. Hence the need
+ -- to create a local binding which will call the exported function
+ -- at a particular type (and, maybe, overloading).
- -- We need to give a name to the new top-level binding that
- -- is *stable* (i.e. the compiler won't change it later),
- -- because this name will be referred to by the C code stub.
- id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
- return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+ -- We need to give a name to the new top-level binding that
+ -- is *stable* (i.e. the compiler won't change it later),
+ -- because this name will be referred to by the C code stub.
+ id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+ return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
@@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
%************************************************************************
-%* *
+%* *
\subsection{Miscellaneous}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -246,7 +246,7 @@ checkForeignArgs pred tys
go ty = check (pred ty) (illegalForeignTyErr argument ty)
------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form
+-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
@@ -256,14 +256,14 @@ nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- -- (IO t) is ok, and so is any newtype wrapping thereof
+ -- (IO t) is ok, and so is any newtype wrapping thereof
| Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
= return ()
-
+
| otherwise
- = check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
@@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
- = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+ = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
@@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
@@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
- dflags <- getDOpts
- let target = hscTarget dflags
- case target of
- HscNothing -> return ()
- _ ->
- case check target of
- Nothing -> return ()
- Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+ dflags <- getDOpts
+ let target = hscTarget dflags
+ case target of
+ HscNothing -> return ()
+ _ ->
+ case check target of
+ Nothing -> return ()
+ Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
-
+
Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv = return ()
+checkCConv CCallConv = return ()
#if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv = return ()
#else
-- This is a warning, not an error. see #3336
-checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
+checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
#endif
checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
-checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
\end{code}
Deprecated "threadsafe" calls
@@ -329,12 +329,12 @@ Warnings
\begin{code}
check :: Bool -> Message -> TcM ()
-check True _ = return ()
+check True _ = return ()
check _ the_err = addErrTc the_err
illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
- = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
+ = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
ptext (sLit "type in foreign declaration:")])
2 (hsep [ppr ty])
@@ -344,12 +344,11 @@ argument = text "argument"
result = text "result"
badCName :: CLabelString -> Message
-badCName target
- = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+badCName target
+ = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
= hang (ptext (sLit "When checking declaration:"))
2 (ppr fo)
\end{code}
-
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 2c04cf4bc34f0e53ff5299466a5966deb9cf6405..ad640efec88affa1789b7595c39f1a52a916668d 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -42,7 +42,7 @@ import Name
import HscTypes
import PrelInfo
import MkCore ( eRROR_ID )
-import PrelNames
+import PrelNames hiding (error_RDR)
import PrimOp
import SrcLoc
import TyCon
@@ -50,7 +50,6 @@ import TcType
import TysPrim
import TysWiredIn
import Type
-import Var( TyVar )
import TypeRep
import VarSet
import State
@@ -779,7 +778,7 @@ gen_Ix_binds loc tycon
single_con_range
= mk_easy_FunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
- nlHsDo ListComp stmts con_expr
+ noLoc (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
@@ -893,15 +892,15 @@ gen_Read_binds get_fixity loc tycon
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])]
+ [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the
-- enclosing "parens" call, so here we must match the naked
-- data_con_str con
- match_con con | isSym con_str = symbol_pat con_str
- | otherwise = ident_pat con_str
+ match_con con | isSym con_str = [symbol_pat con_str]
+ | otherwise = ident_h_pat con_str
where
con_str = data_con_str con
-- For nullary constructors we must match Ident s for normal constrs
@@ -925,12 +924,12 @@ gen_Read_binds get_fixity loc tycon
prefix_parser = mk_parser prefix_prec prefix_stmts body
read_prefix_con
- | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
- | otherwise = [bindLex (ident_pat con_str)]
+ | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
+ | otherwise = ident_h_pat con_str
read_infix_con
- | isSym con_str = [bindLex (symbol_pat con_str)]
- | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
+ | isSym con_str = [symbol_pat con_str]
+ | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
prefix_stmts -- T a b c
= read_prefix_con ++ read_args
@@ -965,15 +964,23 @@ gen_Read_binds get_fixity loc tycon
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
- mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
- mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
- bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
- con_app con as = nlHsVarApps (getRdrName con) as -- con as
- result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
+ mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
+ , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
+ con_app con as = nlHsVarApps (getRdrName con) as -- con as
+ result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
- ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
- symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
+
+ -- For constructors and field labels ending in '#', we hackily
+ -- let the lexer generate two tokens, and look for both in sequence
+ -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
+ ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
+ | otherwise = [ ident_pat s ]
+
+ ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP
+ symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP
data_con_str con = occNameString (getOccName con)
@@ -991,11 +998,9 @@ gen_Read_binds get_fixity loc tycon
-- or (#) = 4
-- Note the parens!
read_lbl lbl | isSym lbl_str
- = [read_punc "(",
- bindLex (symbol_pat lbl_str),
- read_punc ")"]
+ = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
| otherwise
- = [bindLex (ident_pat lbl_str)]
+ = ident_h_pat lbl_str
where
lbl_str = occNameString (getOccName lbl)
\end{code}
@@ -1831,7 +1836,7 @@ assoc_ty_id cls_str _ tbl ty
text "for primitive type" <+> ppr ty)
| otherwise = head res
where
- res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
+ res = [id | (ty',id) <- tbl, ty `eqType` ty']
-----------------------------------------------------------------------
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 122b74374230e063aa36d39cb0452903a1115e92..12b50acff09067c846c23444ae734d3058815c06 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -35,6 +35,7 @@ import TcRnMonad
import PrelNames
import TcType
import TcMType
+import Coercion
import TysPrim
import TysWiredIn
import DataCon
@@ -43,14 +44,15 @@ import NameSet
import Var
import VarSet
import VarEnv
+import DynFlags( DynFlag(..) )
import Literal
import BasicTypes
import Maybes
import SrcLoc
-import DynFlags( DynFlag(..) )
import Bag
import FastString
import Outputable
+-- import Data.Traversable( traverse )
\end{code}
\begin{code}
@@ -119,7 +121,7 @@ shortCutLit (HsIntegral i) ty
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
- | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
+ | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
@@ -578,11 +580,10 @@ zonkExpr env (HsLet binds expr)
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsDo do_or_lc stmts body ty)
- = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
- zonkLExpr new_env body `thenM` \ new_body ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+ = zonkStmts env stmts `thenM` \ (_, new_stmts) ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts new_body new_ty)
+ returnM (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
@@ -676,7 +677,7 @@ zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
+zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
; return (env, WpCast co') }
zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
; return (env', WpEvLam ev') }
@@ -728,22 +729,26 @@ zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
= mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
- return (env1, ParStmt new_stmts_w_bndrs)
+ zonkExpr env1 mzip_op `thenM` \ new_mzip ->
+ zonkExpr env1 bind_op `thenM` \ new_bind ->
+ zonkExpr env1 return_op `thenM` \ new_return ->
+ return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
- , recS_rec_rets = rets })
+ , recS_rec_rets = rets, recS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_ty <- zonkTcTypeToType env ret_ty
; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id
@@ -756,28 +761,34 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
- , recS_rec_rets = new_rets }) }
+ , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
-zonkStmt env (ExprStmt expr then_op ty)
+zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkExpr env then_op `thenM` \ new_then ->
+ zonkExpr env guard_op `thenM` \ new_guard ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_then new_ty)
+ returnM (env, ExprStmt new_expr new_then new_guard new_ty)
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
- = do { (env', stmts') <- zonkStmts env stmts
- ; let binders' = zonkIdOccs env' binders
- ; usingExpr' <- zonkLExpr env' usingExpr
- ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
- ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
-
-zonkStmt env (GroupStmt stmts binderMap by using)
+zonkStmt env (LastStmt expr ret_op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env ret_op `thenM` \ new_ret ->
+ returnM (env, LastStmt new_expr new_ret)
+
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_form = form, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
- ; by' <- fmapMaybeM (zonkLExpr env') by
- ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+ ; by' <- fmapMaybeM (zonkLExpr env') by
+ ; using' <- zonkLExpr env using
+ ; return_op' <- zonkExpr env' return_op
+ ; bind_op' <- zonkExpr env' bind_op
+ ; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendZonkEnv env' (map snd binderMap')
- ; return (env'', GroupStmt stmts' binderMap' by' using') }
+ ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+ , trS_by = by', trS_form = form, trS_using = using'
+ , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
@@ -795,11 +806,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
-zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
-zonkMaybeLExpr _ Nothing = return Nothing
-zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-
-
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
@@ -1004,7 +1010,6 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
- | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
| otherwise = ASSERT( isImmutableTyVar v) return (env, v)
\end{code}
@@ -1034,10 +1039,10 @@ zonkVect env (HsVect v (Just e))
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
return (EvId (zonkIdOcc env v))
-zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co
+zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co
; return (EvCoercion co') }
zonkEvTerm env (EvCast v co) = ASSERT( isId v)
- do { co' <- zonkTcTypeToType env co
+ do { co' <- zonkTcCoToCo env co
; return (EvCast (zonkIdOcc env v) co') }
zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
zonkEvTerm env (EvDFunApp df tys tms)
@@ -1112,4 +1117,27 @@ zonkTypeZapping ty
zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
-\end{code}
\ No newline at end of file
+
+zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkTcCoToCo env co
+ = go co
+ where
+ go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv))
+ go (Refl ty) = do { ty' <- zonkTcTypeToType env ty
+ ; return (Refl ty') }
+ go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
+ go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') }
+ go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkAppCo co1' co2') }
+ go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1
+ ; t2' <- zonkTcTypeToType env t2
+ ; return (mkUnsafeCo t1' t2') }
+ go (SymCo co) = do { co' <- go co; return (mkSymCo co') }
+ go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') }
+ go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkTransCo co1' co2') }
+ go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty
+ ; return (mkInstCo co' ty') }
+ go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv )
+ do { co' <- go co; return (mkForAllCo tv co') }
+\end{code}
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 71eb55ed6c07333d8c8da33d12a60716aac5268f..65f16c56d2b38c0b05d8616865880b3464df1a37 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -44,7 +44,6 @@ import TyCon
import Class
import Name
import NameSet
-import PrelNames
import TysWiredIn
import BasicTypes
import SrcLoc
@@ -365,9 +364,6 @@ kc_hs_type (HsPArrTy ty) = do
ty' <- kcLiftedType ty
return (HsPArrTy ty', liftedTypeKind)
-kc_hs_type (HsNumTy n)
- = return (HsNumTy n, liftedTypeKind)
-
kc_hs_type (HsKindSig ty k) = do
ty' <- kc_check_lhs_type ty (EK k EkKindSig)
return (HsKindSig ty' k, k)
@@ -606,11 +602,6 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do
tau_ty2 <- dsHsType ty2
setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
-ds_type (HsNumTy n)
- = ASSERT(n==1) do
- tc <- tcLookupTyCon genUnitTyConName
- return (mkTyConApp tc [])
-
ds_type ty@(HsAppTy _ _)
= ds_app ty []
@@ -857,7 +848,7 @@ tcPatSig :: UserTypeCtxt
[(Name, TcType)], -- The new bit of type environment, binding
-- the scoped type variables
HsWrapper) -- Coercion due to unification with actual ty
- -- Of shape: res_ty ~ sig_ty
+ -- Of shape: res_ty ~ sig_ty
tcPatSig ctxt sig res_ty
= do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
-- sig_tvs are the type variables free in 'sig',
@@ -869,8 +860,7 @@ tcPatSig ctxt sig res_ty
-- and hence is rigid, so use it to zap the res_ty
wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty
; return (sig_ty, [], wrap)
-
- } else do {
+ } else do {
-- Type signature binds at least one scoped type variable
-- A pattern binding cannot bind scoped type variables
@@ -893,20 +883,20 @@ tcPatSig ctxt sig res_ty
; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
-- Now do a subsumption check of the pattern signature against res_ty
- ; sig_tvs' <- tcInstSigTyVars sig_tvs
+ ; sig_tvs' <- tcInstSigTyVars sig_tvs
; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
sig_tv_tys' = mkTyVarTys sig_tvs'
- ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
+ ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
-- Check that each is bound to a distinct type variable,
-- and one that is not already in scope
- ; binds_in_scope <- getScopedTyVarBinds
+ ; binds_in_scope <- getScopedTyVarBinds
; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys'
; check binds_in_scope tv_binds
-- Phew!
- ; return (sig_ty', tv_binds, wrap)
- } }
+ ; return (sig_ty', tv_binds, wrap)
+ } }
where
check _ [] = return ()
check in_scope ((n,ty):rest) = do { check_one in_scope n ty
@@ -917,7 +907,7 @@ tcPatSig ctxt sig res_ty
-- Must not bind to the same type variable
-- as some other in-scope type variable
where
- dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty]
+ dups = [n' | (n',ty') <- in_scope, eqType ty' ty]
\end{code}
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3bb27a78dec903fb9a33d68630c559902735a2cd..bb0089f8e26a60967f67ead76bcfb516dab8ecbb 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -16,22 +16,24 @@ import TcPat( addInlinePrags )
import TcRnMonad
import TcMType
import TcType
+import BuildTyCl
import Inst
import InstEnv
import FamInst
import FamInstEnv
-import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import TcDeriv
import TcEnv
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
+import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
+import Pair
import VarSet
import CoreUtils ( mkPiTypes )
import CoreUnfold ( mkDFunUnfolding )
@@ -206,7 +208,7 @@ Just <blah>.
Instead, we simply rely on the fact that casts are cheap:
$df :: forall a. C a => C [a]
- {-# INLINE df #} -- NB: INLINE this
+ {-# INLINE df #-} -- NB: INLINE this
$df = /\a. \d. MkC [a] ($cop_list a d)
= $cop_list |> forall a. C a -> (sym (Co:C [a]))
@@ -370,40 +372,41 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
- ; clas_decls = filter (isClassDecl . unLoc) tycl_decls
- ; implicit_things = concatMap implicitTyThings at_idx_tycons
- ; aux_binds = mkRecSelBinds at_idx_tycons
- }
+ ; implicit_things = concatMap implicitTyConThings at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons }
-- (2) Add the tycons of indexed types and their implicit
-- tythings to the global environment
- ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+ ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
- -- (3) Instances from generic class declarations
- ; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- (a) local instance decls
- -- (b) generic instances
- -- (c) local family instance decls
+ -- (b) local family instance decls
; addInsts local_info $
- addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
- -- (4) Compute instances from "deriving" clauses;
+ -- (3) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
- failIfErrsM -- If the addInsts stuff gave any errors, don't
- -- try the deriving stuff, becuase that may give
- -- more errors still
- ; (deriv_inst_info, deriv_binds, deriv_dus)
+ failIfErrsM -- If the addInsts stuff gave any errors, don't
+ -- try the deriving stuff, because that may give
+ -- more errors still
+ ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
<- tcDeriving tycl_decls inst_decls deriv_decls
- ; gbl_env <- addInsts deriv_inst_info getGblEnv
+
+ -- Extend the global environment also with the generated datatypes for
+ -- the generic representation
+ ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
+ ; gbl_env <- tcExtendGlobalEnv all_tycons $
+ tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+ addFamInsts deriv_ty_insts $
+ addInsts deriv_inst_info getGblEnv
; return ( addTcgDUs gbl_env deriv_dus,
- generic_inst_info ++ deriv_inst_info ++ local_info,
+ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
@@ -411,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
-addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts :: [TyCon] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
- where
- mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
- mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
- (ppr tything)
+ = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
- -> TcM (InstInfo Name, [TyThing])
+ -> TcM (InstInfo Name, [TyCon])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
@@ -466,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType]) -- instance types
-> [(LTyClDecl Name, -- source form of AT
- TyThing)] -- Core form of AT
+ TyCon)] -- Core form of AT
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
@@ -484,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes clas inst_tys (hsAT, ATyCon tycon)
+ checkIndexes clas inst_tys (hsAT, tycon)
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
= checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
- checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
@@ -549,8 +547,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
checkIndex ty (Just instTy)
- | ty `tcEqType` instTy = return ()
- | otherwise = addErrTc $ wrongATArgErr ty instTy
+ | ty `eqType` instTy = return ()
+ | otherwise = addErrTc $ wrongATArgErr ty instTy
listToNameSet = addListToNameSet emptyNameSet
@@ -563,7 +561,183 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
tv1 `sameLexeme` tv2 =
nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
- extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+ TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type checking family instances
+%* *
+%************************************************************************
+
+Family instances are somewhat of a hybrid. They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+
+\begin{code}
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
+tcFamInstDecl top_lvl (L loc decl)
+ = -- Prime error recovery, set source location
+ setSrcSpan loc $
+ tcAddDeclCtxt decl $
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
+ ; type_families <- xoptM Opt_TypeFamilies
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+ ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+ -- Perform kind and type checking
+ ; tc <- tcFamInstDecl1 decl
+ ; checkValidTyCon tc -- Remember to check validity;
+ -- no recursion to worry about here
+
+ -- Check that toplevel type instances are not for associated types.
+ ; when (isTopLevel top_lvl && isAssocFamily tc)
+ (addErr $ assocInClassErr (tcdName decl))
+
+ ; return tc }
+
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "isAssocFamily: no family?!?"
+ Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+ ptext (sLit "must be inside a class instance")
+
+
+
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+
+ -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+ do { -- check that the family declaration is for a synonym
+ checkTc (isFamilyTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+
+ ; -- (1) kind check the right-hand side of the type equation
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+ -- ToDo: the ExpKind could be better
+
+ -- we need the exact same number of type parameters as the family
+ -- declaration
+ ; let famArity = tyConArity family
+ ; checkTc (length k_typats == famArity) $
+ wrongNumberOfParmsErr famArity
+
+ -- (2) type check type equation
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; t_rhs <- tcHsKindedType k_rhs
+
+ -- (3) check the well-formedness of the instance
+ ; checkValidTypeInst t_typats t_rhs
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
+ (typeKind t_rhs)
+ NoParentTyCon (Just (family, t_typats))
+ }}
+
+ -- "newtype instance" and "data instance"
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+ tcdCons = cons})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+ do { -- check that the family declaration is for the right kind
+ checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+
+ ; -- (1) kind check the data declaration as usual
+ ; k_decl <- kcDataDecl decl k_tvs
+ ; let k_ctxt = tcdCtxt k_decl
+ k_cons = tcdCons k_decl
+
+ -- result kind must be '*' (otherwise, we have too few patterns)
+ ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
+
+ -- (2) type check indexed data type declaration
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+
+ -- kind check the type indexes and the context
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; stupid_theta <- tcHsKindedContext k_ctxt
+
+ -- (3) Check that
+ -- (a) left-hand side contains no type family applications
+ -- (vanilla synonyms are fine, though, and we checked for
+ -- foralls earlier)
+ ; mapM_ checkTyFamFreeness t_typats
+
+ ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; let ex_ok = True -- Existentials ok for type families!
+ ; fixM (\ rep_tycon -> do
+ { let orig_res_ty = mkTyConApp fam_tycon t_typats
+ ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+ (t_tvs, orig_res_ty) k_cons
+ ; tc_rhs <-
+ case new_or_data of
+ DataType -> return (mkDataTyConRhs data_cons)
+ NewType -> ASSERT( not (null data_cons) )
+ mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
+ ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+ h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+ -- We always assume that indexed types are recursive. Why?
+ -- (1) Due to their open nature, we can never be sure that a
+ -- further instance might not introduce a new recursive
+ -- dependency. (2) They are always valid loop breakers as
+ -- they involve a coercion.
+ })
+ }}
+ where
+ h98_syntax = case cons of -- All constructors have same shape
+ L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+ _ -> True
+
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+
+-- Kind checking of indexed types
+-- -
+
+-- Kind check type patterns and kind annotate the embedded type variables.
+--
+-- * Here we check that a type instance matches its kind signature, but we do
+-- not check whether there is a pattern for each type index; the latter
+-- check is only required for type synonym instances.
+
+kcIdxTyPats :: TyClDecl Name
+ -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
+ -- ^^kinded tvs ^^kinded ty pats ^^res kind
+ -> TcM a
+kcIdxTyPats decl thing_inside
+ = kcHsTyVars (tcdTyVars decl) $ \tvs ->
+ do { let tc_name = tcdLName decl
+ ; fam_tycon <- tcLookupLocatedTyCon tc_name
+ ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+ ; hs_typats = fromJust $ tcdTyPats decl }
+
+ -- we may not have more parameters than the kind indicates
+ ; checkTc (length kinds >= length hs_typats) $
+ tooManyParmsErr (tcdLName decl)
+
+ -- type functions can have a higher-kinded result
+ ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
+ ; typats <- zipWithM kcCheckLHsType hs_typats
+ [ EK kind (EkArg (ppr tc_name) n)
+ | (kind,n) <- kinds `zip` [1..]]
+ ; thing_inside tvs typats resultKind fam_tycon
+ }
\end{code}
@@ -621,6 +795,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+ -- We instantiate the dfun_id with superSkolems.
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
@@ -699,7 +876,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
listToBag meth_binds)
}
where
- skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
+ skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
@@ -718,8 +895,8 @@ tcSuperClass n_ty_args ev_vars pred
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
- find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
- | otherwise = find (i+1) evs
+ find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
+ | otherwise = find (i+1) evs
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
@@ -917,10 +1094,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
----------------------
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+ tc_default sel_id (GenDefMeth dm_name)
+ = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+ ; tc_body sel_id False {- Not generated code? -} meth_bind }
+{-
tc_default sel_id GenDefMeth -- Derivable type classes stuff
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False {- Not generated code? -} meth_bind }
-
+-}
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
@@ -1042,13 +1224,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
Just (init_inst_tys, _) = snocView inst_tys
- rep_ty = fst (coercionKind co) -- [p]
+ rep_ty = pFst (coercionKind co) -- [p]
rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
-- co : [p] ~ T p
- co = substTyWith inst_tvs (mkTyVarTys tyvars) $
- case coi of { IdCo ty -> ty ;
- ACo co -> mkSymCoercion co }
+ co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
+ mkSymCo coi
----------------
tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
@@ -1072,7 +1253,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
----------------
mk_op_wrapper :: Id -> EvVar -> HsWrapper
mk_op_wrapper sel_id rep_d
- = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+ = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
+ local_meth_ty)
<.> WpEvApp (EvId rep_d)
<.> mkWpTyApps (init_inst_tys ++ [rep_ty])
where
@@ -1262,4 +1444,37 @@ wrongATArgErr ty instTy =
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
+
+tooManyParmsErr :: Located Name -> SDoc
+tooManyParmsErr tc_name
+ = ptext (sLit "Family instance has too many parameters:") <+>
+ quotes (ppr tc_name)
+
+tooFewParmsErr :: Arity -> SDoc
+tooFewParmsErr arity
+ = ptext (sLit "Family instance has too few parameters; expected") <+>
+ ppr arity
+
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr exp_arity
+ = ptext (sLit "Number of parameters must match family declaration; expected")
+ <+> ppr exp_arity
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
+ where
+ kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
+ | isAlgTyCon family = ptext (sLit "data type")
+ | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
\end{code}
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 4a049aa3eee6ab0233f7c5a3a674897d85286c0a..3833534f1e44cbd38f73eb7a52a8bfb7fe75a29f 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -12,6 +12,7 @@ import BasicTypes
import TcCanonical
import VarSet
import Type
+import Unify
import Id
import Var
@@ -30,6 +31,7 @@ import Coercion
import Outputable
import TcRnTypes
+import TcMType ( isSilentEvVar )
import TcErrors
import TcSMonad
import Bag
@@ -68,8 +70,11 @@ An InertSet is a bag of canonical constraints, with the following invariants:
will be marked as solved right before being pushed into the inert set.
See note [Touchables and givens].
- 8 No Given constraint mentions a touchable unification variable,
- except if the
+ 8 No Given constraint mentions a touchable unification variable, but
+ Given/Solved may do so.
+
+ 9 Given constraints will also have their superclasses in the inert set,
+ but Given/Solved will not.
Note that 6 and 7 are /not/ enforced by canonicalization but rather by
insertion in the inert list, ie by TcInteract.
@@ -192,7 +197,7 @@ extractUnsolved is@(IS {inert_eqs = eqs})
, inert_funeqs = solved_funeqs }
in (is_solved, unsolved)
- where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenCt) eqs
+ where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
(unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is)
(unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is)
(unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is)
@@ -327,7 +332,7 @@ solveInteractGiven inert gloc evs
map mk_given evs
; return inert_ret }
where
- flav = Given gloc
+ flav = Given gloc GivenOrig
mk_given ev = mkEvVarX ev flav
solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
@@ -408,16 +413,12 @@ dischargeFromCCans cans ev fl
discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool
discharge_ct ct _rest
- | evVarPred (cc_id ct) `tcEqPred` the_pred
+ | evVarPred (cc_id ct) `eqPred` the_pred
, cc_flavor ct `canSolve` fl
- = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct)
+ = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct))
-- Deriveds need no evidence
-- For Givens, we already have evidence, and we don't need it twice
; return True }
- where
- set_ev_bind x y
- | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y))
- | otherwise = setEvBind x (EvId y)
discharge_ct _ct rest = rest
\end{code}
@@ -531,7 +532,7 @@ spontaneousSolveStage depth workItem inerts
, sr_stop = ContinueWith workItem }
SPSolved workItem'
- | not (isGivenCt workItem)
+ | not (isGivenOrSolvedCt workItem)
-- Original was wanted or derived but we have now made him
-- given so we have to interact him with the inerts due to
-- its status change. This in turn may produce more work.
@@ -572,7 +573,7 @@ data SPSolveResult = SPCantSolve | SPSolved WorkItem | SPError
-- See Note [Touchables and givens]
trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
- | isGiven gw
+ | isGivenOrSolved gw
= return SPCantSolve
| Just tv2 <- tcGetTyVar_maybe xi
= do { tch1 <- isTouchableMetaTyVar tv1
@@ -725,13 +726,13 @@ solveWithIdentity cv wd tv xi
]
; setWantedTyBind tv xi
- ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi xi
+ ; let refl_xi = mkReflCo xi
+ ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi
- ; when (isWanted wd) (setCoBind cv xi)
+ ; when (isWanted wd) (setCoBind cv refl_xi)
-- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-
; return $ SPSolved (CTyEqCan { cc_id = cv_given
- , cc_flavor = mkGivenFlavor wd UnkSkol
+ , cc_flavor = mkSolvedFlavor wd UnkSkol
, cc_tyvar = tv, cc_rhs = xi }) }
\end{code}
@@ -928,10 +929,10 @@ doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult
doInteractWithInert
inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 })
workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
- | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2)
+ | cls1 == cls2 && eqTypes tys1 tys2
= solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
- | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+ | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
= -- See Note [When improvement happens]
do { let pty1 = ClassP cls1 tys1
pty2 = ClassP cls2 tys2
@@ -946,7 +947,7 @@ doInteractWithInert
; case m of
Nothing -> noInteraction workItem
Just (rewritten_tys2, cos2, fd_work)
- | tcEqTypes tys1 rewritten_tys2
+ | eqTypes tys1 rewritten_tys2
-> -- Solve him on the spot in this case
case fl2 of
Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem)
@@ -991,7 +992,7 @@ doInteractWithInert
workListFromNonEq workItem' `unionWorkList` fd_work }
where
- dict_co = mkTyConCoercion (classTyCon cls1) cos2
+ dict_co = mkTyConAppCo (classTyCon cls1) cos2
}
-- Class constraint and given equality: use the equality to rewrite
@@ -1035,7 +1036,7 @@ doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_i
-- so we just generate a fresh coercion variable that isn't used anywhere.
doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
- | nm1 == nm2 && isGiven wfl && isGiven ifl
+ | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
= -- See Note [Overriding implicit parameters]
-- Dump the inert item, override totally with the new one
-- Do not require type equality
@@ -1043,15 +1044,22 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i
-- we must *override* the outer one with the inner one
mkIRContinue "IP/IP override" workItem DropInert emptyWorkList
- | nm1 == nm2 && ty1 `tcEqType` ty2
+ | nm1 == nm2 && ty1 `eqType` ty2
= solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem
| 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 (mkSymCo (mkCoVarCo 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
@@ -1089,24 +1097,31 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1
, cc_tyargs = args1, cc_rhs = xi1 })
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl1
+ = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl2
+ = mkIRStopK "Funeq/Funeq" emptyWorkList
+
| fl1 `canSolve` fl2 && lhss_match
- = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2)
; mkIRStopK "FunEq/FunEq" cans }
| fl2 `canSolve` fl1 && lhss_match
- = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue "FunEq/FunEq" workItem DropInert cans }
where
- lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2)
+ lhss_match = tc1 == tc2 && eqTypes args1 args2
doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 })
workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
-- Check for matching LHS
| fl1 `canSolve` fl2 && tv1 == tv2
- = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2)
; mkIRStopK "Eq/Eq lhs" cans }
| fl2 `canSolve` fl1 && tv1 == tv2
- = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue "Eq/Eq lhs" workItem DropInert cans }
-- Check for rewriting RHS
@@ -1137,13 +1152,13 @@ doInteractWithInert _ workItem = noInteraction workItem
-- Equational Rewriting
rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
rewriteDict (cv,tv,xi) (dv,gw,cl,xis)
- = do { let cos = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi]
+ = do { let cos = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis -- xis[tv] ~ xis[xi]
args = substTysWith [tv] [xi] xis
con = classTyCon cl
- dict_co = mkTyConCoercion con cos
+ dict_co = mkTyConAppCo con cos
; dv' <- newDictVar cl args
; case gw of
- Wanted {} -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co))
+ Wanted {} -> setDictBind dv (EvCast dv' (mkSymCo dict_co))
Given {} -> setDictBind dv' (EvCast dv dict_co)
Derived {} -> return () -- Derived dicts we don't set any evidence
@@ -1154,11 +1169,11 @@ rewriteDict (cv,tv,xi) (dv,gw,cl,xis)
rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt
rewriteIP (cv,tv,xi) (ipid,gw,nm,ty)
- = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty -- ty[tv] ~ t[xi]
- ty' = substTyWith [tv] [xi] ty
+ = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty -- ty[tv] ~ t[xi]
+ ty' = substTyWith [tv] [xi] ty
; ipid' <- newIPVar nm ty'
; case gw of
- Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCoercion ip_co))
+ Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCo ip_co))
Given {} -> setIPBind ipid' (EvCast ipid ip_co)
Derived {} -> return () -- Derived ips: we don't set any evidence
@@ -1169,20 +1184,21 @@ rewriteIP (cv,tv,xi) (ipid,gw,nm,ty)
rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt
rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2
- = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args
- args' = substTysWith [tv] [xi1] args
- fun_co = mkTyConCoercion tc arg_cos -- fun_co :: F args ~ F args'
+ = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1]
+ arg_cos = map co_subst args
+ args' = substTysWith [tv] [xi1] args
+ fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args'
xi2' = substTyWith [tv] [xi1] xi2
- xi2_co = substTyWith [tv] [mkCoVarCoercion cv1] xi2 -- xi2_co :: xi2 ~ xi2'
+ xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2'
; cv2' <- newCoVar (mkTyConApp tc args') xi2'
; case gw of
- Wanted {} -> setCoBind cv2 (fun_co `mkTransCoercion`
- mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion xi2_co)
- Given {} -> setCoBind cv2' (mkSymCoercion fun_co `mkTransCoercion`
- mkCoVarCoercion cv2 `mkTransCoercion`
+ Wanted {} -> setCoBind cv2 (fun_co `mkTransCo`
+ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo xi2_co)
+ Given {} -> setCoBind cv2' (mkSymCo fun_co `mkTransCo`
+ mkCoVarCo cv2 `mkTransCo`
xi2_co)
Derived {} -> return ()
@@ -1203,20 +1219,20 @@ rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS WorkLis
rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2)
| Just tv2' <- tcGetTyVar_maybe xi2'
, tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2
- = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2'))
+ = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2'))
; return emptyWorkList }
| otherwise
= do { cv2' <- newCoVar (mkTyVarTy tv2) xi2'
; case gw of
- Wanted {} -> setCoBind cv2 $ mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion co2'
- Given {} -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion`
+ Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo co2'
+ Given {} -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo`
co2'
Derived {} -> return ()
; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' }
where
xi2' = substTyWith [tv1] [xi1] xi2
- co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
+ co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList
-- Used to ineract two equalities of the following form:
@@ -1229,9 +1245,9 @@ rewriteEqLHS LeftComesFromInert (co1,xi1) (cv2,gw,xi2)
= do { cv2' <- newCoVar xi2 xi1
; case gw of
Wanted {} -> setCoBind cv2 $
- co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2')
+ co1 `mkTransCo` mkSymCo (mkCoVarCo cv2')
Given {} -> setCoBind cv2' $
- mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1
+ mkSymCo (mkCoVarCo cv2) `mkTransCo` co1
Derived {} -> return ()
; mkCanonical gw cv2' }
@@ -1239,9 +1255,9 @@ rewriteEqLHS RightComesFromInert (co1,xi1) (cv2,gw,xi2)
= do { cv2' <- newCoVar xi1 xi2
; case gw of
Wanted {} -> setCoBind cv2 $
- co1 `mkTransCoercion` mkCoVarCoercion cv2'
+ co1 `mkTransCo` mkCoVarCo cv2'
Given {} -> setCoBind cv2' $
- mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
+ mkSymCo co1 `mkTransCo` mkCoVarCo cv2
Derived {} -> return ()
; mkCanonical gw cv2' }
@@ -1249,12 +1265,12 @@ rewriteFrozen :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor) -> TcS WorkList
rewriteFrozen (cv1, tv1, xi1) (cv2, fl2)
= do { cv2' <- newCoVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1]
; case fl2 of
- Wanted {} -> setCoBind cv2 $ co2a' `mkTransCoercion`
- mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion co2b'
+ Wanted {} -> setCoBind cv2 $ co2a' `mkTransCo`
+ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo co2b'
- Given {} -> setCoBind cv2' $ mkSymCoercion co2a' `mkTransCoercion`
- mkCoVarCoercion cv2 `mkTransCoercion`
+ Given {} -> setCoBind cv2' $ mkSymCo co2a' `mkTransCo`
+ mkCoVarCo cv2 `mkTransCo`
co2b'
Derived {} -> return ()
@@ -1265,8 +1281,8 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2)
ty2a' = substTyWith [tv1] [xi1] ty2a
ty2b' = substTyWith [tv1] [xi1] ty2b
- co2a' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2a -- ty2a ~ ty2a[xi1/tv1]
- co2b' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2b -- ty2b ~ ty2b[xi1/tv1]
+ co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1]
+ co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1]
solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
-- First argument inert, second argument work-item. They both represent
@@ -1284,6 +1300,10 @@ solveOneFromTheOther info (ev_term,ifl) workItem
-- so it's safe to continue on from this point
= mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
+ | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+ -- Same if the inert is a GivenSolved -- just get rid of it
+ = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+
| otherwise
= ASSERT( ifl `canSolve` wfl )
-- Because of Note [The Solver Invariant], plus Derived dealt with
@@ -1658,33 +1678,34 @@ data TopInteractResult
-- only reacted with functional dependencies
-- arising from top-level instances.
-topReactionsStage :: SimplifierStage
-topReactionsStage depth workItem inerts
- = do { tir <- tryTopReact workItem
- ; case tir of
- NoTopInt ->
- return $ SR { sr_inerts = inerts
- , sr_new_work = emptyWorkList
- , sr_stop = ContinueWith workItem }
- SomeTopInt tir_new_work tir_new_inert ->
+topReactionsStage :: SimplifierStage
+topReactionsStage depth workItem inerts
+ = do { tir <- tryTopReact inerts workItem
+ -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
+ ; case tir of
+ NoTopInt ->
+ return $ SR { sr_inerts = inerts
+ , sr_new_work = emptyWorkList
+ , sr_stop = ContinueWith workItem }
+ SomeTopInt tir_new_work tir_new_inert ->
do { bumpStepCountTcS
; traceFireTcS depth (ptext (sLit "Top react")
<+> vcat [ ptext (sLit "Work =") <+> ppr workItem
, ptext (sLit "New =") <+> ppr tir_new_work ])
- ; return $ SR { sr_inerts = inerts
+ ; return $ SR { sr_inerts = inerts
, sr_new_work = tir_new_work
, sr_stop = tir_new_inert
} }
}
-tryTopReact :: WorkItem -> TcS TopInteractResult
-tryTopReact workitem
+tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
+tryTopReact inerts workitem
= do { -- A flag controls the amount of interaction allowed
-- See Note [Simplifying RULE lhs constraints]
ctxt <- getTcSContext
; if allowedTopReaction (simplEqsOnly ctxt) workitem
then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
- ; doTopReact workitem }
+ ; doTopReact inerts workitem }
else return NoTopInt
}
@@ -1692,7 +1713,7 @@ allowedTopReaction :: Bool -> WorkItem -> Bool
allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
allowedTopReaction _ _ = True
-doTopReact :: WorkItem -> TcS TopInteractResult
+doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
-- The work item does not react with the inert set, so try interaction with top-level instances
-- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are
-- added in the worklist as part of the canonicalisation process.
@@ -1700,12 +1721,12 @@ doTopReact :: WorkItem -> TcS TopInteractResult
-- Given dictionary
-- See Note [Given constraint that matches an instance declaration]
-doTopReact (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_flavor = Given {} })
= return NoTopInt -- NB: Superclasses already added since it's canonical
-- Derived dictionary: just look for functional dependencies
-doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { instEnvs <- getInstEnvs
; let fd_eqns = improveFromInstEnv instEnvs
(ClassP cls xis, pprArisingAt loc)
@@ -1719,10 +1740,10 @@ doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
, tir_new_inert = ContinueWith workItem' } }
-- Wanted dictionary
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { -- See Note [MATCHING-SYNONYMS]
- ; lkp_inst_res <- matchClassInst cls xis loc
+ ; lkp_inst_res <- matchClassInst inerts cls xis loc
; case lkp_inst_res of
NoInstance ->
do { traceTcS "doTopReact/ no class instance for" (ppr dv)
@@ -1734,7 +1755,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
; case m of
Nothing -> return NoTopInt
Just (xis',cos,fd_work) ->
- do { let dict_co = mkTyConCoercion (classTyCon cls) cos
+ do { let dict_co = mkTyConAppCo (classTyCon cls) cos
; dv'<- newDictVar cls xis'
; setDictBind dv (EvCast dv' dict_co)
; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl,
@@ -1748,7 +1769,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
-- matches already so we won't get any more info
-- from functional dependencies
| null wtvs
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved in one step and no new wanted work produced.
-- i.e we directly matched a top-level instance
@@ -1757,25 +1778,29 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
, tir_new_inert = Stop } }
| otherwise
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved and new wanted work produced, you may cache the
- -- (tentatively solved) dictionary as Given! (used to be: Derived)
- ; let solved = workItem { cc_flavor = given_fl }
- given_fl = Given (setCtLocOrigin loc UnkSkol)
+ -- (tentatively solved) dictionary as Solved given.
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
; inst_work <- canWanteds wtvs
; return $ SomeTopInt { tir_new_work = inst_work
, tir_new_inert = ContinueWith solved } }
}
-- Type functions
-doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
- , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+ | Just GivenSolved <- isGiven_maybe fl
+ = return NoTopInt -- If Solved, no more interactions should happen
+
+-- Otherwise, it's a Given, Derived, or Wanted
+doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl
+ , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
= ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far
do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of
- MatchInstNo
- -> return NoTopInt
+ MatchInstNo -> return NoTopInt
MatchInstSingle (rep_tc, rep_tys)
-> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
@@ -1783,25 +1808,40 @@ doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
-- RHS of a type function, so that it never
-- appears in an error message
-- See Note [Type synonym families] in TyCon
- coe = mkTyConApp coe_tc rep_tys
- ; cv' <- case fl of
- Wanted {} -> do { cv' <- newCoVar rhs_ty xi
- ; setCoBind cv $
- coe `mkTransCoercion`
- mkCoVarCoercion cv'
- ; return cv' }
- Given {} -> newGivenCoVar xi rhs_ty $
- mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe
- Derived {} -> newDerivedId (EqPred xi rhs_ty)
- ; can_cts <- mkCanonical fl cv'
- ; return $ SomeTopInt can_cts Stop }
+ coe = mkAxInstCo coe_tc rep_tys
+ ; case fl of
+ Wanted {} -> do { cv' <- newCoVar rhs_ty xi
+ ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
+ ; can_cts <- mkCanonical fl cv'
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
+ ; if isEmptyWorkList can_cts then
+ return (SomeTopInt can_cts Stop) -- No point in caching
+ else return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = ContinueWith solved }
+ }
+ Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $
+ mkSymCo (mkCoVarCo cv) `mkTransCo` coe
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty)
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ }
_
-> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
}
-- Any other work item does not react with any top-level equations
-doTopReact _workItem = return NoTopInt
+doTopReact _inerts _workItem = return NoTopInt
\end{code}
@@ -2005,15 +2045,25 @@ data LookupInstResult
= NoInstance
| GenInst [WantedEvVar] EvTerm
-matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
-matchClassInst clas tys loc
+matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst inerts clas tys loc
= do { let pred = mkClassPred clas tys
; mb_result <- matchClass clas tys
+ ; untch <- getUntouchables
; case mb_result of
MatchInstNo -> return NoInstance
- MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
+ MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
-- we learn more about the reagent
- MatchInstSingle (dfun_id, mb_inst_tys) ->
+ MatchInstSingle (_,_)
+ | given_overlap untch ->
+ do { traceTcS "Delaying instance application" $
+ vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
+ , text "Silents and their superclasses=" <+> ppr silents_and_their_scs
+ , text "All given dictionaries=" <+> ppr all_given_dicts ]
+ ; return NoInstance -- see Note [Instance and Given overlap]
+ }
+
+ MatchInstSingle (dfun_id, mb_inst_tys) ->
do { checkWellStagedDFun pred dfun_id loc
-- It's possible that not all the tyvars are in
@@ -2022,7 +2072,7 @@ matchClassInst clas tys loc
-- (presumably there's a functional dependency in class C)
-- Hence mb_inst_tys :: Either TyVar TcType
- ; tys <- instDFunTypes mb_inst_tys
+ ; tys <- instDFunTypes mb_inst_tys
; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
@@ -2032,4 +2082,94 @@ matchClassInst clas tys loc
; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
}
}
+ where given_overlap :: TcsUntouchables -> Bool
+ given_overlap untch
+ = foldlBag (\r d -> r || matchable untch d) False all_given_dicts
+
+ matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
+ | Just GivenOrig <- isGiven_maybe fl
+ , clas' == clas
+ , does_not_originate_in_a_silent clas' sys
+ = case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv &&
+ tv `elemVarSet` tyVarsOfTypes tys
+ then BindMe else Skolem) tys sys of
+ -- We can't learn anything more about any variable at this point, so the only
+ -- cause of overlap can be by an instantiation of a touchable unification
+ -- variable. Hence we only bind touchable unification variables. In addition,
+ -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
+ Nothing -> False
+ Just _ -> True
+ | otherwise = False -- No overlap with a solved, already been taken care of
+ -- by the overlap check with the instance environment.
+ matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+
+ does_not_originate_in_a_silent clas sys
+ -- UGLY: See Note [Silent parameters overlapping]
+ = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
+
+ silents_and_their_scs
+ = foldlBag (\acc rvnt -> case rvnt of
+ CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
+ | isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc
+ _ -> acc) [] all_given_dicts
+
+ -- TODO:
+ -- When silent parameters will go away we should simply select from
+ -- the given map of the inert set.
+ all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
+
\end{code}
+
+Note [Silent parameters overlapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DV 12/05/2011:
+The long-term goal is to completely remove silent superclass
+parameters when checking instance declarations. But until then we must
+make sure that we never prevent the application of an instance
+declaration because of a potential match from a silent parameter --
+after all we are supposed to have solved that silent parameter from
+some instance, anyway! In effect silent parameters behave more like
+Solved than like Given.
+
+A concrete example appears in typecheck/SilentParametersOverlapping.hs
+
+Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Assume that we have an inert set that looks as follows:
+ [Given] D [Int]
+And an instance declaration:
+ instance C a => D [a]
+A new wanted comes along of the form:
+ [Wanted] D [alpha]
+
+One possibility is to apply the instance declaration which will leave us
+with an unsolvable goal (C alpha). However, later on a new constraint may
+arise (for instance due to a functional dependency between two later dictionaries),
+that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha])
+will be transformed to [Wanted] D [Int], which could have been discharged by the given.
+
+The solution is that in matchClassInst and eventually in topReact, we get back with
+a matching instance, only when there is no Given in the inerts which is unifiable to
+this particular dictionary.
+
+The end effect is that, much as we do for overlapping instances, we delay choosing a
+class instance if there is a possibility of another instance OR a given to match our
+constraint later on. This fixes bugs #4981 and #5002.
+
+This is arguably not easy to appear in practice due to our aggressive prioritization
+of equality solving over other constraints, but it is possible. I've added a test case
+in typecheck/should-compile/GivenOverlapping.hs
+
+Moreover notice that our goals here are different than the goals of the top-level
+overlapping checks. There we are interested in validating the following principle:
+
+ If we inline a function f at a site where the same global instance environment
+ is available as the instance environment at the definition site of f then we
+ should get the same behaviour.
+
+But for the Given Overlap check our goal is just related to completeness of
+constraint solving.
+
+
+
+
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 74533340f3b846a68cb5d82ae0606f8447675782..2c01d2300a4505c34164414c5f746b6d8f862d7c 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -26,7 +26,6 @@ module TcMType (
--------------------------------
-- Creating new evidence variables
newEvVar, newCoVar, newEvVars,
- writeWantedCoVar, readWantedCoVar,
newIP, newDict, newSilentGiven, isSilentEvVar,
newWantedEvVar, newWantedEvVars,
@@ -34,8 +33,8 @@ module TcMType (
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars, tcInstSigTyVars,
- tcInstType, instMetaTyVar,
+ tcInstTyVars, tcInstSigTyVars,
+ tcInstType,
tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType,
tcSkolDFunType, tcSuperSkolTyVars,
@@ -43,16 +42,15 @@ module TcMType (
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
SourceTyCtxt(..), checkValidTheta,
- checkValidInstance,
- checkValidTypeInst, checkTyFamFreeness,
+ checkValidInstHead, checkValidInstance,
+ checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
arityErr,
growPredTyVars, growThetaTyVars, validDerivPred,
--------------------------------
-- Zonking
zonkType, mkZonkTcTyVar, zonkTcPredType,
- zonkTcTypeCarefully,
- skolemiseUnboundMetaTyVar,
+ zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
zonkQuantifiedTyVar, zonkQuantifiedTyVars,
zonkTcType, zonkTcTypes, zonkTcThetaType,
@@ -72,7 +70,6 @@ module TcMType (
import TypeRep
import TcType
import Type
-import Coercion
import Class
import TyCon
import Var
@@ -145,7 +142,7 @@ newEvVar (IParam ip ty) = newIP ip ty
newCoVar :: TcType -> TcType -> TcM CoVar
newCoVar ty1 ty2
- = do { name <- newName (mkTyVarOccFS (fsLit "co"))
+ = do { name <- newName (mkVarOccFS (fsLit "co"))
; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
newIP :: IPName Name -> TcType -> TcM IpId
@@ -258,8 +255,17 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
-- Make meta SigTv type variables for patten-bound scoped type varaibles
-- We use SigTvs for them, so that they can't unify with arbitrary types
-tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv)
- -- ToDo: the "function binding site is bogus
+tcInstSigTyVars = mapM tcInstSigTyVar
+
+tcInstSigTyVar :: TyVar -> TcM TcTyVar
+tcInstSigTyVar tyvar
+ = do { uniq <- newMetaUnique
+ ; ref <- newMutVar Flexi
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ -- Use the same OccName so that the tidy-er
+ -- doesn't rename 'a' to 'a0' etc
+ kind = tyVarKind tyvar
+ ; return (mkTcTyVar name kind (MetaTv SigTv ref)) }
\end{code}
@@ -277,9 +283,9 @@ newMetaTyVar meta_info kind
; ref <- newMutVar Flexi
; let name = mkTcTyVarName uniq s
s = case meta_info of
- TauTv -> fsLit "t"
- TcsTv -> fsLit "u"
- SigTv _ -> fsLit "a"
+ TauTv -> fsLit "t"
+ TcsTv -> fsLit "u"
+ SigTv -> fsLit "a"
; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
mkTcTyVarName :: Unique -> FastString -> Name
@@ -287,24 +293,10 @@ 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)
-readWantedCoVar :: CoVar -> TcM MetaDetails
-readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar )
- readMutVar (metaTvRef covar)
-
isFilledMetaTyVar :: TyVar -> TcM Bool
-- True of a filled-in (Indirect) meta type variable
isFilledMetaTyVar tv
@@ -343,9 +335,6 @@ writeMetaTyVar tyvar ty
= WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
return ()
-writeWantedCoVar :: CoVar -> Coercion -> TcM ()
-writeWantedCoVar cv co = writeMetaTyVar cv co
-
--------------------
writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
-- Here the tyvar is for error checking only;
@@ -394,10 +383,6 @@ newFlexiTyVarTy kind = do
newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
-tcInstTyVar :: TyVar -> TcM TcTyVar
--- Instantiate with a META type variable
-tcInstTyVar tyvar = instMetaTyVar TauTv tyvar
-
tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
-- Instantiate with META type variables
tcInstTyVars tyvars
@@ -407,6 +392,16 @@ tcInstTyVars tyvars
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
-- any existing for-alls. Hence zipTopTvSubst
+
+tcInstTyVar :: TyVar -> TcM TcTyVar
+-- Make a new unification variable tyvar whose Name and Kind
+-- come from an existing TyVar
+tcInstTyVar tyvar
+ = do { uniq <- newMetaUnique
+ ; ref <- newMutVar Flexi
+ ; let name = mkSystemName uniq (getOccName tyvar)
+ kind = tyVarKind tyvar
+ ; return (mkTcTyVar name kind (MetaTv TauTv ref)) }
\end{code}
@@ -622,8 +617,8 @@ zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
-zonkFlavor fl = return fl
+zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
+zonkFlavor fl = return fl
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
@@ -745,13 +740,12 @@ zonkType zonk_tc_tyvar ty
-- The two interesting cases!
go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
- | otherwise = liftM TyVarTy $
- zonkTyVar zonk_tc_tyvar tyvar
+ | otherwise = return (TyVarTy tyvar)
-- Ordinary (non Tc) tyvars occur inside quantified types
go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
ty' <- go ty
- tyvar' <- zonkTyVar zonk_tc_tyvar tyvar
+ tyvar' <- return tyvar
return (ForAllTy tyvar' ty')
go_pred (ClassP c tys) = do tys' <- mapM go tys
@@ -774,16 +768,6 @@ mkZonkTcTyVar unbound_var_fn tyvar
; case cts of
Flexi -> unbound_var_fn tyvar
Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
-
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable
--- (their kind contains types).
-zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar
- -> TyVar -> TcM TyVar
-zonkTyVar zonk_tc_tyvar tv
- | isCoVar tv
- = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv)
- ; return $ setTyVarKind tv kind }
- | otherwise = return tv
\end{code}
@@ -1154,7 +1138,7 @@ check_valid_theta ctxt theta = do
warnTc (notNull dups) (dupPredWarn dups)
mapM_ (check_pred_ty dflags ctxt) theta
where
- (_,dups) = removeDups tcCmpPred theta
+ (_,dups) = removeDups cmpPred theta
-------------------------
check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM ()
@@ -1276,7 +1260,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars
ambigErr :: PredType -> SDoc
ambigErr pred
- = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
+ = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred),
nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
ptext (sLit "must be reachable from the type after the '=>'"))]
\end{code}
@@ -1343,14 +1327,14 @@ eqSuperClassErr pred
2 (ppr pred)
badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc
-badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred
-eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred
+badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred
+eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred
$$
parens (ptext (sLit "Use -XTypeFamilies to permit this"))
predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"),
- nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
dupPredWarn :: [[PredType]] -> SDoc
-dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups)
arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
arityErr kind name n m
@@ -1498,7 +1482,7 @@ checkInstTermination tys theta
predUndecErr :: PredType -> SDoc -> SDoc
predUndecErr pred msg = sep [msg,
- nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
nomoreMsg, smallerMsg, undecidableMsg :: SDoc
nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 860a6dbd92b0ab79d828a538fafdaea5d2a30416..29890a21b54973ae4237a74c39a8b515984e4728 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -6,16 +6,18 @@
TcMatches: Typecheck some @Matches@
\begin{code}
+{-# OPTIONS_GHC -w #-} -- debugging
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
- TcMatchCtxt(..),
- tcStmts, tcDoStmts, tcBody,
- tcDoStmt, tcMDoStmt, tcGuardStmt
+ TcMatchCtxt(..), TcStmtChecker,
+ tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+ tcDoStmt, tcGuardStmt
) where
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
tcMonoExpr, tcMonoExprNC, tcPolyExpr )
import HsSyn
+import BasicTypes
import TcRnMonad
import TcEnv
import TcPat
@@ -28,13 +30,15 @@ import TysWiredIn
import Id
import TyCon
import TysPrim
-import Coercion ( mkSymCoI )
+import Coercion ( isReflCo, mkSymCo )
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"
@@ -143,7 +147,7 @@ matchFunTys
matchFunTys herald arity res_ty thing_inside
= do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
; res <- thing_inside pat_tys res_ty
- ; return (coiToHsWrapper (mkSymCoI coi), res) }
+ ; return (coToHsWrapper (mkSymCo coi), res) }
\end{code}
%************************************************************************
@@ -221,7 +225,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty
tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
tcGRHS ctxt res_ty (GRHS guards rhs)
- = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+ = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
mc_body ctxt rhs
; return (GRHS guards' rhs') }
where
@@ -238,36 +242,33 @@ tcGRHS ctxt res_ty (GRHS guards rhs)
\begin{code}
tcDoStmts :: HsStmtContext Name
-> [LStmt Name]
- -> LHsExpr Name
-> TcRhoType
-> TcM (HsExpr TcId) -- Returns a HsDo
-tcDoStmts ListComp stmts body res_ty
+tcDoStmts ListComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
- ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
- elt_ty $
- tcBody body
- ; return $ mkHsWrapCoI coi
- (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+ ; let list_ty = mkListTy elt_ty
+ ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
+ ; return $ mkHsWrapCo 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 $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) }
+
+tcDoStmts DoExpr stmts res_ty
+ = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+ ; return (HsDo DoExpr stmts' res_ty) }
-tcDoStmts DoExpr stmts body res_ty
- = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo DoExpr stmts' body' res_ty) }
+tcDoStmts MDoExpr stmts res_ty
+ = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+ ; return (HsDo MDoExpr stmts' res_ty) }
-tcDoStmts MDoExpr stmts body res_ty
- = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo MDoExpr stmts' body' res_ty) }
+tcDoStmts MonadComp stmts res_ty
+ = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+ ; return (HsDo MonadComp stmts' res_ty) }
-tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
@@ -296,40 +297,52 @@ tcStmts :: HsStmtContext Name
-> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
-> TcRhoType
- -> (TcRhoType -> TcM thing)
- -> TcM ([LStmt TcId], thing)
+ -> TcM [LStmt TcId]
+tcStmts ctxt stmt_chk stmts res_ty
+ = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
+ const (return ())
+ ; return stmts' }
+
+tcStmtsAndThen :: HsStmtContext Name
+ -> TcStmtChecker -- NB: higher-rank type
+ -> [LStmt Name]
+ -> TcRhoType
+ -> (TcRhoType -> TcM thing)
+ -> TcM ([LStmt TcId], thing)
-- Note the higher-rank type. stmt_chk is applied at different
-- types in the equations for tcStmts
-tcStmts _ _ [] res_ty thing_inside
+tcStmtsAndThen _ _ [] res_ty thing_inside
= do { thing <- thing_inside res_ty
; return ([], thing) }
-- LetStmts are handled uniformly, regardless of context
-tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
= do { (binds', (stmts',thing)) <- tcLocalBinds binds $
- tcStmts ctxt stmt_chk stmts res_ty thing_inside
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
; return (L loc (LetStmt binds') : stmts', thing) }
-- For the vanilla case, handle the location-setting part
-tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
- setSrcSpan loc $
- addErrCtxt (pprStmtInCtxt ctxt stmt) $
- stmt_chk ctxt stmt res_ty $ \ res_ty' ->
- popErrCtxt $
- tcStmts ctxt stmt_chk stmts res_ty' $
+ setSrcSpan loc $
+ addErrCtxt (pprStmtInCtxt ctxt stmt) $
+ stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+ popErrCtxt $
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
---------------------------------
--- Pattern guards
+---------------------------------------------------
+-- Pattern guards
+---------------------------------------------------
+
tcGuardStmt :: TcStmtChecker
-tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
+tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
= do { guard' <- tcMonoExpr guard boolTy
; thing <- thing_inside res_ty
- ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
+ ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
@@ -341,25 +354,292 @@ tcGuardStmt _ stmt _ _
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
---------------------------------
--- List comprehensions and PArrays
+---------------------------------------------------
+-- List comprehensions and PArrays
+-- (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
+-- b) We have special desugaring rules for list comprehensions,
+-- which avoid creating intermediate lists. They in turn
+-- assume that the bind/return operations are the regular
+-- polymorphic ones, and in particular don't have any
+-- coercion matching stuff in them. It's hard to avoid the
+-- potential for non-trivial coercions in tcMcStmt
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
+tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
+ = do { body' <- tcMonoExprNC body elt_ty
+ ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
-- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
+ thing_inside elt_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
-tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
+tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs boolTy
- ; thing <- thing_inside res_ty
- ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
+ ; thing <- thing_inside elt_ty
+ ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
+
+-- ParStmt: See notes with tcMcStmt
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
+ = do { (pairs', thing) <- loop bndr_stmts_s
+ ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
+ where
+ -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop [] = do { thing <- thing_inside elt_ty
+ ; return ([], thing) } -- matching in the branches
+
+ loop ((stmts, names) : pairs)
+ = do { (stmts', (ids, pairs', thing))
+ <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+ do { ids <- tcLookupLocalIds names
+ ; (pairs', thing) <- loop pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
+ , trS_bndrs = bindersMap
+ , trS_by = by, trS_using = using }) elt_ty thing_inside
+ = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+ unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
+ -- The inner 'stmts' lack a LastStmt, so the element type
+ -- passed in to tcStmtsAndThen is never looked at
+ ; (stmts', (bndr_ids, by'))
+ <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+ { by' <- case by of
+ Nothing -> return Nothing
+ Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) }
+ ; bndr_ids <- tcLookupLocalIds bndr_names
+ ; return (bndr_ids, by') }
+
+ ; let m_app ty = mkTyConApp m_tc [ty]
+
+ --------------- Typecheck the 'using' function -------------
+ -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
+ -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
+
+ -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
+ ; let n_app = case form of
+ ThenForm -> (\ty -> ty)
+ _ -> m_app
+
+ by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+ by_arrow = case by' of
+ Nothing -> \ty -> ty
+ Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
+
+ tup_ty = mkBigCoreVarTupTy bndr_ids
+ poly_arg_ty = m_app alphaTy
+ poly_res_ty = m_app (n_app alphaTy)
+ using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
+ poly_arg_ty `mkFunTy` poly_res_ty
+
+ ; using' <- tcPolyExpr using using_poly_ty
+ ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
+
+ -- 'stmts' returns a result of type (m1_ty tuple_ty),
+ -- typically something like [(Int,Bool,Int)]
+ -- We don't know what tuple_ty is yet, so we use a variable
+ ; let mk_n_bndr :: Name -> TcId -> TcId
+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
+
+ -- Ensure that every old binder of type `b` is linked up with its
+ -- new binder which should have type `n b`
+ -- See Note [GroupStmt binder map] in HsExpr
+ n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+ bindersMap' = bndr_ids `zip` n_bndr_ids
+
+ -- Type check the thing in the environment with
+ -- these new binders and return the result
+ ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
+
+ ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+ , trS_by = fmap fst by', trS_using = final_using
+ , trS_form = form }, thing) }
+
+tcLcStmt _ _ stmt _ _
+ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+-- Monad comprehensions
+-- (supports rebindable syntax)
+---------------------------------------------------
+
+tcMcStmt :: TcStmtChecker
+
+tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
+ = do { a_ty <- newFlexiTyVarTy liftedTypeKind
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op
+ (a_ty `mkFunTy` res_ty)
+ ; body' <- tcMonoExprNC body a_ty
+ ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
+ ; return (LastStmt body' return_op', thing) }
+
+-- Generators for monad comprehensions ( pat <- rhs )
+--
+-- [ body | q <- gen ] -> gen :: m a
+-- q :: a
+--
+
+tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+ = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
+ ; pat_ty <- newFlexiTyVarTy liftedTypeKind
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+
+ -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
+ (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
+
+ -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+ ; fail_op' <- if isIrrefutableHsPat pat
+ then return noSyntaxExpr
+ else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
+
+ ; rhs' <- tcMonoExprNC rhs rhs_ty
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
+ thing_inside new_res_ty
+
+ ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+
+-- Boolean expressions.
+--
+-- [ body | stmts, expr ] -> expr :: m Bool
+--
+tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
+ = do { -- Deal with rebindable syntax:
+ -- guard_op :: test_ty -> rhs_ty
+ -- then_op :: rhs_ty -> new_res_ty -> res_ty
+ -- Where test_ty is, for example, Bool
+ test_ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs_ty <- newFlexiTyVarTy liftedTypeKind
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs' <- tcMonoExpr rhs test_ty
+ ; guard_op' <- tcSyntaxOp MCompOrigin guard_op
+ (mkFunTy test_ty rhs_ty)
+ ; then_op' <- tcSyntaxOp MCompOrigin then_op
+ (mkFunTys [rhs_ty, new_res_ty] res_ty)
+ ; thing <- thing_inside new_res_ty
+ ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
+
+-- Grouping statements
+--
+-- [ body | stmts, then group by e ]
+-- -> e :: t
+-- [ body | stmts, then group by e using f ]
+-- -> e :: t
+-- f :: forall a. (a -> t) -> m a -> m (m a)
+-- [ body | stmts, then group using f ]
+-- -> f :: forall a. m a -> m (m a)
+
+-- We type [ body | (stmts, group by e using f), ... ]
+-- f <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 = ...
@@ -381,106 +661,95 @@ tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
-- So the binders of the first parallel group will be in scope in the second
-- group. But that's fine; there's no shadowing to worry about.
-
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
- = do { (pairs', thing) <- loop bndr_stmts_s
- ; return (ParStmt pairs', thing) }
- where
- -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
- loop [] = do { thing <- thing_inside elt_ty
- ; return ([], thing) } -- matching in the branches
-
- loop ((stmts, names) : pairs)
- = do { (stmts', (ids, pairs', thing))
- <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
- do { ids <- tcLookupLocalIds names
- ; (pairs', thing) <- loop pairs
- ; return (ids, pairs', thing) }
- ; return ( (stmts', ids) : pairs', thing ) }
-
-tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
- (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
- let alphaListTy = mkTyConApp m_tc [alphaTy]
-
- (usingExpr', maybeByExpr') <-
- case maybeByExpr of
- Nothing -> do
- -- We must validate that usingExpr :: forall a. [a] -> [a]
- let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
- usingExpr' <- tcPolyExpr usingExpr using_ty
- return (usingExpr', Nothing)
- Just byExpr -> do
- -- We must infer a type such that e :: t and then check that
- -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
- (byExpr', tTy) <- tcInferRhoNC byExpr
- let using_ty = mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` tTy)
- `mkFunTy` alphaListTy `mkFunTy` alphaListTy
- usingExpr' <- tcPolyExpr usingExpr using_ty
- return (usingExpr', Just byExpr')
-
- binders' <- tcLookupLocalIds binders
- thing <- thing_inside elt_ty'
-
- return (binders', usingExpr', maybeByExpr', thing)
-
- return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
-
-tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
- = do { let (bndr_names, list_bndr_names) = unzip bindersMap
-
- ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
- (by', using_ty) <-
- case by of
- Nothing -> -- check that using :: forall a. [a] -> [[a]]
- return (Nothing, mkForAllTy alphaTyVar $
- alphaListTy `mkFunTy` alphaListListTy)
-
- Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
- -- where by :: t
- do { (by_e', t_ty) <- tcInferRhoNC by_e
- ; return (Just by_e', mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` t_ty)
- `mkFunTy` alphaListTy
- `mkFunTy` alphaListListTy) }
- -- Find the Ids (and hence types) of all old binders
- bndr_ids <- tcLookupLocalIds bndr_names
-
- return (bndr_ids, by', using_ty, elt_ty')
-
- -- Ensure that every old binder of type b is linked up with
- -- its new binder which should have type [b]
- ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
- bindersMap' = bndr_ids `zip` list_bndr_ids
- -- See Note [GroupStmt binder map] in HsExpr
-
- ; using' <- case using of
- Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
- Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
-
- -- Type check the thing in the environment with
- -- these new binders and return the result
- ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
- ; return (GroupStmt stmts' bindersMap' by' using', thing) }
- where
- alphaListTy = mkTyConApp m_tc [alphaTy]
- alphaListListTy = mkTyConApp m_tc [alphaListTy]
-
- mk_list_bndr :: Name -> TcId -> TcId
- mk_list_bndr list_bndr_name bndr_id
- = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
-
-tcLcStmt _ _ stmt _ _
- = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
-
---------------------------------
--- Do-notation
--- The main excitement here is dealing with rebindable syntax
+--
+-- Note: The `mzip` function will get typechecked via:
+--
+-- ParStmt [st1::t1, st2::t2, st3::t3]
+--
+-- mzip :: m st1
+-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
+-- -> m (st1, (st2, st3))
+--
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
+ = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+ ; m_ty <- newFlexiTyVarTy star_star_kind
+
+ ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
+ (m_ty `mkAppTy` alphaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` betaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+ ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+
+ ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
+ mkForAllTy alphaTyVar $
+ alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
+
+ ; (pairs', thing) <- loop m_ty bndr_stmts_s
+
+ -- Typecheck bind:
+ ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
+ tuple_ty = mk_tuple_ty tys
+
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ (m_ty `mkAppTy` tuple_ty)
+ `mkFunTy` (tuple_ty `mkFunTy` res_ty)
+ `mkFunTy` res_ty
+
+ ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
+
+ where
+ mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+
+ -- loop :: Type -- m_ty
+ -- -> [([LStmt Name], [Name])]
+ -- -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop _ [] = do { thing <- thing_inside res_ty
+ ; return ([], thing) } -- matching in the branches
+
+ loop m_ty ((stmts, names) : pairs)
+ = do { -- type dummy since we don't know all binder types yet
+ ty_dummy <- newFlexiTyVarTy liftedTypeKind
+ ; (stmts', (ids, pairs', thing))
+ <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
+ do { ids <- tcLookupLocalIds names
+ ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
+
+ ; check_same m_tup_ty res_ty'
+ ; check_same m_tup_ty ty_dummy
+
+ ; (pairs', thing) <- loop m_ty pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+ -- Check that the types match up.
+ -- This is a grevious hack. They always *will* match
+ -- If (>>=) and (>>) are polymorpic in the return type,
+ -- but we don't have any good way to incorporate the coercion
+ -- so for now we just check that it's the identity
+ check_same actual expected
+ = do { coi <- unifyType actual expected
+ ; unless (isReflCo coi) $
+ failWithMisMatch [UnifyOrigin { uo_expected = expected
+ , uo_actual = actual }] }
+
+tcMcStmt _ stmt _ _
+ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+-- Do-notation
+-- (supports rebindable syntax)
+---------------------------------------------------
tcDoStmt :: TcStmtChecker
+tcDoStmt _ (LastStmt body _) res_ty thing_inside
+ = do { body' <- tcMonoExprNC body res_ty
+ ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
@@ -510,7 +779,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
+tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
= do { -- Deal with rebindable syntax;
-- (>>) :: rhs_ty -> new_res_ty -> res_ty
-- See also Note [Treat rebindable syntax first]
@@ -521,7 +790,7 @@ tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
; rhs' <- tcMonoExprNC rhs rhs_ty
; thing <- thing_inside new_res_ty
- ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+ ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names, recS_ret_fn = ret_op
@@ -535,7 +804,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; tcExtendIdEnv tup_ids $ do
{ stmts_ty <- newFlexiTyVarTy liftedTypeKind
; (stmts', (ret_op', tup_rets))
- <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
+ <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
-- Unify the types of the "final" Ids (which may
-- be polymorphic) with those of "knot-tied" Ids
@@ -551,7 +820,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
(mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
; thing <- thing_inside new_res_ty
--- ; lie_binds <- bindLocalMethods lie tup_ids
; let rec_ids = takeList rec_names tup_ids
; later_ids <- tcLookupLocalIds later_names
@@ -560,7 +828,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
- , recS_rec_rets = tup_rets }, thing)
+ , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
}}
tcDoStmt _ stmt _ _
@@ -577,51 +845,6 @@ rebindable syntax first, and push that information into (tcMonoExprNC rhs).
Otherwise the error shows up when cheking the rebindable syntax, and
the expected/inferred stuff is back to front (see Trac #3613).
-\begin{code}
---------------------------------
--- Mdo-notation
--- The distinctive features here are
--- (a) RecStmts, and
--- (b) no rebindable syntax
-
-tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
- -> TcStmtChecker
-tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
- ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
- = do { (rhs', elt_ty) <- tc_rhs rhs
- ; thing <- thing_inside res_ty
- ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
-
-tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
- , recS_rec_ids = recNames }) res_ty thing_inside
- = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
- ; let rec_ids = zipWith mkLocalId recNames rec_tys
- ; tcExtendIdEnv rec_ids $ do
- { (stmts', (later_ids, rec_rets))
- <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
- -- ToDo: res_ty not really right
- do { rec_rets <- zipWithM tcCheckId recNames rec_tys
- ; later_ids <- tcLookupLocalIds laterNames
- ; return (later_ids, rec_rets) }
-
- ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
- -- NB: The rec_ids for the recursive things
- -- already scope over this part. This binding may shadow
- -- some of them with polymorphic things with the same Name
- -- (see note [RecStmt] in HsExpr)
-
- ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
- }}
-
-tcMDoStmt _ _ stmt _ _
- = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
-\end{code}
-
%************************************************************************
%* *
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index d28e901325e6c3de4f85802248260e02bb137f16..8304a22ddbe20cdf95fb0fff6824a2543c518ee4 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -36,7 +36,6 @@ import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
@@ -149,7 +148,7 @@ data TcSigInfo
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
- = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau
+ = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
\end{code}
Note [sig_tau may be polymorphic]
@@ -193,7 +192,7 @@ res_ty free vars.
%************************************************************************
\begin{code}
-tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId)
+tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId)
-- (coi, xp) = tcPatBndr penv x pat_ty
-- Then coi : pat_ty ~ typeof(xp)
--
@@ -205,11 +204,11 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
| otherwise
= do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
- ; return (IdCo pat_ty, bndr_id) }
+ ; return (mkReflCo pat_ty, bndr_id) }
tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
= do { bndr <- mkLocalBinder bndr_name pat_ty
- ; return (IdCo pat_ty, bndr) }
+ ; return (mkReflCo pat_ty, bndr) }
------------
newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId
@@ -348,9 +347,9 @@ tc_lpat :: LPat Name
-> TcM a
-> TcM (LPat TcId, a)
tc_lpat (L span pat) pat_ty penv thing_inside
- = setSrcSpan span $
- maybeAddErrCtxt (patCtxt pat) $
- do { (pat', res) <- tc_pat penv pat pat_ty thing_inside
+ = setSrcSpan span $
+ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+ thing_inside
; return (L span pat', res) }
tc_lpats :: PatEnv
@@ -373,7 +372,7 @@ tc_pat :: PatEnv
tc_pat penv (VarPat name) pat_ty thing_inside
= do { (coi, id) <- tcPatBndr penv name pat_ty
; res <- tcExtendIdEnv1 name id thing_inside
- ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
+ ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) }
tc_pat penv (ParPat pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
@@ -423,7 +422,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
-- perhaps be fixed, but only with a bit more work.
--
-- If you fix it, don't forget the bindInstsOfPatIds!
- ; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+ ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside
= do { checkUnboxedTuple overall_pat_ty $
@@ -448,7 +447,7 @@ tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside
-- pattern must have pat_ty
; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
- ; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) }
+ ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) }
-- Type signatures in patterns
-- See Note [Pattern coercions] below
@@ -459,9 +458,6 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
-tc_pat _ pat@(TypePat _) _ _
- = failWithTc (badTypePat pat)
-
------------------------
-- Lists, tuples, arrays
tc_pat penv (ListPat pats _) pat_ty thing_inside
@@ -511,7 +507,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside
; coi <- unifyPatType lit_ty pat_ty
-- coi is of kind: pat_ty ~ lit_ty
; res <- thing_inside
- ; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty
+ ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty
, res) }
------------------------
@@ -546,19 +542,19 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
; instStupidTheta orig [mkClassPred icls [pat_ty']]
; res <- tcExtendIdEnv1 name bndr_id thing_inside
- ; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
+ ; return (mkHsWrapPatCo coi pat' pat_ty, res) }
tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
----------------
-unifyPatType :: TcType -> TcType -> TcM CoercionI
+unifyPatType :: TcType -> TcType -> TcM Coercion
-- In patterns we want a coercion from the
-- context type (expected) to the actual pattern type
-- But we don't want to reverse the args to unifyType because
-- that controls the actual/expected stuff in error messages
unifyPatType actual_ty expected_ty
= do { coi <- unifyType actual_ty expected_ty
- ; return (mkSymCoI coi) }
+ ; return (mkSymCo coi) }
\end{code}
Note [Hopping the LIE in lazy patterns]
@@ -657,7 +653,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
= do { data_con <- tcLookupDataCon con_name
; let tycon = dataConTyCon data_con
-- For data families this is the representation tycon
- (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
= dataConFullSig data_con
-- Instantiate the constructor type variables [a->ty]
@@ -679,9 +675,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
arg_tys' = substTys tenv arg_tys
- full_theta = eq_theta ++ dict_theta
- ; if null ex_tvs && null eq_spec && null full_theta
+ ; if null ex_tvs && null eq_spec && null theta
then do { -- The common case; no class bindings etc
-- (see Note [Arrows and patterns])
(arg_pats', res) <- tcConArgs data_con arg_tys'
@@ -696,8 +691,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
else do -- The general case, with existential,
-- and local equality constraints
- { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
- theta' = substTheta tenv (eq_preds ++ full_theta)
+ { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta)
-- order is *important* as we generate the list of
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
@@ -726,21 +720,21 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
} }
----------------------------
-matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a))
+matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a))
-> TcRhoType -> TcM (HsWrapper, a)
-- See Note [Matching polytyped patterns]
-- Returns a wrapper : pat_ty ~ inner_ty
matchExpectedPatTy inner_match pat_ty
| null tvs && null theta
= do { (coi, res) <- inner_match pat_ty
- ; return (coiToHsWrapper (mkSymCoI coi), res) }
+ ; return (coToHsWrapper (mkSymCo coi), res) }
-- The Sym is because the inner_match returns a coercion
-- that is the other way round to matchExpectedPatTy
| otherwise
= do { (_, tys, subst) <- tcInstTyVars tvs
; wrap1 <- instCall PatOrigin tys (substTheta subst theta)
- ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau)
+ ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau)
; return (wrap2 <.> wrap1 , arg_tys) }
where
(tvs, theta, tau) = tcSplitSigmaTy pat_ty
@@ -749,7 +743,7 @@ matchExpectedPatTy inner_match pat_ty
matchExpectedConTy :: TyCon -- The TyCon that this data
-- constructor actually returns
-> TcRhoType -- The type of the pattern
- -> TcM (CoercionI, [TcSigmaType])
+ -> TcM (Coercion, [TcSigmaType])
-- See Note [Matching constructor patterns]
-- Returns a coercion : T ty1 ... tyn ~ pat_ty
-- This is the same way round as matchExpectedListTy etc
@@ -764,17 +758,16 @@ matchExpectedConTy data_tc pat_ty
; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
-- coi1 : T (ty1,ty2) ~ pat_ty
- ; let coi2 = ACo (mkTyConApp co_tc tys)
+ ; let coi2 = mkAxInstCo co_tc tys
-- coi2 : T (ty1,ty2) ~ T7 ty1 ty2
- ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) }
+ ; return (mkTransCo (mkSymCo coi2) coi1, tys) }
| otherwise
= matchExpectedTyConApp data_tc pat_ty
-- coi : T tys ~ pat_ty
\end{code}
-Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
@@ -1006,12 +999,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
-}
\begin{code}
-patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context
-patCtxt (VarPat _) = Nothing
-patCtxt (ParPat _) = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
- 2 (ppr pat))
+maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside
+ | not (worth_wrapping pat) = tcm thing_inside
+ | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+ -- Remember to pop before doing thing_inside
+ where
+ worth_wrapping (VarPat {}) = False
+ worth_wrapping (ParPat {}) = False
+ worth_wrapping (AsPat {}) = False
+ worth_wrapping _ = True
+ msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
-----------------------------------------------
checkExistentials :: [TyVar] -> PatEnv -> TcM ()
@@ -1047,9 +1046,6 @@ polyPatSig sig_ty
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat :: Pat Name -> SDoc
-badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
-
lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
lazyUnliftedPatErr pat
= failWithTc $
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 23c2e67daaf16f36c8f75b2202d25986623e8c17..6850846950419426b1013b8ba204d5809691240e 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -65,7 +65,6 @@ import Name
import NameEnv
import NameSet
import TyCon
-import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
@@ -246,9 +245,8 @@ tcRnImports hsc_env this_mod import_decls
-- interfaces, so that their rules and instance decls will be
-- found.
; loadOrphanModules (imp_orphs imports) False
- ; loadOrphanModules (imp_finsts imports) True
- -- Check type-familily consistency
+ -- Check type-family consistency
; traceRn (text "rn1: checking family instance consistency")
; let { dir_imp_mods = moduleEnvKeys
. imp_mods
@@ -300,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
@@ -501,10 +499,9 @@ tcRnHsBootDecls decls
-- Typecheck type/class decls
; traceTc "Tc2" empty
- ; (tcg_env, aux_binds, dm_ids)
+ ; (tcg_env, aux_binds)
<- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ ; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
@@ -645,7 +642,7 @@ checkHiBootIface
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
- idType dfun `tcEqType` boot_inst_ty ] of
+ idType dfun `eqType` boot_inst_ty ] of
[] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
, text "boot_inst" <+> ppr boot_inst
, text "boot_inst_ty" <+> ppr boot_inst_ty
@@ -669,7 +666,7 @@ checkBootDecl :: TyThing -> TyThing -> Bool
checkBootDecl (AnId id1) (AnId id2)
= ASSERT(id1 == id2)
- (idType id1 `tcEqType` idType id2)
+ (idType id1 `eqType` idType id2)
checkBootDecl (ATyCon tc1) (ATyCon tc2)
= checkBootTyCon tc1 tc2
@@ -686,7 +683,7 @@ checkBootDecl (AClass c1) (AClass c2)
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
- tcEqTypeX env op_ty1 op_ty2 &&
+ eqTypeX env op_ty1 op_ty2 &&
def_meth1 == def_meth2
where
(_, rho_ty1) = splitForAllTys (idType id1)
@@ -695,8 +692,8 @@ checkBootDecl (AClass c1) (AClass c2)
op_ty2 = funResultTy rho_ty2
eqFD (as1,bs1) (as2,bs2) =
- eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
- eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+ eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+ eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
in
@@ -705,7 +702,7 @@ checkBootDecl (AClass c1) (AClass c2)
eqListBy eqFD clas_fds1 clas_fds2 &&
(null sc_theta1 && null op_stuff1 && null ats1
|| -- Above tests for an "abstract" class
- eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+ eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
@@ -728,7 +725,7 @@ checkBootTyCon tc1 tc2
eqSynRhs SynFamilyTyCon SynFamilyTyCon
= True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
- = tcEqTypeX env t1 t2
+ = eqTypeX env t1 t2
eqSynRhs _ _ = False
in
equalLength tvs1 tvs2 &&
@@ -737,7 +734,7 @@ checkBootTyCon tc1 tc2
| isAlgTyCon tc1 && isAlgTyCon tc2
= ASSERT(tc1 == tc2)
eqKind (tyConKind tc1) (tyConKind tc2) &&
- eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+ eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
| isForeignTyCon tc1 && isForeignTyCon tc2
@@ -761,17 +758,7 @@ checkBootTyCon tc1 tc2
&& dataConIsInfix c1 == dataConIsInfix c2
&& dataConStrictMarks c1 == dataConStrictMarks c2
&& dataConFieldLabels c1 == dataConFieldLabels c2
- && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
- tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
- env = rnBndrs2 env0 tvs1 tvs2
- in
- equalLength tvs1 tvs2 &&
- eqListBy (tcEqPredX env)
- (dataConEqTheta c1 ++ dataConDictTheta c1)
- (dataConEqTheta c2 ++ dataConDictTheta c2) &&
- eqListBy (tcEqTypeX env)
- (dataConOrigArgTys c1)
- (dataConOrigArgTys c2)
+ && eqType (dataConUserType c1) (dataConUserType c2)
----------------
missingBootThing :: Name -> String -> SDoc
@@ -848,11 +835,10 @@ tcTopSrcDecls boot_details
-- The latter come in via tycl_decls
traceTc "Tc2" empty ;
- (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
@@ -886,6 +872,7 @@ tcTopSrcDecls boot_details
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
+ -- now using the kind-checked decls
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
@@ -1205,7 +1192,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
--------------------
mkPlan :: LStmt Name -> TcM PlanResult
-mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
the_bind = L loc $ mkFunBind (L loc fresh_it) matches
@@ -1214,7 +1201,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
- (HsVar thenIOName) placeHolderType
+ (HsVar thenIOName) noSyntaxExpr placeHolderType
-- The plans are:
-- [it <- e; print it] but not if it::()
@@ -1242,7 +1229,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
mkPlan stmt@(L loc (BindStmt {}))
| [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
- (HsVar thenIOName) placeHolderType
+ (HsVar thenIOName) noSyntaxExpr placeHolderType
; print_bind_result <- doptM Opt_PrintBindResult
; let print_plan = do
@@ -1269,11 +1256,25 @@ tcGhciStmts stmts
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
-
+ tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
names = collectLStmtsBinders stmts ;
+ } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+ ((tc_stmts, ids), lie) <- captureConstraints $
+ tc_io_stmts stmts $ \ _ ->
+ mapM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
- -- mk_return builds the expression
+ -- Simplify the context
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ let { -- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
--
-- Despite the inconvenience of building the type applications etc,
@@ -1284,27 +1285,14 @@ tcGhciStmts stmts
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
- (nlHsVar id)
- } ;
-
- -- OK, we're ready to typecheck the stmts
- traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
- ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
- mapM tcLookupId names ;
- -- Look up the names right in the middle,
- -- where they will all be in scope
-
- -- Simplify the context
- traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
- const_binds <- checkNoErrs (simplifyInteractive lie) ;
- -- checkNoErrs ensures that the plan fails if context redn fails
-
- traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ (nlHsVar id) ;
+ stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+ } ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
+ noLoc (HsDo GhciStmt stmts io_ret_ty))
}
\end{code}
@@ -1325,16 +1313,13 @@ tcRnExpr hsc_env ictxt rdr_expr
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
-
uniq <- newUnique ;
let { fresh_it = itName uniq } ;
- ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
- ((qtvs, dicts, _), lie_top) <- captureConstraints $
- simplifyInfer TopLevel
- False {- No MR for now -}
+ ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
+ ((qtvs, dicts, _), lie_top) <- captureConstraints $
+ simplifyInfer TopLevel False {- No MR for now -}
[(fresh_it, res_ty)]
lie ;
-
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
@@ -1381,29 +1366,20 @@ tcRnType hsc_env ictxt rdr_type
-- could not be found.
getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
getModuleExports hsc_env mod
- = let
- ic = hsc_IC hsc_env
- checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
- in
- initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
+ = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod)
-- Get the export avail info and also load all orphan and family-instance
-- modules. Finally, check that the family instances of all modules in the
-- interactive context are consistent (these modules are in the second
-- argument).
-tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
-tcGetModuleExports mod directlyImpMods
+tcGetModuleExports :: Module -> TcM [AvailInfo]
+tcGetModuleExports mod
= do { let doc = ptext (sLit "context for compiling statements")
; iface <- initIfaceTcRn $ loadSysInterface doc mod
-- Load any orphan-module and family instance-module
-- interfaces, so their instances are visible.
; loadOrphanModules (dep_orphs (mi_deps iface)) False
- ; loadOrphanModules (dep_finsts (mi_deps iface)) True
-
- -- Check that the family instances of all directly loaded
- -- modules are consistent.
- ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
; ifaceExportNames (mi_exports iface)
}
@@ -1586,7 +1562,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
, vcat (map ppr vects)
- , ppr_gen_tycons (typeEnvTyCons type_env)
, ptext (sLit "Dependent modules:") <+>
ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
@@ -1621,7 +1596,10 @@ ppr_types insts type_env
ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env
- = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+ = vcat [ text "TYPE CONSTRUCTORS"
+ , nest 2 (ppr_tydecls tycons)
+ , text "COERCION AXIOMS"
+ , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
where
fi_tycons = map famInstTyCon fam_insts
tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
@@ -1653,22 +1631,11 @@ ppr_tydecls tycons
= vcat (map ppr_tycon (sortLe le_sig tycons))
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
- ppr_tycon tycon
- | isCoercionTyCon tycon
- = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
- , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
- | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
- where
- tvs = take (tyConArity tycon) alphaTyVars
+ ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
nest 2 (pprRules rs),
ptext (sLit "#-}")]
-
-ppr_gen_tycons :: [TyCon] -> SDoc
-ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
- nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index ad2405b95e19912204efb9de127f145d9a788157..7e7f117cdf28d272ff0e4ac5916b9c4a5bf3caa3 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -406,7 +406,6 @@ traceRn, traceSplice :: SDoc -> TcRn ()
traceRn = traceOptTcRn Opt_D_dump_rn_trace
traceSplice = traceOptTcRn Opt_D_dump_splices
-
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
@@ -781,11 +780,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
--- Conditionally add an error context
-maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
-maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
-maybeAddErrCtxt Nothing thing_inside = thing_inside
-
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
@@ -897,6 +891,9 @@ add_err_tcm tidy_env err_msg loc ctxt
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo env ctxts
+ | opt_PprStyle_Debug -- In -dppr-debug style the output
+ = return empty -- just becomes too voluminous
+ | otherwise
= go 0 env ctxts
where
go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
@@ -1152,7 +1149,7 @@ failIfM :: Message -> IfL a
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
- ; liftIO (printErrs (full_msg defaultErrStyle))
+ ; liftIO (printErrs full_msg defaultErrStyle)
; failM }
--------------------
@@ -1187,7 +1184,7 @@ forkM_maybe doc thing_inside
; return Nothing }
}}
where
- print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+ print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 3367f06ded418cac21b177ed3d0221eff3db94ff..17e5dcbb949400e9a82f9be412668b16ef1e6c47 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -40,11 +40,13 @@ module TcRnTypes(
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
- WantedLoc, GivenLoc, pushErrCtxt,
+ WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
- SkolemInfo(..),
+ SkolemInfo(..),
- CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+ CtFlavor(..), pprFlavorArising, isWanted,
+ isGivenOrSolved, isGiven_maybe,
+ isDerived,
FlavoredEvVar,
-- Pretty printing
@@ -62,6 +64,7 @@ module TcRnTypes(
import HsSyn
import HscTypes
import Type
+import Id ( evVarPred )
import Class ( Class )
import DataCon ( DataCon, dataConUserType )
import TcType
@@ -324,6 +327,7 @@ data IfLclEnv
-- plus which bit is currently being examined
if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings
+ -- (and coercions)
if_id_env :: UniqFM Id -- Nested id binding
}
\end{code}
@@ -639,7 +643,7 @@ plusImportAvails
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 })
- = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
+ = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
@@ -674,7 +678,6 @@ instance Outputable WhereFrom where
%************************************************************************
%* *
Wanted constraints
-
These are forced to be in TcRnTypes because
TcLclEnv mentions WantedConstraints
WantedConstraint mentions CtLoc
@@ -901,7 +904,7 @@ pprEvVarTheta :: [EvVar] -> SDoc
pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
pprEvVarWithType :: EvVar -> SDoc
-pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)
pprWantedsWithLocs :: WantedConstraints -> SDoc
pprWantedsWithLocs wcs
@@ -923,35 +926,37 @@ pprWantedEvVar (EvVarX v _) = pprEvVarWithType v
\begin{code}
data CtFlavor
- = Given GivenLoc -- We have evidence for this constraint in TcEvBinds
- | Derived WantedLoc
- -- We have evidence for this constraint in TcEvBinds;
- -- *however* this evidence can contain wanteds, so
- -- it's valid only provisionally to the solution of
- -- these wanteds
- | Wanted WantedLoc -- We have no evidence bindings for this constraint.
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses.
+ = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+ | Derived WantedLoc -- Derived's are just hints for unifications
+ | Wanted WantedLoc -- We have no evidence bindings for this constraint.
+
+data GivenKind
+ = GivenOrig -- Originates in some given, such as signature or pattern match
+ | GivenSolved -- Is given as result of being solved, maybe provisionally on
+ -- some other wanted constraints.
instance Outputable CtFlavor where
- ppr (Given {}) = ptext (sLit "[G]")
- ppr (Wanted {}) = ptext (sLit "[W]")
- ppr (Derived {}) = ptext (sLit "[D]")
+ ppr (Given _ GivenOrig) = ptext (sLit "[G]")
+ ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+ ppr (Wanted {}) = ptext (sLit "[W]")
+ ppr (Derived {}) = ptext (sLit "[D]")
+
pprFlavorArising :: CtFlavor -> SDoc
-pprFlavorArising (Derived wl ) = pprArisingAt wl
+pprFlavorArising (Derived wl) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
-pprFlavorArising (Given gl) = pprArisingAt gl
+pprFlavorArising (Given gl _) = pprArisingAt gl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
-isGiven :: CtFlavor -> Bool
-isGiven (Given {}) = True
-isGiven _ = False
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _ = Nothing
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
@@ -1038,9 +1043,6 @@ data SkolemInfo
-- polymorphic Ids, and are now checking that their RHS
-- constraints are satisfied.
- | RuntimeUnkSkol -- a type variable used to represent an unknown
- -- runtime type (used in the GHCi debugger)
-
| BracketSkol -- Template Haskell bracket
| UnkSkol -- Unhelpful info (until I improve it)
@@ -1075,8 +1077,7 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
-- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.
-- For Insts, these cases should not happen
-pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
-pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol")
+pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
\end{code}
@@ -1116,6 +1117,7 @@ data CtOrigin
| StandAloneDerivOrigin -- Typechecking stand-alone deriving
| DefaultOrigin -- Typechecking a default decl
| DoOrigin -- Arising from a do expression
+ | MCompOrigin -- Arising from a monad comprehension
| IfOrigin -- Arising from an if statement
| ProcOrigin -- Arising from a proc expression
| AnnOrigin -- An annotation
@@ -1151,6 +1153,7 @@ pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declarat
pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
pprO DefaultOrigin = ptext (sLit "a 'default' declaration")
pprO DoOrigin = ptext (sLit "a do statement")
+pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension")
pprO ProcOrigin = ptext (sLit "a proc expression")
pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq
pprO AnnOrigin = ptext (sLit "an annotation")
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index b2c1dac62088a88cd7eaa1d42857b4a95a883821..3925c6def3e535048aa4b0972a7c3d94a546c7b4 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -17,7 +17,6 @@ import TcHsType
import TcExpr
import TcEnv
import Id
-import Var ( Var )
import Name
import VarSet
import SrcLoc
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 87cd5eb2b10bc8bfcbee6e9e42af7dbc95bfbebf..0992fb971e6d8e6d49be73ca66afce68cb1462fe 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -15,13 +15,15 @@ module TcSMonad (
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts,
deCanonicalise, mkFrozenError,
- isWanted, isGiven, isDerived,
- isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
+ isWanted, isGivenOrSolved, isDerived,
+ isGivenOrSolvedCt, isGivenCt_maybe,
+ isWantedCt, isDerivedCt, pprFlavorArising,
isFlexiTcsTv,
canRewrite, canSolve,
- combineCtLoc, mkGivenFlavor, mkWantedFlavor,
+ combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+ mkWantedFlavor,
getWantedLoc,
TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality
@@ -39,6 +41,8 @@ module TcSMonad (
setWantedTyBind,
+ lookupFlatCacheMap, updateFlatCacheMap,
+
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
@@ -82,6 +86,7 @@ import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
+import Kind
import TcType
import DynFlags
@@ -97,14 +102,20 @@ import Outputable
import Bag
import MonadUtils
import VarSet
+import Pair
import FastString
import HsBinds -- for TcEvBinds stuff
import Id
-
import TcRnTypes
-
import Data.IORef
+
+import qualified Data.Map as Map
+
+#ifdef DEBUG
+import StaticFlags( opt_PprStyle_Debug )
+import Control.Monad( when )
+#endif
\end{code}
@@ -204,9 +215,9 @@ instance Outputable CanonicalCt where
ppr (CIPCan ip fl ip_nm ty)
= ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
ppr (CTyEqCan co fl tv ty)
- = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
+ = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty)
ppr (CFunEqCan co fl tc tys ty)
- = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
+ = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty)
ppr (CFrozenErr co fl)
= ppr fl <+> pprEvVarWithType co
\end{code}
@@ -330,11 +341,16 @@ getWantedLoc ct
isWantedCt :: CanonicalCt -> Bool
isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool
-isGivenCt ct = isGiven (cc_flavor ct)
isDerivedCt :: CanonicalCt -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
+
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
@@ -359,22 +375,27 @@ canRewrite = canSolve
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
-combineCtLoc (Wanted loc) _ = loc
-combineCtLoc _ (Wanted loc) = loc
-combineCtLoc (Derived loc ) _ = loc
-combineCtLoc _ (Derived loc ) = loc
+combineCtLoc (Wanted loc) _ = loc
+combineCtLoc _ (Wanted loc) = loc
+combineCtLoc (Derived loc ) _ = loc
+combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
-mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
+mkSolvedFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
-mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
\end{code}
%************************************************************************
@@ -409,10 +430,33 @@ data TcSEnv
tcs_untch :: TcsUntouchables,
- tcs_ic_depth :: Int, -- Implication nesting depth
- tcs_count :: IORef Int -- Global step count
+ tcs_ic_depth :: Int, -- Implication nesting depth
+ tcs_count :: IORef Int, -- Global step count
+
+ tcs_flat_map :: IORef FlatCache
}
+data FlatCache
+ = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+ -- Invariant: all CtFlavors here satisfy isGiven
+ , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+ -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache
+ = FlatCache { givenFlatCache = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+ FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+ FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2)
+ = case compare tc1 tc2 of
+ EQ -> cmpTypes xis1 xis2
+ other -> other
+
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables,
-- but records extra TcsTv variables generated during simplification
@@ -421,17 +465,16 @@ type TcsUntouchables = (Untouchables,TcTyVarSet)
\begin{code}
data SimplContext
- = SimplInfer -- Inferring type of a let-bound thing
- | SimplRuleLhs -- Inferring type of a RULE lhs
- | SimplInteractive -- Inferring type at GHCi prompt
- | SimplCheck -- Checking a type signature or RULE rhs
- deriving Eq
+ = SimplInfer SDoc -- Inferring type of a let-bound thing
+ | SimplRuleLhs RuleName -- Inferring type of a RULE lhs
+ | SimplInteractive -- Inferring type at GHCi prompt
+ | SimplCheck SDoc -- Checking a type signature or RULE rhs
instance Outputable SimplContext where
- ppr SimplInfer = ptext (sLit "SimplInfer")
- ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs")
+ ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d
+ ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d
+ ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n)
ppr SimplInteractive = ptext (sLit "SimplInteractive")
- ppr SimplCheck = ptext (sLit "SimplCheck")
isInteractive :: SimplContext -> Bool
isInteractive SimplInteractive = True
@@ -441,14 +484,14 @@ simplEqsOnly :: SimplContext -> Bool
-- Simplify equalities only, not dictionaries
-- This is used for the LHS of rules; ee
-- Note [Simplifying RULE lhs constraints] in TcSimplify
-simplEqsOnly SimplRuleLhs = True
-simplEqsOnly _ = False
+simplEqsOnly (SimplRuleLhs {}) = True
+simplEqsOnly _ = False
performDefaulting :: SimplContext -> Bool
-performDefaulting SimplInfer = False
-performDefaulting SimplRuleLhs = False
-performDefaulting SimplInteractive = True
-performDefaulting SimplCheck = True
+performDefaulting (SimplInfer {}) = False
+performDefaulting (SimplRuleLhs {}) = False
+performDefaulting SimplInteractive = True
+performDefaulting (SimplCheck {}) = True
---------------
newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
@@ -510,12 +553,14 @@ runTcS context untouch tcs
= do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; step_count <- TcM.newTcRef 0
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
, tcs_context = context
, tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet
, tcs_count = step_count
, tcs_ic_depth = 0
+ , tcs_flat_map = flat_cache_var
}
-- Run the computation
@@ -526,7 +571,9 @@ runTcS context untouch tcs
#ifdef DEBUG
; count <- TcM.readTcRef step_count
- ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count)
+ ; when (opt_PprStyle_Debug && count > 0) $
+ TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =")
+ <+> int count <+> ppr context)
#endif
-- And return
; ev_binds <- TcM.readTcRef evb_ref
@@ -540,21 +587,31 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
, tcs_untch = (_outer_range, outer_tcs)
, tcs_count = count
, tcs_ic_depth = idepth
- , tcs_context = ctxt } ->
- let
- inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+ , tcs_context = ctxt
+ , tcs_flat_map = orig_flat_cache_var
+ } ->
+ do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
-- The inner_range should be narrower than the outer one
-- (thus increasing the set of untouchables) but
-- the inner Tcs-untouchables must be unioned with the
-- outer ones!
- nest_env = TcSEnv { tcs_ev_binds = ref
- , tcs_ty_binds = ty_binds
- , tcs_untch = inner_untch
- , tcs_count = count
- , tcs_ic_depth = idepth+1
- , tcs_context = ctxtUnderImplic ctxt }
- in
- thing_inside nest_env
+
+ ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+ ; flat_cache_var <- TcM.newTcRef orig_flat_cache
+ -- One could be more conservative as well:
+ -- ; flat_cache_var <- TcM.newTcRef emptyFlatCache
+
+ -- Consider copying the results the tcs_flat_map of the
+ -- incomping constraint, but we must make sure that we
+ -- have pushed everything in, which seems somewhat fragile
+ ; let nest_env = TcSEnv { tcs_ev_binds = ref
+ , tcs_ty_binds = ty_binds
+ , tcs_untch = inner_untch
+ , tcs_count = count
+ , tcs_ic_depth = idepth+1
+ , tcs_context = ctxtUnderImplic ctxt
+ , tcs_flat_map = flat_cache_var }
+ ; thing_inside nest_env }
recoverTcS :: TcS a -> TcS a -> TcS a
recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -563,18 +620,21 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
ctxtUnderImplic :: SimplContext -> SimplContext
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
-ctxtUnderImplic SimplRuleLhs = SimplCheck
-ctxtUnderImplic ctxt = ctxt
+ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule")
+ <+> doubleQuotes (ftext n))
+ctxtUnderImplic ctxt = ctxt
tryTcS :: TcS a -> TcS a
--- Like runTcS, but from within the TcS monad
+-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs
+tryTcS tcs
= TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env1 = env { tcs_ev_binds = ev_binds_var
- , tcs_ty_binds = ty_binds_var }
- ; unTcS tcs env1 })
+ , tcs_ty_binds = ty_binds_var
+ , tcs_flat_map = flat_cache_var }
+ ; unTcS tcs env1 })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -597,12 +657,51 @@ getTcSTyBinds = TcS (return . tcs_ty_binds)
getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+ = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor
+ -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+ Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+ other -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+ -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+ = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; let new_cache_map
+ | isGivenOrSolved fl
+ = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ givenFlatCache cache_map }
+ | isWanted fl
+ = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ wantedFlatCache cache_map }
+ | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+ ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
; wrapTcS $ TcM.readTcRef ev_ref }
+
setCoBind :: CoVar -> Coercion -> TcS ()
setCoBind cv co = setEvBind cv (EvCoercion co)
@@ -672,7 +771,7 @@ checkWellStagedDFun pred dfun_id loc
bind_lvl = TcM.topIdLvl dfun_id
pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
+pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2)
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
isTouchableMetaTyVar tv
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index eecfb279c04e8b4b339f2b68e6f5e1ac071d2558..bed09325acde46c7fa3d695f4a4bfb732ca49a07 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1,7 +1,7 @@
\begin{code}
module TcSimplify(
simplifyInfer,
- simplifyDefault, simplifyDeriv,
+ simplifyDefault, simplifyDeriv,
simplifyRule, simplifyTop, simplifyInteractive
) where
@@ -15,10 +15,12 @@ import TcType
import TcSMonad
import TcInteract
import Inst
-import Unify( niFixTvSubst, niSubstTvSet )
+import Id ( evVarPred )
+import Unify ( niFixTvSubst, niSubstTvSet )
import Var
import VarSet
import VarEnv
+import Coercion
import TypeRep
import Name
@@ -49,7 +51,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
-- but when there is nothing to quantify we don't wrap
-- in a degenerate implication, so we do that here instead
simplifyTop wanteds
- = simplifyCheck SimplCheck wanteds
+ = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds
------------------
simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
@@ -61,7 +63,8 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it
-> TcM () -- Succeeds iff the constraint is soluble
simplifyDefault theta
= do { wanted <- newFlatWanteds DefaultOrigin theta
- ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted)
+ ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults")))
+ (mkFlatWC wanted)
; return () }
\end{code}
@@ -75,13 +78,14 @@ simplifyDefault theta
\begin{code}
simplifyDeriv :: CtOrigin
- -> [TyVar]
- -> ThetaType -- Wanted
- -> TcM ThetaType -- Needed
+ -> PredType
+ -> [TyVar]
+ -> ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
-- Given instance (wanted) => C inst_ty
-- Simplify 'wanted' as much as possibles
-- Fail if not possible
-simplifyDeriv orig tvs theta
+simplifyDeriv orig pred tvs theta
= do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize
-- The constraint solving machinery
-- expects *TcTyVars* not TyVars.
@@ -90,12 +94,13 @@ simplifyDeriv orig tvs theta
; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs
+ doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred)
; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
; (residual_wanted, _binds)
- <- runTcS SimplInfer NoUntouchables $
+ <- runTcS (SimplInfer doc) NoUntouchables $
solveWanteds emptyInert (mkFlatWC wanted)
; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
@@ -247,7 +252,7 @@ simplifyInfer top_lvl apply_mr name_taus wanteds
-- Step 2
-- Now simplify the possibly-bound constraints
; (simpl_results, tc_binds0)
- <- runTcS SimplInfer NoUntouchables $
+ <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $
simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound })
; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint
@@ -547,7 +552,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- variables; hence *no untouchables*
; (lhs_results, lhs_binds)
- <- runTcS SimplRuleLhs untch $
+ <- runTcS (SimplRuleLhs name) untch $
solveWanteds emptyInert zonked_lhs
; traceTc "simplifyRule" $
@@ -589,7 +594,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- Hence the rather painful ad-hoc treatement here
; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds
- ; rhs_binds1 <- simplifyCheck SimplCheck $
+ ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name)
+ ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $
WC { wc_flat = emptyBag
, wc_insol = emptyBag
, wc_impl = unitBag $
@@ -743,22 +749,26 @@ solve_wanteds inert wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol =
unsolved_implics
}
-givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar
--- Extract the *wanted* ones from CanonicalCts
--- and make them into *givens*
-givensFromWanteds = foldrBag getWanted emptyBag
+givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
+-- Extract the Wanted ones from CanonicalCts and conver to
+-- Givens; not Given/Solved, see Note [Preparing inert set for implications]
+givensFromWanteds _ctxt = foldrBag getWanted emptyBag
where
getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
getWanted cc givens
- | not (isCFrozenErr cc)
- , Wanted loc <- cc_flavor cc
- , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol))
- = given `consBag` givens
- | otherwise
- = givens -- We are not helping anyone by pushing a Derived in!
- -- Because if we could not solve it to start with
- -- we are not going to do either inside the impl constraint
-
+ | pushable_wanted cc
+ = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
+ in given `consBag` givens -- and not mkSolvedFlavor,
+ -- see Note [Preparing inert set for implications]
+ | otherwise = givens
+
+ pushable_wanted :: CanonicalCt -> Bool
+ pushable_wanted cc
+ | not (isCFrozenErr cc)
+ , isWantedCt cc
+ = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+ | otherwise = False
+
solveNestedImplications :: InertSet -> CanonicalCts
-> Bag Implication
-> TcS (Bag FlavoredEvVar, Bag Implication)
@@ -768,15 +778,18 @@ solveNestedImplications just_given_inert unsolved_cans implics
| otherwise
= do { -- See Note [Preparing inert set for implications]
-- Push the unsolved wanteds inwards, but as givens
- let pushed_givens = givensFromWanteds unsolved_cans
+
+ ; simpl_ctx <- getTcSContext
+
+ ; let pushed_givens = givensFromWanteds simpl_ctx unsolved_cans
tcs_untouchables = filterVarSet isFlexiTcsTv $
tyVarsOfEvVarXs pushed_givens
-- See Note [Extra TcsTv untouchables]
; traceTcS "solveWanteds: preparing inerts for implications {"
(vcat [ppr tcs_untouchables, ppr pushed_givens])
-
- ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
+
+ ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
; traceTcS "solveWanteds: } now doing nested implications {" $
vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
@@ -927,6 +940,42 @@ We were not able to solve (a ~w [beta]) but we can't just assume it as
given because the resulting set is not inert. Hence we have to do a
'solveInteract' step first.
+Finally, note that we convert them to [Given] and NOT [Given/Solved].
+The reason is that Given/Solved are weaker than Givens and may be discarded.
+As an example consider the inference case, where we may have, the following
+original constraints:
+ [Wanted] F Int ~ Int
+ (F Int ~ a => F Int ~ a)
+If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next
+given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting
+the (F Int ~ a) insoluble. Hence we should really convert the residual
+wanteds to plain old Given.
+
+We need only push in unsolved equalities both in checking mode and inference mode:
+
+ (1) In checking mode we should not push given dictionaries in because of
+example LongWayOverlapping.hs, where we might get strange overlap
+errors between far-away constraints in the program. But even in
+checking mode, we must still push type family equations. Consider:
+
+ type instance F True a b = a
+ type instance F False a b = b
+
+ [w] F c a b ~ gamma
+ (c ~ True) => a ~ gamma
+ (c ~ False) => b ~ gamma
+
+Since solveCTyFunEqs happens at the very end of solving, the only way to solve
+the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not
+merely Given/Solved because it has to interact with the top-level instance
+environment) and push it inside the implications. Now, when we come out again at
+the end, having solved the implications solveCTyFunEqs will solve this equality.
+
+ (2) In inference mode, we recheck the final constraint in checking mode and
+hence we will be able to solve inner implications from top-level quantified
+constraints nonetheless.
+
+
Note [Extra TcsTv untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Furthemore, we record the inert set simplifier-generated unification
@@ -982,7 +1031,8 @@ solveCTyFunEqs cts
; return (niFixTvSubst ni_subst, unsolved_can_cts) }
where
- solve_one (cv,tv,ty) = setWantedTyBind tv ty >> setCoBind cv ty
+ solve_one (cv,tv,ty) = do { setWantedTyBind tv ty
+ ; setCoBind cv (mkReflCo ty) }
------------
type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)])
@@ -1025,7 +1075,7 @@ getSolvableCTyFunEqs untch cts
, not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
-- Occurs check: see Note [Solving Family Equations], Point 2
- = ASSERT ( not (isGiven fl) )
+ = ASSERT ( not (isGivenOrSolved fl) )
(cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
dflt_funeq (cts_in, fun_eq_binds) ct
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f68239ee26e8e267af6f222d3ad3d74df4b98b54..3cc2eb5570d0b9007162f9a99cd3334a7d649521 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -71,6 +71,7 @@ import SrcLoc
import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
@@ -1066,8 +1067,9 @@ reifyThing (AGlobal (AnId id))
_ -> return (TH.VarI v ty Nothing fix)
}
-reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls)) = reifyClass cls
reifyThing (AGlobal (ADataCon dc))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
@@ -1091,12 +1093,24 @@ reifyThing (ATyVar tv ty)
reifyThing (AThing {}) = panic "reifyThing AThing"
------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = do { args' <- mapM reifyType args
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+ | otherwise
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
| isFunTyCon tc
= return (TH.PrimTyConI (reifyName tc) 2 False)
+
| isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+
| isFamilyTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
@@ -1107,6 +1121,7 @@ reifyTyCon tc
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
@@ -1114,7 +1129,7 @@ reifyTyCon tc
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
}
-reifyTyCon tc
+ | otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
@@ -1189,7 +1204,7 @@ reifyClassInstance i
reifyType :: TypeRep.Type -> TcM TH.Type
-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a433d697b9d8d5667899e15968f32ae517134833..8d62b785801339489dd185dbc85cc00a19a639a0 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -7,7 +7,8 @@ TcTyClsDecls: Typecheck type and class declarations
\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
+ tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
+ checkValidTyCon, dataDeclChecks, badFamInstDecl
) where
#include "HsVersions.h"
@@ -25,17 +26,16 @@ import TcMType
import TcType
import TysWiredIn ( unitTy )
import Type
-import Generics
import Class
import TyCon
import DataCon
import Id
-import MkId ( mkDefaultMethodId )
import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Name
+import NameEnv
import Outputable
import Maybes
import Unify
@@ -61,12 +61,12 @@ import Data.List
%************************************************************************
\begin{code}
+
tcTyAndClassDecls :: ModDetails
-> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
- HsValBinds Name, -- Renamed bindings for record selectors
- [Id]) -- Default method ids
+ HsValBinds Name) -- Renamed bindings for record selectors
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
@@ -89,7 +89,7 @@ tcTyAndClassDecls boot_details decls_s
-- And now build the TyCons/Classes
; let rec_flags = calcRecFlags boot_details rec_tyclss
- ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+ ; concatMapM (tcTyClDecl rec_flags) kc_decls }
; tcExtendGlobalEnv tyclss $ do
{ -- Perform the validity check
@@ -105,11 +105,13 @@ tcTyAndClassDecls boot_details decls_s
-- second time here. This doesn't matter as the definitions are
-- the same.
; let { implicit_things = concatMap implicitTyThings tyclss
- ; rec_sel_binds = mkRecSelBinds tyclss
+ ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss]
; dm_ids = mkDefaultMethodIds tyclss }
- ; env <- tcExtendGlobalEnv implicit_things getGblEnv
- ; return (env, rec_sel_binds, dm_ids) } }
+ ; env <- tcExtendGlobalEnv implicit_things $
+ tcExtendGlobalValEnv dm_ids $
+ getGblEnv
+ ; return (env, rec_sel_binds) } }
zipRecTyClss :: [[LTyClDecl Name]]
-> [TyThing] -- Knot-tied
@@ -135,188 +137,6 @@ zipRecTyClss decls_s rec_things
\end{code}
-%************************************************************************
-%* *
- Type checking family instances
-%* *
-%************************************************************************
-
-Family instances are somewhat of a hybrid. They are processed together with
-class instance heads, but can contain data constructors and hence they share a
-lot of kinding and type checking code with ordinary algebraic data types (and
-GADTs).
-
-\begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
-tcFamInstDecl top_lvl (L loc decl)
- = -- Prime error recovery, set source location
- setSrcSpan loc $
- tcAddDeclCtxt decl $
- do { -- type family instances require -XTypeFamilies
- -- and can't (currently) be in an hs-boot file
- ; type_families <- xoptM Opt_TypeFamilies
- ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; checkTc type_families $ badFamInstDecl (tcdLName decl)
- ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
- -- Perform kind and type checking
- ; tc <- tcFamInstDecl1 decl
- ; checkValidTyCon tc -- Remember to check validity;
- -- no recursion to worry about here
-
- -- Check that toplevel type instances are not for associated types.
- ; when (isTopLevel top_lvl && isAssocFamily tc)
- (addErr $ assocInClassErr (tcdName decl))
-
- ; return (ATyCon tc) }
-
-isAssocFamily :: TyCon -> Bool -- Is an assocaited type
-isAssocFamily tycon
- = case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name
- = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
- ptext (sLit "must be inside a class instance")
-
-
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
-
- -- "type instance"
-tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
- do { -- check that the family declaration is for a synonym
- checkTc (isFamilyTyCon family) (notFamily family)
- ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
-
- ; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
- -- ToDo: the ExpKind could be better
-
- -- we need the exact same number of type parameters as the family
- -- declaration
- ; let famArity = tyConArity family
- ; checkTc (length k_typats == famArity) $
- wrongNumberOfParmsErr famArity
-
- -- (2) type check type equation
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; t_typats <- mapM tcHsKindedType k_typats
- ; t_rhs <- tcHsKindedType k_rhs
-
- -- (3) check the well-formedness of the instance
- ; checkValidTypeInst t_typats t_rhs
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (typeKind t_rhs)
- NoParentTyCon (Just (family, t_typats))
- }}
-
- -- "newtype instance" and "data instance"
-tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
- tcdCons = cons})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
- do { -- check that the family declaration is for the right kind
- checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
- ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
-
- ; -- (1) kind check the data declaration as usual
- ; k_decl <- kcDataDecl decl k_tvs
- ; let k_ctxt = tcdCtxt k_decl
- k_cons = tcdCons k_decl
-
- -- result kind must be '*' (otherwise, we have too few patterns)
- ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
-
- -- (2) type check indexed data type declaration
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; unbox_strict <- doptM Opt_UnboxStrictFields
-
- -- kind check the type indexes and the context
- ; t_typats <- mapM tcHsKindedType k_typats
- ; stupid_theta <- tcHsKindedContext k_ctxt
-
- -- (3) Check that
- -- (a) left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though, and we checked for
- -- foralls earlier)
- ; mapM_ checkTyFamFreeness t_typats
-
- -- Check that we don't use GADT syntax in H98 world
- ; gadt_ok <- xoptM Opt_GADTs
- ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-
- -- (b) a newtype has exactly one constructor
- ; checkTc (new_or_data == DataType || isSingleton k_cons) $
- newtypeConError tc_name (length k_cons)
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; let ex_ok = True -- Existentials ok for type families!
- ; fixM (\ rep_tycon -> do
- { let orig_res_ty = mkTyConApp fam_tycon t_typats
- ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
- (t_tvs, orig_res_ty) k_cons
- ; tc_rhs <-
- case new_or_data of
- DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
- mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
- ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
- -- We always assume that indexed types are recursive. Why?
- -- (1) Due to their open nature, we can never be sure that a
- -- further instance might not introduce a new recursive
- -- dependency. (2) They are always valid loop breakers as
- -- they involve a coercion.
- })
- }}
- where
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
-
-tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
-
--- Kind checking of indexed types
--- -
-
--- Kind check type patterns and kind annotate the embedded type variables.
---
--- * Here we check that a type instance matches its kind signature, but we do
--- not check whether there is a pattern for each type index; the latter
--- check is only required for type synonym instances.
-
-kcIdxTyPats :: TyClDecl Name
- -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
- -- ^^kinded tvs ^^kinded ty pats ^^res kind
- -> TcM a
-kcIdxTyPats decl thing_inside
- = kcHsTyVars (tcdTyVars decl) $ \tvs ->
- do { let tc_name = tcdLName decl
- ; fam_tycon <- tcLookupLocatedTyCon tc_name
- ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
- ; hs_typats = fromJust $ tcdTyPats decl }
-
- -- we may not have more parameters than the kind indicates
- ; checkTc (length kinds >= length hs_typats) $
- tooManyParmsErr (tcdLName decl)
-
- -- type functions can have a higher-kinded result
- ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckLHsType hs_typats
- [ EK kind (EkArg (ppr tc_name) n)
- | (kind,n) <- kinds `zip` [1..]]
- ; thing_inside tvs typats resultKind fam_tycon
- }
-\end{code}
-
-
%************************************************************************
%* *
Kind checking
@@ -488,6 +308,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
where
kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
; return (TypeSig nm op_ty') }
+ kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+ ; return (GenericSig nm op_ty') }
kc_sig other_sig = return other_sig
kcTyClDecl decl@(ForeignType {})
@@ -634,7 +456,7 @@ tcTyClDecl1 parent _calc_isrec
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
- DataFamilyTyCon Recursive False True
+ DataFamilyTyCon Recursive True
parent Nothing
; return [ATyCon tycon]
}
@@ -660,36 +482,18 @@ tcTyClDecl1 _parent calc_isrec
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- xoptM Opt_EmptyDataDecls
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
- ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
- -- Check that we don't use GADT syntax in H98 world
- ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
- -- Check that the stupid theta is empty for a GADT-style declaration
- ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
-
- -- Check that a newtype has exactly one constructor
- -- Do this before checking for empty data decls, so that
- -- we don't suggest -XEmptyDataDecls for newtypes
- ; checkTc (new_or_data == DataType || isSingleton cons)
- (newtypeConError tc_name (length cons))
+ ; dataDeclChecks tc_name new_or_data stupid_theta cons
- -- Check that there's at least one condecl,
- -- or else we're reading an hs-boot file, or -XEmptyDataDecls
- ; checkTc (not (null cons) || empty_data_decls || is_boot)
- (emptyConDeclsErr tc_name)
-
; tycon <- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls unbox_strict ex_ok
@@ -702,8 +506,7 @@ tcTyClDecl1 _parent calc_isrec
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
- (want_generic && canDoGenerics data_cons) (not h98_syntax)
- NoParentTyCon Nothing
+ (not h98_syntax) NoParentTyCon Nothing
})
; return [ATyCon tycon]
}
@@ -719,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
- ; sig_stuff <- tcClassSigs class_name sigs meths
+ ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; clas <- fixM $ \ clas -> do
{ let -- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
@@ -732,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec
; buildClass False {- Must include unfoldings for selectors -}
class_name tvs' ctxt' fds' (concat atss')
sig_stuff tc_isrec }
- ; return (AClass clas : map ATyCon (classATs clas))
+
+ ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+ | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+ , let gen_dm_tau = expectJust "tcTyClDecl1" $
+ lookupNameEnv gen_dm_env (idName sel_id)
+ , let gen_dm_ty = mkSigmaTy tvs'
+ [mkClassPred clas (mkTyVarTys tvs')]
+ gen_dm_tau
+ ]
+ class_ats = map ATyCon (classATs clas)
+
+ ; return (AClass clas : gen_dm_ids ++ class_ats )
-- NB: Order is important due to the call to `mkGlobalThings' when
-- tying the the type and class declaration type checking knot.
}
@@ -747,6 +561,29 @@ tcTyClDecl1 _ _
tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
+dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
+dataDeclChecks tc_name new_or_data stupid_theta cons
+ = do { -- Check that we don't use GADT syntax in H98 world
+ gadtSyntax_ok <- xoptM Opt_GADTSyntax
+ ; let h98_syntax = consUseH98Syntax cons
+ ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
+
+ -- Check that the stupid theta is empty for a GADT-style declaration
+ ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
+
+ -- Check that a newtype has exactly one constructor
+ -- Do this before checking for empty data decls, so that
+ -- we don't suggest -XEmptyDataDecls for newtypes
+ ; checkTc (new_or_data == DataType || isSingleton cons)
+ (newtypeConError tc_name (length cons))
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+ ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; checkTc (not (null cons) || empty_data_decls || is_boot)
+ (emptyConDeclsErr tc_name) }
+
-----------------------------------
tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
@@ -974,6 +811,8 @@ checkValidTyCl decl
ATyCon tc -> checkValidTyCon tc
AClass cl -> do { checkValidClass cl
; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+ AnId _ -> return () -- Generic default methods are checked
+ -- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
@@ -1099,14 +938,14 @@ checkNewDataCon con
-- One argument
; checkTc (null eq_spec) (newtypePredError con)
-- Return type is (T a b c)
- ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
+ ; checkTc (null ex_tvs && null theta) (newtypeExError con)
-- No existentials
; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
-- No strictness
}
where
- (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
+ (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
-------------------------------
checkValidClass :: Class -> TcM ()
@@ -1134,7 +973,7 @@ checkValidClass cls
where
(tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
- no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+ no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
@@ -1155,10 +994,10 @@ checkValidClass cls
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
- -- Check that for a generic method, the type of
- -- the method is sufficiently simple
- ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
- (badGenericMethodType op_name op_ty)
+ ; case dm of
+ GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+ ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+ _ -> return ()
}
where
op_name = idName sel_id
@@ -1186,7 +1025,7 @@ checkValidClass cls
mkDefaultMethodIds :: [TyThing] -> [Id]
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds things
- = [ mkDefaultMethodId sel_id dm_name
+ = [ mkExportedLocalId dm_name (idType sel_id)
| AClass cls <- things
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
\end{code}
@@ -1208,16 +1047,16 @@ must bring the default method Ids into scope first (so they can be seen
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyCon] -> HsValBinds Name
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
-mkRecSelBinds ty_things
+mkRecSelBinds tycons
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
- | ATyCon tc <- ty_things
+ | tc <- tycons
, fld <- tyConFields tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
@@ -1424,12 +1263,6 @@ genericMultiParamErr clas
= ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
ptext (sLit "cannot have generic methods")
-badGenericMethodType :: Name -> Kind -> SDoc
-badGenericMethodType op op_ty
- = hang (ptext (sLit "Generic method type is too complex"))
- 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
- ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
-
recSynErr :: [LTyClDecl Name] -> TcRn ()
recSynErr syn_decls
= setSrcSpan (getLoc (head sorted_decls)) $
@@ -1511,39 +1344,6 @@ badFamInstDecl tc_name
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
-tooManyParmsErr :: Located Name -> SDoc
-tooManyParmsErr tc_name
- = ptext (sLit "Family instance has too many parameters:") <+>
- quotes (ppr tc_name)
-
-tooFewParmsErr :: Arity -> SDoc
-tooFewParmsErr arity
- = ptext (sLit "Family instance has too few parameters; expected") <+>
- ppr arity
-
-wrongNumberOfParmsErr :: Arity -> SDoc
-wrongNumberOfParmsErr exp_arity
- = ptext (sLit "Number of parameters must match family declaration; expected")
- <+> ppr exp_arity
-
-badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr
- = ptext (sLit "Illegal family instance in hs-boot file")
-
-notFamily :: TyCon -> SDoc
-notFamily tycon
- = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
- , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
-
-wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family
- = ptext (sLit "Wrong category of family instance; declaration was for a")
- <+> kindOfFamily
- where
- kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
- | isAlgTyCon family = ptext (sLit "data type")
- | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
-
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index a9ea11aefa19ab6158959342eabfffdd92f90318..15c817a65780e26d6303d777fe279ecda1e01458 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -30,7 +30,7 @@ import NameSet
import Digraph
import BasicTypes
import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Data.List
\end{code}
@@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss
nt_loop_breakers `unionNameSets`
prod_loop_breakers
- all_tycons = [ tc | tycls <- tyclss,
+ all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
- let tc = getTyCon tycls,
- not (tyConName tc `elemNameSet` boot_name_set) ]
+ , not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
@@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _ = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _ = Nothing
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
@@ -356,8 +355,8 @@ tcTyConsOfType ty
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
+ go (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2
go (ForAllTy _ ty) = go ty
- go _ = panic "tcTyConsOfType"
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index eab07326b1e615cd3a04b1c9c5d4ac540468c337..a825d23b04771b65af95af0384aa0ea399571846 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -19,7 +19,7 @@ module TcType (
--------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
- TcTyVar, TcTyVarSet, TcKind, TcCoVar,
+ TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
--------------------------------
-- MetaDetails
@@ -50,7 +50,7 @@ module TcType (
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
- tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
+ eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
eqKind,
isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
@@ -61,18 +61,11 @@ module TcType (
---------------------------------
-- Misc type manipulators
deNoteType,
- orphNamesOfType, orphNamesOfDFunHead,
+ orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
getDFunTyKey,
---------------------------------
-- Predicate types
- getClassPredTys_maybe, getClassPredTys,
- isClassPred, isTyVarClassPred, isEqPred,
- mkClassPred, mkIPPred, tcSplitPredTy_maybe,
- mkDictTy, evVarPred,
- isPredTy, isDictTy, isDictLikeTy,
- tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- isIPPred,
mkMinimalBySCs, transSuperClasses, immSuperClasses,
-- * Tidying type related things up for printing
@@ -81,7 +74,8 @@ module TcType (
tidyTyVarBndr, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTopType, tidyPred,
- tidyKind,
+ tidyKind,
+ tidyCo, tidyCos,
---------------------------------
-- Foreign import and export
@@ -101,32 +95,38 @@ module TcType (
tcSplitIOType_maybe, -- :: Type -> Maybe Type
--------------------------------
- -- Rexported from Coercion
- typeKind,
-
- --------------------------------
- -- Rexported from Type
- Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
+ -- Rexported from Kind
+ Kind, typeKind,
unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
kindVarRef, mkKindVar,
- Type, PredType(..), ThetaType,
+ --------------------------------
+ -- Rexported from Type
+ Type, Pred(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+ getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred, isEqPred,
+ mkClassPred, mkIPPred, splitPredTy_maybe,
+ mkDictTy, isPredTy, isDictTy, isDictLikeTy,
+ tcSplitDFunTy, tcSplitDFunHead,
+ isIPPred, mkEqPred,
+
-- Type substitutions
TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst, substEqSpec,
+ TvSubstEnv, emptyTvSubst,
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst,
mkTopTvSubst, notElemTvSubst, unionTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
- extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
+ extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
+ Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
@@ -138,13 +138,14 @@ module TcType (
pprKind, pprParendKind,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
+ pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred
) where
#include "HsVersions.h"
-- friends:
+import Kind
import TypeRep
import Class
import Var
@@ -156,7 +157,7 @@ import TyCon
-- others:
import DynFlags
-import Name
+import Name hiding (varName)
import NameSet
import VarEnv
import PrelNames
@@ -216,6 +217,8 @@ type TcType = Type -- A TcType can have mutable type variables
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
+type TcCoercion = Coercion -- A TcCoercion can contain TcTypes.
+
-- These types do not have boxy type variables in them
type TcPredType = PredType
type TcThetaType = ThetaType
@@ -262,7 +265,7 @@ the same type variable in both type signatures. But that takes explanation.
The alternative (currently implemented) is to have a special kind of skolem
constant, SigTv, which can unify with other SigTvs. These are *not* treated
-as righd for the purposes of GADTs. And they are used *only* for pattern
+as rigid for the purposes of GADTs. And they are used *only* for pattern
bindings and mutually recursive function bindings. See the function
TcBinds.tcInstSig, and its use_skols parameter.
@@ -306,14 +309,12 @@ data MetaInfo
-- A TauTv is always filled in with a tau-type, which
-- never contains any ForAlls
- | SigTv Name -- A variant of TauTv, except that it should not be
+ | SigTv -- A variant of TauTv, except that it should not be
-- unified with a type, only with a type variable
-- SigTvs are only distinguished to improve error messages
-- see Note [Signature skolems]
-- The MetaDetails, if filled in, will
-- always be another SigTv or a SkolemTv
- -- The Name is the name of the function from whose
- -- type signature we got this skolem
| TcsTv -- A MetaTv allocated by the constraint solver
-- Its particular property is that it is always "touchable"
@@ -392,12 +393,12 @@ kind_var_occ = mkOccName tvName "k"
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
-pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
-pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
-pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
-pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
-pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
-pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
+pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
+pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
+pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
+pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n)
@@ -428,19 +429,13 @@ pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context")
--
-- It doesn't change the uniques at all, just the print names.
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr env@(tidy_env, subst) tyvar
+tidyTyVarBndr (tidy_env, subst) tyvar
= case tidyOccName tidy_env occ1 of
- (tidy', occ') -> ((tidy', subst'), tyvar'')
+ (tidy', occ') -> ((tidy', subst'), tyvar')
where
- subst' = extendVarEnv subst tyvar tyvar''
+ subst' = extendVarEnv subst tyvar tyvar'
tyvar' = setTyVarName tyvar name'
-
- name' = tidyNameOcc name occ'
-
- -- Don't forget to tidy the kind for coercions!
- tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
- | otherwise = tyvar'
- kind' = tidyType env (tyVarKind tyvar)
+ name' = tidyNameOcc name occ'
where
name = tyVarName tyvar
occ = getOccName name
@@ -529,6 +524,40 @@ tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
tidyKind env k = tidyOpenType env k
\end{code}
+%************************************************************************
+%* *
+ Tidying coercions
+%* *
+%************************************************************************
+
+\begin{code}
+
+tidyCo :: TidyEnv -> Coercion -> Coercion
+tidyCo env@(_, subst) co
+ = go co
+ where
+ go (Refl ty) = Refl (tidyType env ty)
+ go (TyConAppCo tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo tc args
+ go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
+ go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co)
+ where
+ (envp, tvp) = tidyTyVarBndr env tv
+ go (CoVarCo cv) = case lookupVarEnv subst cv of
+ Nothing -> CoVarCo cv
+ Just cv' -> CoVarCo cv'
+ go (AxiomInstCo con cos) = let args = tidyCos env cos
+ in args `seqList` AxiomInstCo con args
+ go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
+ go (SymCo co) = SymCo $! go co
+ go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
+ go (NthCo d co) = NthCo d $! go co
+ go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty
+
+tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
+tidyCos env = map (tidyCo env)
+
+\end{code}
%************************************************************************
%* *
@@ -552,8 +581,8 @@ isTyConableTyVar tv
-- not a SigTv
= ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> False
- _ -> True
+ MetaTv SigTv _ -> False
+ _ -> True
isSkolemTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
@@ -583,8 +612,8 @@ isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> True
- _ -> False
+ MetaTv SigTv _ -> True
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
@@ -672,22 +701,19 @@ tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split _ (ForAllTy tv ty) tvs
- | not (isCoVar tv) = split ty ty (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
tcIsForAllTy :: Type -> Bool
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
-tcIsForAllTy _ = False
+tcIsForAllTy (ForAllTy {}) = True
+tcIsForAllTy _ = False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
-tcSplitPredFunTy_maybe (ForAllTy tv ty)
- | isCoVar tv = Just (coVarPred tv, ty)
tcSplitPredFunTy_maybe (FunTy arg res)
- | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+ | Just p <- splitPredTy_maybe arg = Just (p, res)
tcSplitPredFunTy_maybe _
= Nothing
@@ -837,13 +863,12 @@ tcSplitDFunTy ty
-- coercion and class constraints; or (in the general NDP case)
-- some other function argument
split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
- split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty
split_dfun_args n ty = (n, ty)
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead tau
- = case tcSplitPredTy_maybe tau of
+ = case splitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
_ -> pprPanic "tcSplitDFunHead" (ppr tau)
@@ -886,60 +911,6 @@ tcInstHeadTyAppAllTyVars ty
%* *
%************************************************************************
-\begin{code}
-evVarPred :: EvVar -> PredType
-evVarPred var
- = case tcSplitPredTy_maybe (varType var) of
- Just pred -> pred
- Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
-
-tcSplitPredTy_maybe :: Type -> Maybe PredType
- -- Returns Just for predicates only
-tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
-tcSplitPredTy_maybe (PredTy p) = Just p
-tcSplitPredTy_maybe _ = Nothing
-
-predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _) = getUnique (ipNameName n)
-predTyUnique (ClassP clas _) = getUnique clas
-predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
-\end{code}
-
-
---------------------- Dictionary types ---------------------------------
-
-\begin{code}
-mkClassPred :: Class -> [Type] -> PredType
-mkClassPred clas tys = ClassP clas tys
-
-isClassPred :: PredType -> Bool
-isClassPred (ClassP _ _) = True
-isClassPred _ = False
-
-isTyVarClassPred :: PredType -> Bool
-isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys
-isTyVarClassPred _ = False
-
-getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
-getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
-getClassPredTys_maybe _ = Nothing
-
-getClassPredTys :: PredType -> (Class, [Type])
-getClassPredTys (ClassP clas tys) = (clas, tys)
-getClassPredTys _ = panic "getClassPredTys"
-
-mkDictTy :: Class -> [Type] -> Type
-mkDictTy clas tys = mkPredTy (ClassP clas tys)
-
-isDictLikeTy :: Type -> Bool
--- Note [Dictionary-like types]
-isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
-isDictLikeTy (PredTy p) = isClassPred p
-isDictLikeTy (TyConApp tc tys)
- | isTupleTyCon tc = all isDictLikeTy tys
-isDictLikeTy _ = False
-\end{code}
-
Superclasses
\begin{code}
@@ -949,7 +920,7 @@ mkMinimalBySCs ptys = [ ploc | ploc <- ptys
, ploc `not_in_preds` rec_scs ]
where
rec_scs = concatMap trans_super_classes ptys
- not_in_preds p ps = null (filter (tcEqPred p) ps)
+ not_in_preds p ps = null (filter (eqPred p) ps)
trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
trans_super_classes _other_pty = []
@@ -969,53 +940,6 @@ immSuperClasses cls tys
where (tyvars,sc_theta,_,_) = classBigSig cls
\end{code}
-Note [Dictionary-like types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Being "dictionary-like" means either a dictionary type or a tuple thereof.
-In GHC 6.10 we build implication constraints which construct such tuples,
-and if we land up with a binding
- t :: (C [a], Eq [a])
- t = blah
-then we want to treat t as cheap under "-fdicts-cheap" for example.
-(Implication constraints are normally inlined, but sadly not if the
-occurrence is itself inside an INLINE function! Until we revise the
-handling of implication constraints, that is.) This turned out to
-be important in getting good arities in DPH code. Example:
-
- class C a
- class D a where { foo :: a -> a }
- instance C a => D (Maybe a) where { foo x = x }
-
- bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
- {-# INLINE bar #-}
- bar x y = (foo (Just x), foo (Just y))
-
-Then 'bar' should jolly well have arity 4 (two dicts, two args), but
-we ended up with something like
- bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
- in \x,y. <blah>)
-
-This is all a bit ad-hoc; eg it relies on knowing that implication
-constraints build tuples.
-
---------------------- Implicit parameters ---------------------------------
-
-\begin{code}
-mkIPPred :: IPName Name -> Type -> PredType
-mkIPPred ip ty = IParam ip ty
-
-isIPPred :: PredType -> Bool
-isIPPred (IParam _ _) = True
-isIPPred _ = False
-\end{code}
-
---------------------- Equality predicates ---------------------------------
-\begin{code}
-substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
-substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
- | (tv,ty) <- eq_spec]
-\end{code}
-
%************************************************************************
%* *
@@ -1037,17 +961,10 @@ isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
-- Yes for a type of a function that might require evidence-passing
-- Used only by bindLocalMethods
--- NB: be sure to check for type with an equality predicate; hence isCoVar
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
-isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty
-isOverloadedTy (FunTy a _) = isPredTy a
-isOverloadedTy _ = False
-
-isPredTy :: Type -> Bool -- Belongs in TcType because it does
- -- not look through newtypes, or predtypes (of course)
-isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
-isPredTy (PredTy _) = True
-isPredTy _ = False
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a _) = isPredTy a
+isOverloadedTy _ = False
\end{code}
\begin{code}
@@ -1109,14 +1026,9 @@ tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys
tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
-tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar)
- `unionVarSet` tcTyVarsOfTyVar tyvar
+tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
-- We do sometimes quantify over skolem TcTyVars
-tcTyVarsOfTyVar :: TcTyVar -> TyVarSet
-tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv)
- | otherwise = emptyVarSet
-
tcTyVarsOfTypes :: [Type] -> TyVarSet
tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
@@ -1126,61 +1038,6 @@ tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
\end{code}
-Note [Silly type synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- type T a = Int
-What are the free tyvars of (T x)? Empty, of course!
-Here's the example that Ralf Laemmel showed me:
- foo :: (forall a. C u a -> C u a) -> u
- mappend :: Monoid u => u -> u -> u
-
- bar :: Monoid u => u
- bar = foo (\t -> t `mappend` t)
-We have to generalise at the arg to f, and we don't
-want to capture the constraint (Monad (C u a)) because
-it appears to mention a. Pretty silly, but it was useful to him.
-
-exactTyVarsOfType is used by the type checker to figure out exactly
-which type variables are mentioned in a type. It's also used in the
-smart-app checking code --- see TcExpr.tcIdApp
-
-On the other hand, consider a *top-level* definition
- f = (\x -> x) :: T a -> T a
-If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
-if we have an application like (f "x") we get a confusing error message
-involving Any. So the conclusion is this: when generalising
- - at top level use tyVarsOfType
- - in nested bindings use exactTyVarsOfType
-See Trac #1813 for example.
-
-\begin{code}
-exactTyVarsOfType :: TcType -> TyVarSet
--- Find the free type variables (of any kind)
--- but *expand* type synonyms. See Note [Silly type synonym] above.
-exactTyVarsOfType ty
- = go ty
- where
- go ty | Just ty' <- tcView ty = go ty' -- This is the key line
- go (TyVarTy tv) = unitVarSet tv
- go (TyConApp _ tys) = exactTyVarsOfTypes tys
- go (PredTy ty) = go_pred ty
- go (FunTy arg res) = go arg `unionVarSet` go res
- go (AppTy fun arg) = go fun `unionVarSet` go arg
- go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
- `unionVarSet` go_tv tyvar
-
- go_pred (IParam _ ty) = go ty
- go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
- go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
-
- go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar)
- | otherwise = emptyVarSet
-
-exactTyVarsOfTypes :: [TcType] -> TyVarSet
-exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
-\end{code}
-
Find the free tycons and classes of a type. This is used in the front
end of the compiler.
@@ -1213,6 +1070,26 @@ orphNamesOfDFunHead :: Type -> NameSet
orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
(_, _, head_ty) -> orphNamesOfType head_ty
+
+orphNamesOfCo :: Coercion -> NameSet
+orphNamesOfCo (Refl ty) = orphNamesOfType ty
+orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
+orphNamesOfCo (CoVarCo _) = emptyNameSet
+orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCo (SymCo co) = orphNamesOfCo co
+orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
+orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
+
+orphNamesOfCos :: [Coercion] -> NameSet
+orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
+
+orphNamesOfCoCon :: CoAxiom -> NameSet
+orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
+ = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
\end{code}
@@ -1227,7 +1104,7 @@ restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
-- (isIOType t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
@@ -1238,7 +1115,7 @@ tcSplitIOType_maybe ty
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
- -> Just (io_tycon, io_res_ty, IdCo ty)
+ -> Just (io_tycon, io_res_ty, mkReflCo ty)
Just (tc, tys)
| not (isRecursiveTyCon tc)
@@ -1246,7 +1123,7 @@ tcSplitIOType_maybe ty
-- Newtypes that require a coercion are ok
-> case tcSplitIOType_maybe ty of
Nothing -> Nothing
- Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
+ Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
_ -> Nothing
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 4fc50b33256e642b0331aad8a57854d9d44a0a8a..572ad4437cfd2489ad95f2a6f266c1b2fe54db80 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -20,7 +20,7 @@ module TcUnify (
matchExpectedListTy, matchExpectedPArrTy,
matchExpectedTyConApp, matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunKind,
- wrapFunResCoercion
+ wrapFunResCoercion, failWithMisMatch
) where
#include "HsVersions.h"
@@ -28,7 +28,7 @@ module TcUnify (
import HsSyn
import TypeRep
import CoreUtils( mkPiTypes )
-import TcErrors ( unifyCtxt )
+import TcErrors ( unifyCtxt )
import TcMType
import TcIface
import TcRnMonad
@@ -44,7 +44,6 @@ import VarEnv
import Name
import ErrUtils
import BasicTypes
-
import Maybes ( allMaybes )
import Util
import Outputable
@@ -103,7 +102,7 @@ expected type, becuase it expects that to have been done already
matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys]
-> Arity
-> TcRhoType
- -> TcM (CoercionI, [TcSigmaType], TcRhoType)
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
-- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r)
-- then co : ty ~ (t1 -> ... -> tn -> ty_r)
@@ -122,7 +121,7 @@ matchExpectedFunTys herald arity orig_ty
-- then co : ty ~ t1 -> .. -> tn -> ty_r
go n_req ty
- | n_req == 0 = return (IdCo ty, [], ty)
+ | n_req == 0 = return (mkReflCo ty, [], ty)
go n_req ty
| Just ty' <- tcView ty = go n_req ty'
@@ -130,7 +129,7 @@ matchExpectedFunTys herald arity orig_ty
go n_req (FunTy arg_ty res_ty)
| not (isPredTy arg_ty)
= do { (coi, tys, ty_r) <- go (n_req-1) res_ty
- ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) }
+ ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) }
go _ (TyConApp tc _) -- A common case
| not (isSynFamilyTyCon tc)
@@ -173,14 +172,14 @@ matchExpectedFunTys herald arity orig_ty
\begin{code}
----------------------
-matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType)
-- Special case for lists
matchExpectedListTy exp_ty
= do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
; return (coi, elt_ty) }
----------------------
-matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType)
-- Special case for parrs
matchExpectedPArrTy exp_ty
= do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty
@@ -189,7 +188,7 @@ matchExpectedPArrTy exp_ty
----------------------
matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> *
-> TcRhoType -- orig_ty
- -> TcM (CoercionI, -- T a b c ~ orig_ty
+ -> TcM (Coercion, -- T a b c ~ orig_ty
[TcSigmaType]) -- Element types, a b c
-- It's used for wired-in tycons, so we call checkWiredInTyCon
@@ -200,7 +199,7 @@ matchExpectedTyConApp tc orig_ty
= do { checkWiredInTyCon tc
; go (tyConArity tc) orig_ty [] }
where
- go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType])
+ go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType])
-- If go n ty tys = (co, [t1..tn] ++ tys)
-- then co : T t1..tn ~ ty
@@ -217,12 +216,12 @@ matchExpectedTyConApp tc orig_ty
go n_req ty@(TyConApp tycon args) tys
| tc == tycon
= ASSERT( n_req == length args) -- ty::*
- return (IdCo ty, args ++ tys)
+ return (mkReflCo ty, args ++ tys)
go n_req (AppTy fun arg) tys
| n_req > 0
= do { (coi, args) <- go (n_req - 1) fun (arg : tys)
- ; return (mkAppTyCoI coi (IdCo arg), args) }
+ ; return (mkAppCo coi (mkReflCo arg), args) }
go n_req ty tys = defer n_req ty tys
@@ -236,7 +235,7 @@ matchExpectedTyConApp tc orig_ty
----------------------
matchExpectedAppTy :: TcRhoType -- orig_ty
- -> TcM (CoercionI, -- m a ~ orig_ty
+ -> TcM (Coercion, -- m a ~ orig_ty
(TcSigmaType, TcSigmaType)) -- Returns m, a
-- If the incoming type is a mutable type variable of kind k, then
-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
@@ -248,7 +247,7 @@ matchExpectedAppTy orig_ty
| Just ty' <- tcView ty = go ty'
| Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
- = return (IdCo orig_ty, (fun_ty, arg_ty))
+ = return (mkReflCo orig_ty, (fun_ty, arg_ty))
go (TyVarTy tv)
| ASSERT( isTcTyVar tv) isMetaTyVar tv
@@ -306,14 +305,14 @@ tcSubType origin ctxt ty_actual ty_expected
<- tcGen ctxt ty_expected $ \ _ sk_rho -> do
{ (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual
; coi <- unifyType in_rho sk_rho
- ; return (coiToHsWrapper coi <.> in_wrap) }
+ ; return (coToHsWrapper coi <.> in_wrap) }
; return (sk_wrap <.> inst_wrap) }
| otherwise -- Urgh! It seems deeply weird to have equality
-- when actual is not a polytype, and it makes a big
-- difference e.g. tcfail104
= do { coi <- unifyType ty_actual ty_expected
- ; return (coiToHsWrapper coi) }
+ ; return (coToHsWrapper coi) }
tcInfer :: (TcType -> TcM a) -> TcM (a, TcType)
tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind
@@ -325,7 +324,7 @@ tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId)
tcWrapResult expr actual_ty res_ty
= do { coi <- unifyType actual_ty res_ty
-- Both types are deeply skolemised
- ; return (mkHsWrapCoI coi expr) }
+ ; return (mkHsWrapCo coi expr) }
-----------------------------------
wrapFunResCoercion
@@ -451,18 +450,18 @@ non-exported generic functions.
\begin{code}
---------------
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
-- Actual and expected types
-- Returns a coercion : ty1 ~ ty2
unifyType ty1 ty2 = uType [] ty1 ty2
---------------
-unifyPred :: PredType -> PredType -> TcM CoercionI
+unifyPred :: PredType -> PredType -> TcM Coercion
-- Actual and expected types
unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2
---------------
-unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI]
+unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion]
-- Actual and expected types
unifyTheta theta1 theta2
= do { checkTc (equalLength theta1 theta2)
@@ -513,7 +512,7 @@ uType, uType_np, uType_defer
:: [EqOrigin]
-> TcType -- ty1 is the *actual* type
-> TcType -- ty2 is the *expected* type
- -> TcM CoercionI
+ -> TcM Coercion
--------------
-- It is always safe to defer unification to the main constraint solver
@@ -529,7 +528,7 @@ uType_defer (item : origin) ty1 ty2
; doc <- mkErrInfo emptyTidyEnv ctxt
; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc])
- ; return $ ACo $ mkTyVarTy co_var }
+ ; return $ mkCoVarCo co_var }
uType_defer [] _ _
= panic "uType_defer"
@@ -545,15 +544,15 @@ uType_np origin orig_ty1 orig_ty2
[ sep [ ppr orig_ty1, text "~", ppr orig_ty2]
, ppr origin]
; coi <- go orig_ty1 orig_ty2
- ; case coi of
- ACo co -> traceTc "u_tys yields coercion:" (ppr co)
- IdCo _ -> traceTc "u_tys yields no coercion" empty
+ ; if isReflCo coi
+ then traceTc "u_tys yields no coercion" empty
+ else traceTc "u_tys yields coercion:" (ppr coi)
; return coi }
where
bale_out :: [EqOrigin] -> TcM a
bale_out origin = failWithMisMatch origin
- go :: TcType -> TcType -> TcM CoercionI
+ go :: TcType -> TcType -> TcM Coercion
-- The arguments to 'go' are always semantically identical
-- to orig_ty{1,2} except for looking through type synonyms
@@ -579,24 +578,14 @@ uType_np origin orig_ty1 orig_ty2
| Just ty1' <- tcView ty1 = go ty1' ty2
| Just ty2' <- tcView ty2 = go ty1 ty2'
-
-- Predicates
go (PredTy p1) (PredTy p2) = uPred origin p1 p2
- -- Coercion functions: (t1a ~ t1b) => t1c ~ (t2a ~ t2b) => t2c
- go ty1 ty2
- | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe ty1,
- Just (t2a,t2b,t2c) <- splitCoPredTy_maybe ty2
- = do { co1 <- uType origin t1a t2a
- ; co2 <- uType origin t1b t2b
- ; co3 <- uType origin t1c t2c
- ; return $ mkCoPredCoI co1 co2 co3 }
-
-- Functions (or predicate functions) just check the two parts
go (FunTy fun1 arg1) (FunTy fun2 arg2)
= do { coi_l <- uType origin fun1 fun2
; coi_r <- uType origin arg1 arg2
- ; return $ mkFunTyCoI coi_l coi_r }
+ ; return $ mkFunCo coi_l coi_r }
-- Always defer if a type synonym family (type function)
-- is involved. (Data families behave rigidly.)
@@ -608,20 +597,20 @@ uType_np origin orig_ty1 orig_ty2
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2 -- See Note [TyCon app]
= do { cois <- uList origin uType tys1 tys2
- ; return $ mkTyConAppCoI tc1 cois }
+ ; return $ mkTyConAppCo tc1 cois }
-- See Note [Care with type applications]
go (AppTy s1 t1) ty2
| Just (s2,t2) <- tcSplitAppTy_maybe ty2
= do { coi_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy]
; coi_t <- uType origin t1 t2
- ; return $ mkAppTyCoI coi_s coi_t }
+ ; return $ mkAppCo coi_s coi_t }
go ty1 (AppTy s2 t2)
| Just (s1,t1) <- tcSplitAppTy_maybe ty1
= do { coi_s <- uType_np origin s1 s2
; coi_t <- uType origin t1 t2
- ; return $ mkAppTyCoI coi_s coi_t }
+ ; return $ mkAppCo coi_s coi_t }
go ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
@@ -630,7 +619,7 @@ uType_np origin orig_ty1 orig_ty2
-- Anything else fails
go _ _ = bale_out origin
-unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI
+unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion
unifySigmaTy origin ty1 ty2
= do { let (tvs1, body1) = tcSplitForAllTys ty1
(tvs2, body2) = tcSplitForAllTys ty2
@@ -639,9 +628,8 @@ unifySigmaTy origin ty1 ty2
-- Get location from monad, not from tvs1
; let tys = mkTyVarTys skol_tvs
in_scope = mkInScopeSet (mkVarSet skol_tvs)
- phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
- phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
--- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+ phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
+ phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
; ((coi, _untch), lie) <- captureConstraints $
captureUntouchables $
@@ -656,23 +644,24 @@ unifySigmaTy origin ty1 ty2
(failWithMisMatch origin) -- ToDo: give details from bad_lie
; emitConstraints lie
- ; return (foldr mkForAllTyCoI coi skol_tvs) }
+ ; return (foldr mkForAllCo coi skol_tvs) }
----------
-uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI
+uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion
uPred origin (IParam n1 t1) (IParam n2 t2)
| n1 == n2
= do { coi <- uType origin t1 t2
- ; return $ mkIParamPredCoI n1 coi }
+ ; return $ mkPredCo $ IParam n1 coi }
uPred origin (ClassP c1 tys1) (ClassP c2 tys2)
| c1 == c2
= do { cois <- uList origin uType tys1 tys2
-- Guaranteed equal lengths because the kinds check
- ; return $ mkClassPPredCoI c1 cois }
+ ; return $ mkPredCo $ ClassP c1 cois }
+
uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b)
- = do { coia <- uType origin ty1a ty2a
- ; coib <- uType origin ty1b ty2b
- ; return $ mkEqPredCoI coia coib }
+ = do { coa <- uType origin ty1a ty2a
+ ; cob <- uType origin ty1b ty2b
+ ; return $ mkPredCo $ EqPred coa cob }
uPred origin _ _ = failWithMisMatch origin
@@ -816,7 +805,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips
back into @uTys@ if it turns out that the variable is already bound.
\begin{code}
-uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI
+uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion
uVar origin swapped tv1 ty2
= do { traceTc "uVar" (vcat [ ppr origin
, ppr swapped
@@ -834,13 +823,13 @@ uUnfilledVar :: [EqOrigin]
-> SwapFlag
-> TcTyVar -> TcTyVarDetails -- Tyvar 1
-> TcTauType -- Type 2
- -> TcM CoercionI
+ -> TcM Coercion
-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
-- It might be a skolem, or untouchable, or meta
uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2)
| tv1 == tv2 -- Same type variable => no-op
- = return (IdCo (mkTyVarTy tv1))
+ = return (mkReflCo (mkTyVarTy tv1))
| otherwise -- Distinct type variables
= do { lookup2 <- lookupTcTyVar tv2
@@ -874,7 +863,7 @@ uUnfilledVars :: [EqOrigin]
-> SwapFlag
-> TcTyVar -> TcTyVarDetails -- Tyvar 1
-> TcTyVar -> TcTyVarDetails -- Tyvar 2
- -> TcM CoercionI
+ -> TcM Coercion
-- Invarant: The type variables are distinct,
-- Neither is filled in yet
@@ -899,8 +888,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2
ty1 = mkTyVarTy tv1
ty2 = mkTyVarTy tv2
- nicer_to_update_tv1 _ (SigTv _) = True
- nicer_to_update_tv1 (SigTv _) _ = False
+ nicer_to_update_tv1 _ SigTv = True
+ nicer_to_update_tv1 SigTv _ = False
nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1)
-- Try not to update SigTvs; and try to update sys-y type
-- variables in preference to ones gotten (say) by
@@ -1053,10 +1042,10 @@ lookupTcTyVar tyvar
details = ASSERT2( isTcTyVar tyvar, ppr tyvar )
tcTyVarDetails tyvar
-updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI
+updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion
updateMeta tv1 ref1 ty2
= do { writeMetaTyVarRef tv1 ref1 ty2
- ; return (IdCo ty2) }
+ ; return (mkReflCo ty2) }
\end{code}
Note [Unifying untouchables]
diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot
index 244f0cb19b32c2c57bdb227e3b9e501bf3be7361..e7ad4181fc31f0ebc190a752e827a52be26c337b 100644
--- a/compiler/typecheck/TcUnify.lhs-boot
+++ b/compiler/typecheck/TcUnify.lhs-boot
@@ -2,10 +2,10 @@
module TcUnify where
import TcType ( TcTauType )
import TcRnTypes( TcM )
-import Coercion (CoercionI)
+import Coercion (Coercion)
-- This boot file exists only to tie the knot between
-- TcUnify and TcSimplify
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
\end{code}
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 1e16bc4763b320eb503dfc7cd58cf7d29d846c1c..d9e44e591c4553700c0a969cb1d4da19e851e037 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -81,7 +81,7 @@ type ClassOpItem = (Id, DefMeth)
data DefMeth = NoDefMeth -- No default method
| DefMeth Name -- A polymorphic default method
- | GenDefMeth -- A generic default method
+ | GenDefMeth Name -- A generic default method
deriving Eq
-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
@@ -91,7 +91,7 @@ defMethSpecOfDefMeth meth
= case meth of
NoDefMeth -> NoDM
DefMeth _ -> VanillaDM
- GenDefMeth -> GenericDM
+ GenDefMeth _ -> GenericDM
\end{code}
@@ -208,9 +208,9 @@ instance Show Class where
showsPrec p c = showsPrecSDoc p (ppr c)
instance Outputable DefMeth where
- ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
- ppr GenDefMeth = ptext (sLit "Generic default method")
- ppr NoDefMeth = empty -- No default method
+ ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
+ ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n
+ ppr NoDefMeth = empty -- No default method
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index faab46304421562cc7ab117447019d7bf650a5b7..7df5b8e38fb82d77f1689165bdc8a70631827695 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -7,15 +7,9 @@
-- as used in System FC. See 'CoreSyn.Expr' for
-- more on System FC and how coercions fit into it.
--
--- Coercions are represented as types, and their kinds tell what types the
--- coercion works on. The coercion kind constructor is a special TyCon that
--- must always be saturated, like so:
---
--- > typeKind (symCoercion type) :: TyConApp CoTyCon{...} [type, type]
module Coercion (
-- * Main data type
- Coercion, Kind,
- typeKind,
+ Coercion(..), Var, CoVar,
-- ** Deconstructing Kinds
kindFunResult, kindAppResult, synTyConResKind,
@@ -24,237 +18,454 @@ module Coercion (
-- ** Predicates on Kinds
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
- isCoSuperKind, isSuperKind, isCoercionKind,
+ isSuperKind, isCoercionKind,
mkArrowKind, mkArrowKinds,
isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
isSubKindCon,
- mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe,
- coercionKind, coercionKinds, isIdentityCoercion,
-
- -- ** Equality predicates
- isEqPred, mkEqPred, getEqPredTys, isEqPredTy,
-
- -- ** Coercion transformations
- mkCoercion,
- mkSymCoercion, mkTransCoercion,
- mkLeftCoercion, mkRightCoercion,
- mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion,
- mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion,
- mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
- mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion,
-
- mkClassPPredCo, mkIParamPredCo, mkEqPredCo,
- mkCoVarCoercion, mkCoPredCo,
+ mkCoType, coVarKind, coVarKind_maybe,
+ coercionType, coercionKind, coercionKinds, isReflCo,
-
- unsafeCoercionTyCon, symCoercionTyCon,
- transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn
- csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon,
+ -- ** Constructing coercions
+ mkReflCo, mkCoVarCo,
+ mkAxInstCo, mkPiCo, mkPiCos,
+ mkSymCo, mkTransCo, mkNthCo,
+ mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
+ mkForAllCo, mkUnsafeCo,
+ mkNewTypeCo, mkFamInstCo,
+ mkPredCo,
-- ** Decomposition
- decompLR_maybe, decompCsel_maybe, decompInst_maybe,
splitCoPredTy_maybe,
splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
-
+ getCoVar_maybe,
+
+ splitTyConAppCo_maybe,
+ splitAppCo_maybe,
+ splitForAllCo_maybe,
+
+ -- ** Coercion variables
+ mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique,
+
+ -- ** Free variables
+ tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize,
+
+ -- ** Substitution
+ CvSubstEnv, emptyCvSubstEnv,
+ CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar,
+ isEmptyCvSubst, zapCvSubstEnv, getCvInScope,
+ substCo, substCos, substCoVar, substCoVars,
+ substCoWithTy, substCoWithTys,
+ cvTvSubst, tvCvSubst, zipOpenCvSubst,
+ substTy, extendTvSubst,
+ substTyVarBndr, substCoVarBndr,
+
+ -- ** Lifting
+ liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith,
+
-- ** Comparison
coreEqCoercion, coreEqCoercion2,
- -- * CoercionI
- CoercionI(..),
- isIdentityCoI,
- mkSymCoI, mkTransCoI,
- mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
- mkForAllTyCoI,
- fromCoI,
- mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI, mkCoPredCoI
+ -- ** Forcing evaluation of coercions
+ seqCo,
+
+ -- * Pretty-printing
+ pprCo, pprParendCo, pprCoAxiom,
+ -- * Other
+ applyCo, coVarPred
+
) where
#include "HsVersions.h"
+import Unify ( MatchEnv(..), ruleMatchTyX, matchList )
import TypeRep
-import Type
+import qualified Type
+import Type hiding( substTy, substTyVarBndr, extendTvSubst )
+import Kind
+import Class ( classTyCon )
import TyCon
-import Class
import Var
import VarEnv
import VarSet
-import Name
-import PrelNames
+import UniqFM ( minusUFM )
+import Maybes ( orElse )
+import Name ( Name, NamedThing(..), nameUnique )
+import OccName ( isSymOcc )
import Util
import BasicTypes
import Outputable
+import Unique
+import Pair
+import TysPrim ( eqPredPrimTyCon )
+import PrelNames ( funTyConKey )
+import Control.Applicative
+import Data.Traversable (traverse, sequenceA)
+import Control.Arrow (second)
import FastString
+
+import qualified Data.Data as Data hiding ( TyCon )
\end{code}
%************************************************************************
%* *
- Functions over Kinds
+ Coercions
%* *
%************************************************************************
\begin{code}
--- | Essentially 'funResultTy' on kinds
-kindFunResult :: Kind -> Kind
-kindFunResult k = funResultTy k
-
-kindAppResult :: Kind -> [arg] -> Kind
-kindAppResult k [] = k
-kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
-
--- | Essentially 'splitFunTys' on kinds
-splitKindFunTys :: Kind -> ([Kind],Kind)
-splitKindFunTys k = splitFunTys k
-
-splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
-splitKindFunTy_maybe = splitFunTy_maybe
-
--- | Essentially 'splitFunTysN' on kinds
-splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
-splitKindFunTysN k = splitFunTysN k
-
--- | Find the result 'Kind' of a type synonym,
--- after applying it to its 'arity' number of type variables
--- Actually this function works fine on data types too,
--- but they'd always return '*', so we never need to ask
-synTyConResKind :: TyCon -> Kind
-synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
-isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
- isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
-
-isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
-
-isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
-isOpenTypeKind _ = False
-
-isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
-
-isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
-isUbxTupleKind _ = False
-
-isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
-
-isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
-isArgTypeKind _ = False
-
-isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
-
-isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
-isUnliftedTypeKind _ = False
-
-isSubOpenTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
-isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
- ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
- False
-isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
-isSubOpenTypeKind other = ASSERT( isKind other ) False
- -- This is a conservative answer
- -- It matters in the call to isSubKind in
- -- checkExpectedKind.
-
-isSubArgTypeKindCon kc
- | isUnliftedTypeKindCon kc = True
- | isLiftedTypeKindCon kc = True
- | isArgTypeKindCon kc = True
- | otherwise = False
-
-isSubArgTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of ArgTypeKind
-isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
-isSubArgTypeKind _ = False
-
--- | Is this a super-kind (i.e. a type-of-kinds)?
-isSuperKind :: Type -> Bool
-isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
-isSuperKind _ = False
-
--- | Is this a kind (i.e. a type-of-types)?
-isKind :: Kind -> Bool
-isKind k = isSuperKind (typeKind k)
-
-isSubKind :: Kind -> Kind -> Bool
--- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
-isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2'))
- = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2'
-isSubKind _ _ = False
-
-eqKind :: Kind -> Kind -> Bool
-eqKind = tcEqType
-
-isSubKindCon :: TyCon -> TyCon -> Bool
--- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
-isSubKindCon kc1 kc2
- | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
- | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
- | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
- | isOpenTypeKindCon kc2 = True
- -- we already know kc1 is not a fun, its a TyCon
- | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
- | otherwise = False
-
-defaultKind :: Kind -> Kind
--- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
--- information on what that means
-
--- When we generalise, we make generic type variables whose kind is
--- simple (* or *->* etc). So generic type variables (other than
--- built-in constants like 'error') always have simple kinds. This is important;
--- consider
--- f x = True
--- We want f to get type
--- f :: forall (a::*). a -> Bool
--- Not
--- f :: forall (a::??). a -> Bool
--- because that would allow a call like (f 3#) as well as (f True),
---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
-defaultKind k
- | isSubOpenTypeKind k = liftedTypeKind
- | isSubArgTypeKind k = liftedTypeKind
- | otherwise = k
+-- | A 'Coercion' is concrete evidence of the equality/convertibility
+-- of two types.
+
+data Coercion
+ -- These ones mirror the shape of types
+ = Refl Type -- See Note [Refl invariant]
+ -- Invariant: applications of (Refl T) to a bunch of identity coercions
+ -- always show up as Refl.
+ -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).
+
+ -- Applications of (Refl T) to some coercions, at least one of
+ -- which is NOT the identity, show up as TyConAppCo.
+ -- (They may not be fully saturated however.)
+ -- ConAppCo coercions (like all coercions other than Refl)
+ -- are NEVER the identity.
+
+ -- These ones simply lift the correspondingly-named
+ -- Type constructors into Coercions
+ | TyConAppCo TyCon [Coercion] -- lift TyConApp
+ -- The TyCon is never a synonym;
+ -- we expand synonyms eagerly
+
+ | AppCo Coercion Coercion -- lift AppTy
+
+ -- See Note [Forall coercions]
+ | ForAllCo TyVar Coercion -- forall a. g
+
+ -- These are special
+ | CoVarCo CoVar
+ | AxiomInstCo CoAxiom [Coercion] -- The coercion arguments always *precisely*
+ -- saturate arity of CoAxiom.
+ -- See [Coercion axioms applied to coercions]
+ | UnsafeCo Type Type
+ | SymCo Coercion
+ | TransCo Coercion Coercion
+
+ -- These are destructors
+ | NthCo Int Coercion -- Zero-indexed
+ | InstCo Coercion Type
+ deriving (Data.Data, Data.Typeable)
\end{code}
+Note [Refl invariant]
+~~~~~~~~~~~~~~~~~~~~~
+Coercions have the following invariant
+ Refl is always lifted as far as possible.
+
+You might think that a consequencs is:
+ Every identity coercions has Refl at the root
+
+But that's not quite true because of coercion variables. Consider
+ g where g :: Int~Int
+ Left h where h :: Maybe Int ~ Maybe Int
+etc. So the consequence is only true of coercions that
+have no coercion variables.
+
+Note [Coercion axioms applied to coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The reason coercion axioms can be applied to coercions and not just
+types is to allow for better optimization. There are some cases where
+we need to be able to "push transitivity inside" an axiom in order to
+expose further opportunities for optimization.
+
+For example, suppose we have
+
+ C a : t[a] ~ F a
+ g : b ~ c
+
+and we want to optimize
+
+ sym (C b) ; t[g] ; C c
+
+which has the kind
+
+ F b ~ F c
+
+(stopping through t[b] and t[c] along the way).
+
+We'd like to optimize this to just F g -- but how? The key is
+that we need to allow axioms to be instantiated by *coercions*,
+not just by types. Then we can (in certain cases) push
+transitivity inside the axiom instantiations, and then react
+opposite-polarity instantiations of the same axiom. In this
+case, e.g., we match t[g] against the LHS of (C c)'s kind, to
+obtain the substitution a |-> g (note this operation is sort
+of the dual of lifting!) and hence end up with
+
+ C g : t[b] ~ F c
+
+which indeed has the same kind as t[g] ; C c.
+
+Now we have
+
+ sym (C b) ; C g
+
+which can be optimized to F g.
+
+
+Note [Forall coercions]
+~~~~~~~~~~~~~~~~~~~~~~~
+Constructing coercions between forall-types can be a bit tricky.
+Currently, the situation is as follows:
+
+ ForAllCo TyVar Coercion
+
+represents a coercion between polymorphic types, with the rule
+
+ v : k g : t1 ~ t2
+ ----------------------------------------------
+ ForAllCo v g : (all v:k . t1) ~ (all v:k . t2)
+
+Note that it's only necessary to coerce between polymorphic types
+where the type variables have identical kinds, because equality on
+kinds is trivial.
+
+Note [Predicate coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ g :: a~b
+How can we coerce between types
+ ([c]~a) => [a] -> c
+and
+ ([c]~b) => [b] -> c
+where the equality predicate *itself* differs?
+
+Answer: we simply treat (~) as an ordinary type constructor, so these
+types really look like
+
+ ((~) [c] a) -> [a] -> c
+ ((~) [c] b) -> [b] -> c
+
+So the coercion between the two is obviously
+
+ ((~) [c] g) -> [g] -> c
+
+Another way to see this to say that we simply collapse predicates to
+their representation type (see Type.coreView and Type.predTypeRep).
+
+This collapse is done by mkPredCo; there is no PredCo constructor
+in Coercion. This is important because we need Nth to work on
+predicates too:
+ Nth 1 ((~) [c] g) = g
+See Simplify.simplCoercionF, which generates such selections.
+
%************************************************************************
%* *
- Coercions
+\subsection{Coercion variables}
+%* *
+%************************************************************************
+
+\begin{code}
+coVarName :: CoVar -> Name
+coVarName = varName
+
+setCoVarUnique :: CoVar -> Unique -> CoVar
+setCoVarUnique = setVarUnique
+
+setCoVarName :: CoVar -> Name -> CoVar
+setCoVarName = setVarName
+
+isCoVar :: Var -> Bool
+isCoVar v = isCoVarType (varType v)
+
+isCoVarType :: Type -> Bool
+isCoVarType = isEqPredTy
+\end{code}
+
+
+\begin{code}
+tyCoVarsOfCo :: Coercion -> VarSet
+-- Extracts type and coercion variables from a coercion
+tyCoVarsOfCo (Refl ty) = tyVarsOfType ty
+tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv
+tyCoVarsOfCo (CoVarCo v) = unitVarSet v
+tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co
+tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co
+tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
+
+tyCoVarsOfCos :: [Coercion] -> VarSet
+tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
+
+coVarsOfCo :: Coercion -> VarSet
+-- Extract *coerction* variables only. Tiresome to repeat the code, but easy.
+coVarsOfCo (Refl _) = emptyVarSet
+coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos
+coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (ForAllCo _ co) = coVarsOfCo co
+coVarsOfCo (CoVarCo v) = unitVarSet v
+coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos
+coVarsOfCo (UnsafeCo _ _) = emptyVarSet
+coVarsOfCo (SymCo co) = coVarsOfCo co
+coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (NthCo _ co) = coVarsOfCo co
+coVarsOfCo (InstCo co _) = coVarsOfCo co
+
+coVarsOfCos :: [Coercion] -> VarSet
+coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
+
+coercionSize :: Coercion -> Int
+coercionSize (Refl ty) = typeSize ty
+coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2
+coercionSize (ForAllCo _ co) = 1 + coercionSize co
+coercionSize (CoVarCo _) = 1
+coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2
+coercionSize (SymCo co) = 1 + coercionSize co
+coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
+coercionSize (NthCo _ co) = 1 + coercionSize co
+coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty
+\end{code}
+
+%************************************************************************
%* *
+ Pretty-printing coercions
+%* *
%************************************************************************
+@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@
+function is defined to use this. @pprParendCo@ is the same, except it
+puts parens around the type, except for the atomic cases.
+@pprParendCo@ works just by setting the initial context precedence
+very high.
\begin{code}
--- | A 'Coercion' represents a 'Type' something should be coerced to.
-type Coercion = Type
+instance Outputable Coercion where
+ ppr = pprCo
+
+pprCo, pprParendCo :: Coercion -> SDoc
+pprCo co = ppr_co TopPrec co
+pprParendCo co = ppr_co TyConPrec co
+
+ppr_co :: Prec -> Coercion -> SDoc
+ppr_co _ (Refl ty) = angles (ppr ty)
+
+ppr_co p co@(TyConAppCo tc cos)
+ | tc `hasKey` funTyConKey = ppr_fun_co p co
+ | otherwise = pprTcApp p ppr_co tc cos
+
+ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $
+ pprCo co1 <+> ppr_co TyConPrec co2
+
+ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
+
+ppr_co _ (CoVarCo cv)
+ | isSymOcc (getOccName cv) = parens (ppr cv)
+ | otherwise = ppr cv
+
+ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
--- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the
--- types that a 'Coercion' will work on.
-type CoercionKind = Kind
-------------------------------
+ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $
+ ppr_co FunPrec co1
+ <+> ptext (sLit ";")
+ <+> ppr_co FunPrec co2
+ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
+ pprParendCo co <> ptext (sLit "@") <> pprType ty
--- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into
+ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2]
+ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co]
+ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co]
+
+
+angles :: SDoc -> SDoc
+angles p = char '<' <> p <> char '>'
+
+ppr_fun_co :: Prec -> Coercion -> SDoc
+ppr_fun_co p co = pprArrowChain p (split co)
+ where
+ split (TyConAppCo f [arg,res])
+ | f `hasKey` funTyConKey
+ = ppr_co FunPrec arg : split res
+ split co = [ppr_co TopPrec co]
+
+ppr_forall_co :: Prec -> Coercion -> SDoc
+ppr_forall_co p ty
+ = maybeParen p FunPrec $
+ sep [pprForAll tvs, ppr_co TopPrec rho]
+ where
+ (tvs, rho) = split1 [] ty
+ split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
+\end{code}
+
+\begin{code}
+pprCoAxiom :: CoAxiom -> SDoc
+pprCoAxiom ax
+ = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax)
+ , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ]
+\end{code}
+
+%************************************************************************
+%* *
+ Functions over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into
-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:
--
--- > decomposeCo 3 c = [right (left (left c)), right (left c), right c]
+-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]
decomposeCo :: Arity -> Coercion -> [Coercion]
-decomposeCo n co
- = go n co []
- where
- go 0 _ cos = cos
- go n co cos = go (n-1) (mkLeftCoercion co)
- (mkRightCoercion co : cos)
-
+decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ]
+
+-- | Attempts to obtain the type variable underlying a 'Coercion'
+getCoVar_maybe :: Coercion -> Maybe CoVar
+getCoVar_maybe (CoVarCo cv) = Just cv
+getCoVar_maybe _ = Nothing
+
+-- | Attempts to tease a coercion apart into a type constructor and the application
+-- of a number of coercion arguments to that constructor
+splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
+splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty)
+splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos)
+splitTyConAppCo_maybe _ = Nothing
+
+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
+-- ^ Attempt to take a coercion application apart.
+splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2)
+splitAppCo_maybe (TyConAppCo tc cos)
+ | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc
+ , Just (cos', co') <- snocView cos
+ = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps!
+ -- Use mkTyConAppCo to preserve the invariant
+ -- that identity coercions are always represented by Refl
+splitAppCo_maybe (Refl ty)
+ | Just (ty1, ty2) <- splitAppTy_maybe ty
+ = Just (Refl ty1, Refl ty2)
+splitAppCo_maybe _ = Nothing
+
+splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co)
+splitForAllCo_maybe _ = Nothing
-------------------------------------------------------
-- and some coercion kind stuff
+coVarPred :: CoVar -> PredType
+coVarPred cv
+ = ASSERT( isCoVar cv )
+ case splitPredTy_maybe (varType cv) of
+ Just pred -> pred
+ other -> pprPanic "coVarPred" (ppr cv $$ ppr other)
+
coVarKind :: CoVar -> (Type,Type)
-- c :: t1 ~ t2
coVarKind cv = case coVarKind_maybe cv of
@@ -262,31 +473,12 @@ coVarKind cv = case coVarKind_maybe cv of
Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv))
coVarKind_maybe :: CoVar -> Maybe (Type,Type)
-coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv)
-
--- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'.
--- Panics if the argument is not a valid 'CoercionKind'
-splitCoKind_maybe :: Kind -> Maybe (Type, Type)
-splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co'
-splitCoKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2)
-splitCoKind_maybe _ = Nothing
+coVarKind_maybe cv = splitEqPredTy_maybe (varType cv)
--- | Makes a 'CoercionKind' from two types: the types whose equality
+-- | Makes a coercion type from two types: the types whose equality
-- is proven by the relevant 'Coercion'
-mkCoKind :: Type -> Type -> CoercionKind
-mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2)
-
--- | (mkCoPredTy s t r) produces the type: (s~t) => r
-mkCoPredTy :: Type -> Type -> Type -> Type
-mkCoPredTy s t r = ASSERT( not (co_var `elemVarSet` tyVarsOfType r) )
- ForAllTy co_var r
- where
- co_var = mkWildCoVar (mkCoKind s t)
-
-mkCoPredCo :: Coercion -> Coercion -> Coercion -> Coercion
--- Creates a coercion between (s1~t1) => r1 and (s2~t2) => r2
-mkCoPredCo = mkCoPredTy
-
+mkCoType :: Type -> Type -> Type
+mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2)
splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type)
splitCoPredTy_maybe ty
@@ -297,25 +489,13 @@ splitCoPredTy_maybe ty
| otherwise
= Nothing
--- | Tests whether a type is just a type equality predicate
-isEqPredTy :: Type -> Bool
-isEqPredTy (PredTy pred) = isEqPred pred
-isEqPredTy _ = False
-
--- | Creates a type equality predicate
-mkEqPred :: (Type, Type) -> PredType
-mkEqPred (ty1, ty2) = EqPred ty1 ty2
-
--- | Splits apart a type equality predicate, if the supplied 'PredType' is one.
--- Panics otherwise
-getEqPredTys :: PredType -> (Type,Type)
-getEqPredTys (EqPred ty1 ty2) = (ty1, ty2)
-getEqPredTys other = pprPanic "getEqPredTys" (ppr other)
-
-isIdentityCoercion :: Coercion -> Bool
-isIdentityCoercion co
- = case coercionKind co of
- (t1,t2) -> t1 `coreEqType` t2
+isReflCo :: Coercion -> Bool
+isReflCo (Refl {}) = True
+isReflCo _ = False
+
+isReflCo_maybe :: Coercion -> Maybe Type
+isReflCo_maybe (Refl ty) = Just ty
+isReflCo_maybe _ = Nothing
\end{code}
%************************************************************************
@@ -324,236 +504,157 @@ isIdentityCoercion co
%* *
%************************************************************************
-Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args)
-
\begin{code}
--- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to
--- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function
--- if possible
-mkCoercion :: TyCon -> [Type] -> Coercion
-mkCoercion coCon args = ASSERT( tyConArity coCon == length args )
- TyConApp coCon args
+mkCoVarCo :: CoVar -> Coercion
+mkCoVarCo cv
+ | ty1 `eqType` ty2 = Refl ty1
+ | otherwise = CoVarCo cv
+ where
+ (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
-mkCoVarCoercion :: CoVar -> Coercion
-mkCoVarCoercion cv = mkTyVarTy cv
+mkReflCo :: Type -> Coercion
+mkReflCo = Refl
--- | Apply a 'Coercion' to another 'Coercion', which is presumably a
--- 'Coercion' constructor of some kind
-mkAppCoercion :: Coercion -> Coercion -> Coercion
-mkAppCoercion co1 co2 = mkAppTy co1 co2
+mkAxInstCo :: CoAxiom -> [Type] -> Coercion
+mkAxInstCo ax tys
+ | arity == n_tys = AxiomInstCo ax rtys
+ | otherwise = ASSERT( arity < n_tys )
+ foldl AppCo (AxiomInstCo ax (take arity rtys))
+ (drop arity rtys)
+ where
+ n_tys = length tys
+ arity = coAxiomArity ax
+ rtys = map Refl tys
+
+-- | Apply a 'Coercion' to another 'Coercion'.
+mkAppCo :: Coercion -> Coercion -> Coercion
+mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2)
+mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co])
+mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co])
+mkAppCo co1 co2 = AppCo co1 co2
+-- Note, mkAppCo is careful to maintain invariants regarding
+-- where Refl constructors appear; see the comments in the definition
+-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs.
-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
--- See also 'mkAppCoercion'
-mkAppsCoercion :: Coercion -> [Coercion] -> Coercion
-mkAppsCoercion co1 tys = foldl mkAppTy co1 tys
+-- See also 'mkAppCo'
+mkAppCos :: Coercion -> [Coercion] -> Coercion
+mkAppCos co1 tys = foldl mkAppCo co1 tys
-- | Apply a type constructor to a list of coercions.
-mkTyConCoercion :: TyCon -> [Coercion] -> Coercion
-mkTyConCoercion con cos = mkTyConApp con cos
+mkTyConAppCo :: TyCon -> [Coercion] -> Coercion
+mkTyConAppCo tc cos
+ -- Expand type synonyms
+ | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos
+ = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos
+
+ | Just tys <- traverse isReflCo_maybe cos
+ = Refl (mkTyConApp tc tys) -- See Note [Refl invariant]
+
+ | otherwise = TyConAppCo tc cos
-- | Make a function 'Coercion' between two other 'Coercion's
-mkFunCoercion :: Coercion -> Coercion -> Coercion
-mkFunCoercion co1 co2 = mkFunTy co1 co2 -- NB: Handles correctly the forall for eqpreds!
+mkFunCo :: Coercion -> Coercion -> Coercion
+mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2]
-- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
-mkForAllCoercion :: Var -> Coercion -> Coercion
+mkForAllCo :: Var -> Coercion -> Coercion
-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkForAllCoercion tv co = ASSERT ( isTyCoVar tv ) mkForAllTy tv co
+mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty)
+mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co
+mkPredCo :: Pred Coercion -> Coercion
+-- See Note [Predicate coercions]
+mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2]
+mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos
+mkPredCo (IParam _ co) = co
-------------------------------
-mkSymCoercion :: Coercion -> Coercion
--- ^ Create a symmetric version of the given 'Coercion' that asserts equality
--- between the same types but in the other "direction", so a kind of @t1 ~ t2@
--- becomes the kind @t2 ~ t1@.
-mkSymCoercion g = mkCoercion symCoercionTyCon [g]
-
-mkTransCoercion :: Coercion -> Coercion -> Coercion
--- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's.
-mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2]
-
-mkLeftCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of
--- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: f ~ g
-mkLeftCoercion co = mkCoercion leftCoercionTyCon [co]
-
-mkRightCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of
--- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: x ~ y
-mkRightCoercion co = mkCoercion rightCoercionTyCon [co]
-
-mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion
-mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co]
-mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co]
-mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co]
-
--------------------------------
-mkInstCoercion :: Coercion -> Type -> Coercion
--- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
--- the resulting beta-reduction, otherwise it creates a suspended instantiation.
-mkInstCoercion co ty = mkCoercion instCoercionTyCon [co, ty]
-
-mkInstsCoercion :: Coercion -> [Type] -> Coercion
--- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right
-mkInstsCoercion co tys = foldl mkInstCoercion co tys
-
--- | Manufacture a coercion from this air. Needless to say, this is not usually safe,
--- but it is used when we know we are dealing with bottom, which is one case in which
--- it is safe. This is also used implement the @unsafeCoerce#@ primitive.
--- Optimise by pushing down through type constructors
-mkUnsafeCoercion :: Type -> Type -> Coercion
-mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+-- | Create a symmetric version of the given 'Coercion' that asserts
+-- equality between the same types but in the other "direction", so
+-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.
+mkSymCo :: Coercion -> Coercion
+
+-- Do a few simple optimizations, but don't bother pushing occurrences
+-- of symmetry to the leaves; the optimizer will take care of that.
+mkSymCo co@(Refl {}) = co
+mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1
+mkSymCo (SymCo co) = co
+mkSymCo co = SymCo co
+
+-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
+mkTransCo :: Coercion -> Coercion -> Coercion
+mkTransCo (Refl _) co = co
+mkTransCo co (Refl _) = co
+mkTransCo co1 co2 = TransCo co1 co2
+
+mkNthCo :: Int -> Coercion -> Coercion
+mkNthCo n (Refl ty) = Refl (getNth n ty)
+mkNthCo n co = NthCo n co
+
+-- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
+-- the resulting beta-reduction, otherwise it creates a suspended instantiation.
+mkInstCo :: Coercion -> Type -> Coercion
+mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co
+mkInstCo co ty = InstCo co ty
+
+-- | Manufacture a coercion from thin air. Needless to say, this is
+-- not usually safe, but it is used when we know we are dealing with
+-- bottom, which is one case in which it is safe. This is also used
+-- to implement the @unsafeCoerce#@ primitive. Optimise by pushing
+-- down through type constructors.
+mkUnsafeCo :: Type -> Type -> Coercion
+mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1
+mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2
- = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2)
+ = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2)
-mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2)
- = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2)
+mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2)
+ = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2)
-mkUnsafeCoercion ty1 ty2
- | ty1 `coreEqType` ty2 = ty1
- | otherwise = mkCoercion unsafeCoercionTyCon [ty1, ty2]
+mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
-- See note [Newtype coercions] in TyCon
--- | Create a coercion suitable for the given 'TyCon'. The 'Name' should be that of a
--- new coercion 'TyCon', the 'TyVar's the arguments expected by the @newtype@ and the
--- type the appropriate right hand side of the @newtype@, with the free variables
--- a subset of those 'TyVar's.
-mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon
-mkNewTypeCoercion name tycon tvs rhs_ty
- = mkCoercionTyCon name arity desc
- where
- arity = length tvs
- desc = CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
- , co_ax_rhs = rhs_ty }
+-- | Create a coercion constructor (axiom) suitable for the given
+-- newtype 'TyCon'. The 'Name' should be that of a new coercion
+-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
+-- the type the appropriate right hand side of the @newtype@, with
+-- the free variables a subset of those 'TyVar's.
+mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom
+mkNewTypeCo name tycon tvs rhs_ty
+ = CoAxiom { co_ax_unique = nameUnique name
+ , co_ax_name = name
+ , co_ax_tvs = tvs
+ , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
+ , co_ax_rhs = rhs_ty }
-- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type
-- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is
--- the coercion tycon built here, @F@ the family tycon and @R@ the (derived)
+-- the coercion constructor built here, @F@ the family tycon and @R@ the (derived)
-- representation tycon.
-mkFamInstCoercion :: Name -- ^ Unique name for the coercion tycon
+mkFamInstCo :: Name -- ^ Unique name for the coercion tycon
-> [TyVar] -- ^ Type parameters of the coercion (@tvs@)
-> TyCon -- ^ Family tycon (@F@)
-> [Type] -- ^ Type instance (@ts@)
-> TyCon -- ^ Representation tycon (@R@)
- -> TyCon -- ^ Coercion tycon (@Co@)
-mkFamInstCoercion name tvs family inst_tys rep_tycon
- = mkCoercionTyCon name arity desc
- where
- arity = length tvs
- desc = CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp family inst_tys
- , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) }
-
-
-mkClassPPredCo :: Class -> [Coercion] -> Coercion
-mkClassPPredCo cls = (PredTy . ClassP cls)
-
-mkIParamPredCo :: (IPName Name) -> Coercion -> Coercion
-mkIParamPredCo ipn = (PredTy . IParam ipn)
-
-mkEqPredCo :: Coercion -> Coercion -> Coercion
-mkEqPredCo co1 co2 = PredTy (EqPred co1 co2)
-
-
+ -> CoAxiom -- ^ Coercion constructor (@Co@)
+mkFamInstCo name tvs family inst_tys rep_tycon
+ = CoAxiom { co_ax_unique = nameUnique name
+ , co_ax_name = name
+ , co_ax_tvs = tvs
+ , co_ax_lhs = mkTyConApp family inst_tys
+ , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) }
+
+mkPiCos :: [Var] -> Coercion -> Coercion
+mkPiCos vs co = foldr mkPiCo co vs
+
+mkPiCo :: Var -> Coercion -> Coercion
+mkPiCo v co | isTyVar v = mkForAllCo v co
+ | otherwise = mkFunCo (mkReflCo (varType v)) co
\end{code}
-
-%************************************************************************
-%* *
- Coercion Type Constructors
-%* *
-%************************************************************************
-
-Example. The coercion ((sym c) (sym d) (sym e))
-will be represented by (TyConApp sym [c, sym d, sym e])
-If sym c :: p1=q1
- sym d :: p2=q2
- sym e :: p3=q3
-then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3)
-
-\begin{code}
--- | Coercion type constructors: avoid using these directly and instead use
--- the @mk*Coercion@ and @split*Coercion@ family of functions if possible.
---
--- Each coercion TyCon is built with the special CoercionTyCon record and
--- carries its own kinding rule. Such CoercionTyCons must be fully applied
--- by any TyConApp in which they are applied, however they may also be over
--- applied (see example above) and the kinding function must deal with this.
-symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon,
- csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon
-
-symCoercionTyCon = mkCoercionTyCon symCoercionTyConName 1 CoSym
-transCoercionTyCon = mkCoercionTyCon transCoercionTyConName 2 CoTrans
-leftCoercionTyCon = mkCoercionTyCon leftCoercionTyConName 1 CoLeft
-rightCoercionTyCon = mkCoercionTyCon rightCoercionTyConName 1 CoRight
-instCoercionTyCon = mkCoercionTyCon instCoercionTyConName 2 CoInst
-csel1CoercionTyCon = mkCoercionTyCon csel1CoercionTyConName 1 CoCsel1
-csel2CoercionTyCon = mkCoercionTyCon csel2CoercionTyConName 1 CoCsel2
-cselRCoercionTyCon = mkCoercionTyCon cselRCoercionTyConName 1 CoCselR
-unsafeCoercionTyCon = mkCoercionTyCon unsafeCoercionTyConName 2 CoUnsafe
-
-transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName,
- rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName,
- csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name
-
-transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon
-symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon
-leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon
-rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon
-instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon
-csel1CoercionTyConName = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon
-csel2CoercionTyConName = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon
-cselRCoercionTyConName = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon
-unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon
-
-mkCoConName :: FastString -> Unique -> TyCon -> Name
-mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
- key (ATyCon coCon) BuiltInSyntax
-\end{code}
-
-\begin{code}
-------------
-decompLR_maybe :: (Type,Type) -> Maybe ((Type,Type), (Type,Type))
--- Helper for left and right. Finds coercion kind of its input and
--- returns the left and right projections of the coercion...
---
--- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2))
-decompLR_maybe (ty1,ty2)
- | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1
- , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2
- = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2))
-decompLR_maybe _ = Nothing
-
-------------
-decompInst_maybe :: (Type, Type) -> Maybe ((TyVar,TyVar), (Type,Type))
-decompInst_maybe (ty1, ty2)
- | Just (tv1,r1) <- splitForAllTy_maybe ty1
- , Just (tv2,r2) <- splitForAllTy_maybe ty2
- = Just ((tv1,tv2), (r1,r2))
-decompInst_maybe _ = Nothing
-
-------------
-decompCsel_maybe :: (Type, Type) -> Maybe ((Type,Type), (Type,Type), (Type,Type))
--- If co :: (s1~t1 => r1) ~ (s2~t2 => r2)
--- Then csel1 co :: s1 ~ s2
--- csel2 co :: t1 ~ t2
--- cselR co :: r1 ~ r2
-decompCsel_maybe (ty1, ty2)
- | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1
- , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2
- = Just ((s1,s2), (t1,t2), (r1,r2))
-decompCsel_maybe _ = Nothing
-\end{code}
-
-
%************************************************************************
%* *
Newtypes
@@ -561,17 +662,14 @@ decompCsel_maybe _ = Nothing
%************************************************************************
\begin{code}
-instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI)
+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
-- ^ If @co :: T ts ~ rep_ty@ then:
--
-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
instNewTyCon_maybe tc tys
- | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc
+ | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc
= ASSERT( tys `lengthIs` tyConArity tc )
- Just (substTyWith tvs tys ty,
- case mb_co_tc of
- Nothing -> IdCo (mkTyConApp tc tys)
- Just co_tc -> ACo (mkTyConApp co_tc tys))
+ Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys)
| otherwise
= Nothing
@@ -588,270 +686,425 @@ splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)
splitNewTypeRepCo_maybe ty
| Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
splitNewTypeRepCo_maybe (TyConApp tc tys)
- | Just (ty', coi) <- instNewTyCon_maybe tc tys
- = case coi of
- ACo co -> Just (ty', co)
- IdCo _ -> panic "splitNewTypeRepCo_maybe"
+ | Just (ty', co) <- instNewTyCon_maybe tc tys
+ = case co of
+ Refl _ -> panic "splitNewTypeRepCo_maybe"
-- This case handled by coreView
+ _ -> Just (ty', co)
splitNewTypeRepCo_maybe _
= Nothing
-- | Determines syntactic equality of coercions
coreEqCoercion :: Coercion -> Coercion -> Bool
-coreEqCoercion = coreEqType
+coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2
+ where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2))
coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool
-coreEqCoercion2 = coreEqType2
-\end{code}
+coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2
+coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2)
+ = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22)
+ = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2)
+ = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2
+
+coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2)
+ = rnOccL env cv1 == rnOccR env cv2
+
+coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2)
+ = con1 == con2
+ && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22)
+ = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22
+
+coreEqCoercion2 env (SymCo co1) (SymCo co2)
+ = coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22)
+ = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2)
+ = d1 == d2 && coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2)
+ = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2
+coreEqCoercion2 _ _ _ = False
+\end{code}
%************************************************************************
%* *
- CoercionI and its constructors
-%* *
+ Substitution of coercions
+%* *
%************************************************************************
---------------------------------------
--- CoercionI smart constructors
--- lifted smart constructors of ordinary coercions
+\begin{code}
+-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when
+-- doing a \"lifting\" substitution)
+type CvSubstEnv = VarEnv Coercion
+
+emptyCvSubstEnv :: CvSubstEnv
+emptyCvSubstEnv = emptyVarEnv
+
+data CvSubst
+ = CvSubst InScopeSet -- The in-scope type variables
+ TvSubstEnv -- Substitution of types
+ CvSubstEnv -- Substitution of coercions
+
+instance Outputable CvSubst where
+ ppr (CvSubst ins tenv cenv)
+ = brackets $ sep[ ptext (sLit "CvSubst"),
+ nest 2 (ptext (sLit "In scope:") <+> ppr ins),
+ nest 2 (ptext (sLit "Type env:") <+> ppr tenv),
+ nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ]
+
+emptyCvSubst :: CvSubst
+emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+isEmptyCvSubst :: CvSubst -> Bool
+isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv
+
+getCvInScope :: CvSubst -> InScopeSet
+getCvInScope (CvSubst in_scope _ _) = in_scope
+
+zapCvSubstEnv :: CvSubst -> CvSubst
+zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv
+
+cvTvSubst :: CvSubst -> TvSubst
+cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs
+
+tvCvSubst :: TvSubst -> CvSubst
+tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv
+
+extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst
+extendTvSubst (CvSubst in_scope tenv cenv) tv ty
+ = CvSubst in_scope (extendVarEnv tenv tv ty) cenv
+
+substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar)
+substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var
+ = ASSERT( isCoVar old_var )
+ (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)
+ where
+ -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t)
+ -- In that case, mkCoVarCo will return a ReflCoercion, and
+ -- we want to substitute that (not new_var) for old_var
+ new_co = mkCoVarCo new_var
+ no_change = new_var == old_var && not (isReflCo new_co)
+
+ new_cenv | no_change = delVarEnv cenv old_var
+ | otherwise = extendVarEnv cenv old_var new_co
+
+ new_var = uniqAway in_scope subst_old_var
+ subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var))
+ -- It's important to do the substitution for coercions,
+ -- because only they can have free type variables
+
+substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+substTyVarBndr (CvSubst in_scope tenv cenv) old_var
+ = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of
+ (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var)
+
+zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst
+zipOpenCvSubst vs cos
+ | debugIsOn && (length vs /= length cos)
+ = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst
+ | otherwise
+ = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos)
+
+mkTopCvSubst :: [(Var,Coercion)] -> CvSubst
+mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs)
+
+substCoWithTy :: TyVar -> Type -> Coercion -> Coercion
+substCoWithTy tv ty = substCoWithTys [tv] [ty]
+
+substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion
+substCoWithTys tvs tys co
+ | debugIsOn && (length tvs /= length tys)
+ = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co
+ | otherwise
+ = ASSERT( length tvs == length tys )
+ substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co
+ where
+ in_scope = mkInScopeSet (tyVarsOfTypes tys)
+
+-- | Substitute within a 'Coercion'
+substCo :: CvSubst -> Coercion -> Coercion
+substCo subst co | isEmptyCvSubst subst = co
+ | otherwise = subst_co subst co
+
+-- | Substitute within several 'Coercion's
+substCos :: CvSubst -> [Coercion] -> [Coercion]
+substCos subst cos | isEmptyCvSubst subst = cos
+ | otherwise = map (substCo subst) cos
+
+substTy :: CvSubst -> Type -> Type
+substTy subst = Type.substTy (cvTvSubst subst)
+
+subst_co :: CvSubst -> Coercion -> Coercion
+subst_co subst co
+ = go co
+ where
+ go_ty :: Type -> Type
+ go_ty = Coercion.substTy subst
+
+ go :: Coercion -> Coercion
+ go (Refl ty) = Refl $! go_ty ty
+ go (TyConAppCo tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo tc args
+ go (AppCo co1 co2) = mkAppCo (go co1) $! go co2
+ go (ForAllCo tv co) = case substTyVarBndr subst tv of
+ (subst', tv') ->
+ ForAllCo tv' $! subst_co subst' co
+ go (CoVarCo cv) = substCoVar subst cv
+ go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos
+ go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2
+ go (SymCo co) = mkSymCo (go co)
+ go (TransCo co1 co2) = mkTransCo (go co1) (go co2)
+ go (NthCo d co) = mkNthCo d (go co)
+ go (InstCo co ty) = mkInstCo (go co) $! go_ty ty
+
+substCoVar :: CvSubst -> CoVar -> Coercion
+substCoVar (CvSubst in_scope _ cenv) cv
+ | Just co <- lookupVarEnv cenv cv = co
+ | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
+ | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv )
+ ASSERT( isCoVar cv ) CoVarCo cv
+
+substCoVars :: CvSubst -> [CoVar] -> [Coercion]
+substCoVars subst cvs = map (substCoVar subst) cvs
+
+lookupTyVar :: CvSubst -> TyVar -> Maybe Type
+lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv
+
+lookupCoVar :: CvSubst -> Var -> Maybe Coercion
+lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v
+\end{code}
+
+%************************************************************************
+%* *
+ "Lifting" substitution
+ [(TyVar,Coercion)] -> Type -> Coercion
+%* *
+%************************************************************************
\begin{code}
--- | 'CoercionI' represents a /lifted/ ordinary 'Coercion', in that it
--- can represent either one of:
---
--- 1. A proper 'Coercion'
+liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion
+liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos)
+
+-- | The \"lifting\" operation which substitutes coercions for type
+-- variables in a type to produce a coercion.
--
--- 2. The identity coercion
-data CoercionI = IdCo Type | ACo Coercion
+-- For the inverse operation, see 'liftCoMatch'
+liftCoSubst :: CvSubst -> Type -> Coercion
+-- The CvSubst maps TyVar -> Type (mainly for cloning foralls)
+-- TyVar -> Coercion (this is the payload)
+-- The unusual thing is that the *coercion* substitution maps
+-- some *type* variables. That's the whole point of this function!
+liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty
+ | otherwise = ty_co_subst subst ty
+
+ty_co_subst :: CvSubst -> Type -> Coercion
+ty_co_subst subst ty
+ = go ty
+ where
+ go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv)
+ go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2)
+ go (TyConApp tc tys) = mkTyConAppCo tc (map go tys)
+ go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2)
+ go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty)
+ where
+ (subst', v') = liftCoSubstTyVarBndr subst v
+ go (PredTy p) = mkPredCo (go <$> p)
+
+liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion
+liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv
+ = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of
+ (Nothing, Nothing) -> Nothing
+ (Just ty, Nothing) -> Just (Refl ty)
+ (Nothing, Just co) -> Just co
+ (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst)
+
+liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var
+ = (CvSubst (in_scope `extendInScopeSet` new_var)
+ new_tenv
+ (delVarEnv cenv old_var) -- See Note [Lifting substitutions]
+ , new_var)
+ where
+ new_tenv | no_change = delVarEnv tenv old_var
+ | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
+
+ no_change = new_var == old_var
+ new_var = uniqAway in_scope old_var
+\end{code}
-liftCoI :: (Type -> Type) -> CoercionI -> CoercionI
-liftCoI f (IdCo ty) = IdCo (f ty)
-liftCoI f (ACo ty) = ACo (f ty)
+Note [Lifting substitutions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider liftCoSubstWith [a] [co] (a, forall a. a)
+Then we want to substitute for the free 'a', but obviously not for
+the bound 'a'. hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr.
-liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI
-liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2)
-liftCoI2 f coi1 coi2 = ACo (f (fromCoI coi1) (fromCoI coi2))
+This also why we need a full CvSubst when doing lifting substitutions.
-liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI
-liftCoIs f cois = go_id [] cois
+\begin{code}
+-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if
+-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@.
+-- That is, it matches a type against a coercion of the same
+-- "shape", and returns a lifting substitution which could have been
+-- used to produce the given coercion from the given type.
+liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst
+liftCoMatch tmpls ty co
+ = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of
+ Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env)
+ Nothing -> Nothing
where
- go_id rev_tys [] = IdCo (f (reverse rev_tys))
- go_id rev_tys (IdCo ty : cois) = go_id (ty:rev_tys) cois
- go_id rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois
-
- go_aco rev_tys [] = ACo (f (reverse rev_tys))
- go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois
- go_aco rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois
-
-instance Outputable CoercionI where
- ppr (IdCo _) = ptext (sLit "IdCo")
- ppr (ACo co) = ppr co
-
-isIdentityCoI :: CoercionI -> Bool
-isIdentityCoI (IdCo _) = True
-isIdentityCoI (ACo _) = False
-
--- | Return either the 'Coercion' contained within the 'CoercionI' or the given
--- 'Type' if the 'CoercionI' is the identity 'Coercion'
-fromCoI :: CoercionI -> Type
-fromCoI (IdCo ty) = ty -- Identity coercion represented
-fromCoI (ACo co) = co -- by the type itself
-
--- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion'
-mkSymCoI :: CoercionI -> CoercionI
-mkSymCoI (IdCo ty) = IdCo ty
-mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co]
- -- the smart constructor
- -- is too smart with tyvars
-
--- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion'
-mkTransCoI :: CoercionI -> CoercionI -> CoercionI
-mkTransCoI (IdCo _) aco = aco
-mkTransCoI aco (IdCo _) = aco
-mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
-
--- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion'
-mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI
-mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois
-
--- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion'
-mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkAppTyCoI = liftCoI2 mkAppTy
-
-mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkFunTyCoI = liftCoI2 mkFunTy
-
--- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion'
-mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
-mkForAllTyCoI tv = liftCoI (ForAllTy tv)
-
--- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies:
---
--- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois))
-mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI
-mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls)
+ menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }
+ in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)
+ -- Like tcMatchTy, assume all the interesting variables
+ -- in ty are in tmpls
+
+type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv)
+ -- Used locally inside ty_co_match only
+
+-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.
+ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv
+ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co
+
+ -- Deal with the Refl case by delegating to type matching
+ty_co_match menv (tenv, cenv) ty co
+ | Just ty' <- isReflCo_maybe co
+ = case ruleMatchTyX ty_menv tenv ty ty' of
+ Just tenv' -> Just (tenv', cenv)
+ Nothing -> Nothing
+ where
+ ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv }
+ -- Remove from the template set any variables already bound to non-refl coercions
+
+ -- Match a type variable against a non-refl coercion
+ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co
+ | Just {} <- lookupVarEnv tenv tv1' -- tv1' is already bound to (Refl ty)
+ = Nothing -- The coercion 'co' is not Refl
+
+ | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1
+ = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co
+ then Just subst
+ else Nothing -- no match since tv1 matches two different coercions
+
+ | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var
+ = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co))
+ then Nothing -- occurs check failed
+ else return (tenv, extendVarEnv cenv tv1' co)
+ -- BAY: I don't think we need to do any kind matching here yet
+ -- (compare 'match'), but we probably will when moving to SHE.
+
+ | otherwise -- tv1 is not a template ty var, so the only thing it
+ -- can match is a reflexivity coercion for itself.
+ -- But that case is dealt with already
+ = Nothing
--- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI
-mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn)
+ where
+ rn_env = me_env menv
+ tv1' = rnOccL rn_env tv1
--- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI
-mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2))
+ty_co_match menv subst (AppTy ty1 ty2) co
+ | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy
+ = do { subst' <- ty_co_match menv subst ty1 co1
+ ; ty_co_match menv subst' ty2 co2 }
-mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI
-mkCoPredCoI coi1 coi2 coi3 = mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3
+ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos)
+ | tc1 == tc2 = ty_co_matches menv subst tys cos
+ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos)
+ | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos
+ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co)
+ = ty_co_match menv' subst ty co
+ where
+ menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 }
+
+ty_co_match _ _ _ _ = Nothing
+
+ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv
+ty_co_matches menv = matchList (ty_co_match menv)
\end{code}
%************************************************************************
%* *
- The kind of a type, and of a coercion
+ Sequencing on coercions
%* *
%************************************************************************
\begin{code}
-typeKind :: Type -> Kind
-typeKind ty@(TyConApp tc tys)
- | isCoercionTyCon tc = typeKind (fst (coercionKind ty))
- | otherwise = kindAppResult (tyConKind tc) tys
- -- During coercion optimisation we *do* match a type
- -- against a coercion (see OptCoercion.matchesAxiomLhs)
- -- So the use of typeKind in Unify.match_kind must work on coercions too
- -- Hence the isCoercionTyCon case above
-
-typeKind (PredTy pred) = predKind pred
-typeKind (AppTy fun _) = kindFunResult (typeKind fun)
-typeKind (ForAllTy _ ty) = typeKind ty
-typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (FunTy _arg res)
- -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
- -- not unliftedTypKind (#)
- -- The only things that can be after a function arrow are
- -- (a) types (of kind openTypeKind or its sub-kinds)
- -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
- | isTySuperKind k = k
- | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
- where
- k = typeKind res
+seqCo :: Coercion -> ()
+seqCo (Refl ty) = seqType ty
+seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos
+seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (ForAllCo tv co) = tv `seq` seqCo co
+seqCo (CoVarCo cv) = cv `seq` ()
+seqCo (AxiomInstCo con cos) = con `seq` seqCos cos
+seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2
+seqCo (SymCo co) = seqCo co
+seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (NthCo _ co) = seqCo co
+seqCo (InstCo co ty) = seqCo co `seq` seqType ty
+
+seqCos :: [Coercion] -> ()
+seqCos [] = ()
+seqCos (co:cos) = seqCo co `seq` seqCos cos
+\end{code}
-------------------
-predKind :: PredType -> Kind
-predKind (EqPred {}) = coSuperKind -- A coercion kind!
-predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are
-predKind (IParam {}) = liftedTypeKind -- always represented by lifted types
+
+%************************************************************************
+%* *
+ The kind of a type, and of a coercion
+%* *
+%************************************************************************
+
+\begin{code}
+coercionType :: Coercion -> Type
+coercionType co = case coercionKind co of
+ Pair ty1 ty2 -> mkCoType ty1 ty2
------------------
-- | If it is the case that
--
-- > c :: (t1 ~ t2)
--
--- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@,
--- then @coercionKind c = (t1, t2)@.
-coercionKind :: Coercion -> (Type, Type)
-coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a
- | otherwise = (ty, ty)
-coercionKind (AppTy ty1 ty2)
- = let (s1, t1) = coercionKind ty1
- (s2, t2) = coercionKind ty2 in
- (mkAppTy s1 s2, mkAppTy t1 t2)
-coercionKind co@(TyConApp tc args)
- | Just (ar, desc) <- isCoercionTyCon_maybe tc
- -- CoercionTyCons carry their kinding rule, so we use it here
- = WARN( not (length args >= ar), ppr co ) -- Always saturated
- (let (ty1, ty2) = coTyConAppKind desc (take ar args)
- (tys1, tys2) = coercionKinds (drop ar args)
- in (mkAppTys ty1 tys1, mkAppTys ty2 tys2))
-
- | otherwise
- = let (lArgs, rArgs) = coercionKinds args in
- (TyConApp tc lArgs, TyConApp tc rArgs)
-
-coercionKind (FunTy ty1 ty2)
- = let (t1, t2) = coercionKind ty1
- (s1, s2) = coercionKind ty2 in
- (mkFunTy t1 s1, mkFunTy t2 s2)
-
-coercionKind (ForAllTy tv ty)
- | isCoVar tv
--- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2
--- ----------------------------------------------
--- c1~c2 => c3 :: (s1~t1) => r1 ~ (s2~t2) => r2
--- or
--- forall (_:c1~c2)
- = let (c1,c2) = coVarKind tv
- (s1,s2) = coercionKind c1
- (t1,t2) = coercionKind c2
- (r1,r2) = coercionKind ty
- in
- (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2)
-
- | otherwise
--- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2
--- ----------------------------------------------
--- forall a:k. c :: forall a:k. t1 ~ forall a:k. t2
- = let (ty1, ty2) = coercionKind ty in
- (ForAllTy tv ty1, ForAllTy tv ty2)
-
-coercionKind (PredTy (ClassP cl args))
- = let (lArgs, rArgs) = coercionKinds args in
- (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs))
-coercionKind (PredTy (IParam name ty))
- = let (ty1, ty2) = coercionKind ty in
- (PredTy (IParam name ty1), PredTy (IParam name ty2))
-coercionKind (PredTy (EqPred c1 c2))
- = pprTrace "coercionKind" (pprEqPred (c1,c2)) $
- -- These should not show up in coercions at all
- -- becuase they are in the form of for-alls
- let k1 = coercionKindPredTy c1
- k2 = coercionKindPredTy c2 in
- (k1,k2)
- where
- coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2
+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
+coercionKind :: Coercion -> Pair Type
+coercionKind (Refl ty) = Pair ty ty
+coercionKind (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map coercionKind cos)
+coercionKind (AppCo co1 co2) = mkAppTy <$> coercionKind co1 <*> coercionKind co2
+coercionKind (ForAllCo tv co) = mkForAllTy tv <$> coercionKind co
+coercionKind (CoVarCo cv) = ASSERT( isCoVar cv ) toPair $ coVarKind cv
+coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos
+ in Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax))
+ (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
+coercionKind (UnsafeCo ty1 ty2) = Pair ty1 ty2
+coercionKind (SymCo co) = swap $ coercionKind co
+coercionKind (TransCo co1 co2) = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2)
+coercionKind (NthCo d co) = getNth d <$> coercionKind co
+coercionKind co@(InstCo aco ty) | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco
+ = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks
+ | otherwise = pprPanic "coercionKind" (ppr co)
-------------------
-- | Apply 'coercionKind' to multiple 'Coercion's
-coercionKinds :: [Coercion] -> ([Type], [Type])
-coercionKinds tys = unzip $ map coercionKind tys
+coercionKinds :: [Coercion] -> Pair [Type]
+coercionKinds tys = sequenceA $ map coercionKind tys
-------------------
--- | 'coTyConAppKind' is given a list of the type arguments to the 'CoTyCon',
--- and constructs the types that the resulting coercion relates.
--- Fails (in the monad) if ill-kinded.
--- Typically the monad is
--- either the Lint monad (with the consistency-check flag = True),
--- or the ID monad with a panic on failure (and the consistency-check flag = False)
-coTyConAppKind
- :: CoTyConDesc
- -> [Type] -- Exactly right number of args
- -> (Type, Type) -- Kind of this application
-coTyConAppKind CoUnsafe (ty1:ty2:_)
- = (ty1,ty2)
-coTyConAppKind CoSym (co:_)
- | (ty1,ty2) <- coercionKind co = (ty2,ty1)
-coTyConAppKind CoTrans (co1:co2:_)
- = (fst (coercionKind co1), snd (coercionKind co2))
-coTyConAppKind CoLeft (co:_)
- | Just (res,_) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoRight (co:_)
- | Just (_,res) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoCsel1 (co:_)
- | Just (res,_,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCsel2 (co:_)
- | Just (_,res,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCselR (co:_)
- | Just (_,_,res) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoInst (co:ty:_)
- | Just ((tv1,tv2), (ty1,ty2)) <- decompInst_maybe (coercionKind co)
- = (substTyWith [tv1] [ty] ty1, substTyWith [tv2] [ty] ty2)
-coTyConAppKind (CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
- = (substTyWith tvs tys1 lhs_ty, substTyWith tvs tys2 rhs_ty)
- where
- (tys1, tys2) = coercionKinds cos
-coTyConAppKind desc cos = pprTrace "coTyConAppKind" (ppr desc $$ braces (vcat
- [ ppr co <+> dcolon <+> pprEqPred (coercionKind co)
- | co <- cos ])) $
- coercionKind (head cos)
+getNth :: Int -> Type -> Type
+getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty
+ = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
+getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty)
\end{code}
+
+\begin{code}
+applyCo :: Type -> Coercion -> Type
+-- Gives the type of (e co) where e :: (a~b) => ty
+applyCo ty co | Just ty' <- coreView ty = applyCo ty' co
+applyCo (FunTy _ ty) _ = ty
+applyCo _ _ = panic "applyCo"
+\end{code}
\ No newline at end of file
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 93a67a7eddc17417e9ed7fb1fed3c0c8039d5cc5..5b4374afa2e834cad5c9f283e805baf5d82a4462 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -29,7 +29,6 @@ import TypeRep
import TyCon
import Coercion
import VarSet
-import Var
import Name
import UniqFM
import Outputable
@@ -85,7 +84,12 @@ instance Outputable FamInst where
pprFamInst :: FamInst -> SDoc
pprFamInst famInst
= hang (pprFamInstHdr famInst)
- 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
+ 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax)
+ , ptext (sLit "--") <+> pprNameLoc (getName famInst)])
+ where
+ pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of
+ Just ax -> ppr ax
+ Nothing -> ptext (sLit "<not there!>")
pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_tycon = rep_tc})
@@ -303,7 +307,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
-- anything else would be difficult to test for at this stage.
conflicting old_fam_inst subst
| isAlgTyCon fam = True
- | otherwise = not (old_rhs `tcEqType` new_rhs)
+ | otherwise = not (old_rhs `eqType` new_rhs)
where
old_tycon = famInstTyCon old_fam_inst
old_tvs = tyConTyVars old_tycon
@@ -439,35 +443,34 @@ topNormaliseType env ty
go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
- go rec_nts (TyConApp tc tys) -- Expand newtypes
- | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
- = if tc `elem` rec_nts -- in Type.lhs
+ go rec_nts (TyConApp tc tys)
+ | isNewTyCon tc -- Expand newtypes
+ = if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs
then Nothing
- else let nt_co = mkTyConApp co_con tys
- in add_co nt_co rec_nts' nt_rhs
- where
- nt_rhs = newTyConInstRhs tc tys
- rec_nts' | isRecursiveTyCon tc = tc:rec_nts
- | otherwise = rec_nts
-
- go rec_nts (TyConApp tc tys) -- Expand open tycons
- | isFamilyTyCon tc
- , (ACo co, ty) <- normaliseTcApp env tc tys
- = -- The ACo says "something happened"
- -- Note that normaliseType fully normalises, but it has do to so
- -- to be sure that
- add_co co rec_nts ty
+ else let nt_co = mkAxInstCo (newTyConCo tc) tys
+ in add_co nt_co rec_nts' nt_rhs
+
+ | isFamilyTyCon tc -- Expand open tycons
+ , (co, ty) <- normaliseTcApp env tc tys
+ -- Note that normaliseType fully normalises,
+ -- but it has do to so to be sure that
+ , not (isReflCo co)
+ = add_co co rec_nts ty
+ where
+ nt_rhs = newTyConInstRhs tc tys
+ rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+ | otherwise = rec_nts
go _ _ = Nothing
add_co co rec_nts ty
= case go rec_nts ty of
Nothing -> Just (co, ty)
- Just (co', ty') -> Just (mkTransCoercion co co', ty')
+ Just (co', ty') -> Just (mkTransCo co co', ty')
---------------
-normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
+normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type)
normaliseTcApp env tc tys
| isFamilyTyCon tc
, tyConArity tc <= length tys -- Unsaturated data families are possible
@@ -475,29 +478,30 @@ normaliseTcApp env tc tys
= let -- A matching family instance exists
rep_tc = famInstTyCon fam_inst
co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
- co = mkTyConApp co_tycon inst_tys
- first_coi = mkTransCoI tycon_coi (ACo co)
- (rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
- fix_coi = mkTransCoI first_coi rest_coi
+ co = mkAxInstCo co_tycon inst_tys
+ first_coi = mkTransCo tycon_coi co
+ (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
+ fix_coi = mkTransCo first_coi rest_coi
in
(fix_coi, nty)
- | otherwise
+ | otherwise -- No unique matching family instance exists;
+ -- we do not do anything
= (tycon_coi, TyConApp tc ntys)
where
-- Normalise the arg types so that they'll match
-- when we lookup in in the instance envt
(cois, ntys) = mapAndUnzip (normaliseType env) tys
- tycon_coi = mkTyConAppCoI tc cois
+ tycon_coi = mkTyConAppCo tc cois
---------------
normaliseType :: FamInstEnvs -- environment with family instances
-> Type -- old type
- -> (CoercionI, Type) -- (coercion,new type), where
+ -> (Coercion, Type) -- (coercion,new type), where
-- co :: old-type ~ new_type
-- Normalise the input type, by eliminating *all* type-function redexes
--- Returns with IdCo if nothing happens
+-- Returns with Refl if nothing happens
normaliseType env ty
| Just ty' <- coreView ty = normaliseType env ty'
@@ -506,29 +510,29 @@ normaliseType env (TyConApp tc tys)
normaliseType env (AppTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2)
+ in (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
normaliseType env (FunTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2)
+ in (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
normaliseType env (ForAllTy tyvar ty1)
= let (coi,nty1) = normaliseType env ty1
- in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
+ in (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
normaliseType _ ty@(TyVarTy _)
- = (IdCo ty,ty)
+ = (Refl ty,ty)
normaliseType env (PredTy predty)
= normalisePred env predty
---------------
-normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
+normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type)
normalisePred env (ClassP cls tys)
- = let (cois,tys') = mapAndUnzip (normaliseType env) tys
- in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
+ = let (cos,tys') = mapAndUnzip (normaliseType env) tys
+ in (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys')
normalisePred env (IParam ipn ty)
- = let (coi,ty') = normaliseType env ty
- in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
+ = let (co,ty') = normaliseType env ty
+ in (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty')
normalisePred env (EqPred ty1 ty2)
- = let (coi1,ty1') = normaliseType env ty1
- (coi2,ty2') = normaliseType env ty2
- in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
+ = let (co1,ty1') = normaliseType env ty1
+ (co2,ty2') = normaliseType env ty2
+ in (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2')
\end{code}
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 6ce932bfe356a0c902d23485add4387bb4ef85fb..f1c934717e0ec7a94789e4d8bd3625099bbaab80 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -271,8 +271,8 @@ improveFromAnother pred1@(ClassP cls1 tys1, _) pred2@(ClassP cls2 tys2, _)
, fd <- cls_fds
, let (ltys1, rs1) = instFD fd cls_tvs tys1
(ltys2, irs2) = instFD_WithPos fd cls_tvs tys2
- , tcEqTypes ltys1 ltys2 -- The LHSs match
- , let eqs = zipAndComputeFDEqs tcEqType rs1 irs2
+ , eqTypes ltys1 ltys2 -- The LHSs match
+ , let eqs = zipAndComputeFDEqs eqType rs1 irs2
, not (null eqs) ]
improveFromAnother _ _ = []
@@ -386,7 +386,7 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2'
-- Don't discard anything!
-- We could discard equal types but it's an overkill to call
- -- tcEqType again, since we know for sure that /at least one/
+ -- eqType again, since we know for sure that /at least one/
-- equation in there is useful)
qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs
diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 604db8d2d9594d50da71c94bb38883e0fbab2014..323da41d66a4b54cb24a6e6937e5b515b8b34898 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -1,18 +1,12 @@
%
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2011
%
\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
-
-module Generics ( canDoGenerics, mkTyConGenericBinds,
- mkGenericRhs,
- validGenericInstanceType, validGenericMethodType
+
+module Generics ( canDoGenerics,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
+ MetaTyCons(..), metaTyCons2TyCons
) where
@@ -22,17 +16,20 @@ import TcType
import DataCon
import TyCon
-import Name
+import Name hiding (varName)
+import Module (moduleName, moduleNameString)
import RdrName
import BasicTypes
-import Var
-import VarSet
-import Id
import TysWiredIn
import PrelNames
-
+
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad
+import HscTypes
+import BuildTyCl
+
import SrcLoc
-import Util
import Bag
import Outputable
import FastString
@@ -40,185 +37,6 @@ import FastString
#include "HsVersions.h"
\end{code}
-Roadmap of what's where in the Generics work.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Parser
-No real checks.
-
-RnSource.rnHsType
- Checks that HsNumTy has a "1" in it.
-
-TcInstDcls.mkGenericInstance:
- Checks for invalid type patterns, such as f {| Int |}
-
-TcClassDcl.tcClassSig
- Checks for a method type that is too complicated;
- e.g. has for-alls or lists in it
- We could lift this restriction
-
-TcClassDecl.mkDefMethRhs
- Checks that the instance type is simple, in an instance decl
- where we let the compiler fill in a generic method.
- e.g. instance C (T Int)
- is not valid if C has generic methods.
-
-TcClassDecl.checkGenericClassIsUnary
- Checks that we don't have generic methods in a multi-parameter class
-
-TcClassDecl.checkDefaultBinds
- Checks that all the equations for a method in a class decl
- are generic, or all are non-generic
-
-
-
-Checking that the type constructors which are present in Generic
-patterns (not Unit, this is done differently) is done in mk_inst_info
-(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
-HsOpTy is tied to Generic definitions which is not a very good design
-feature, indeed a bug. However, the check is easy to move from
-tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5. [I don't think that this is the case anymore after SPJ's latest
-changes in that regard. Delete this comment? -=chak/7Jun2]
-
-Generics.lhs
-
-Making generic information to put into a tycon. Constructs the
-representation type, which, I think, are not used later. Perhaps it is
-worth removing them from the GI datatype. Although it does get used in
-the construction of conversion functions (internally).
-
-TyCon.lhs
-
-Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
-
-TysWiredIn.lhs
-
-Defines generic and other type and data constructors.
-
-This is sadly incomplete, but will be added to.
-
-
-Bugs & shortcomings of existing implementation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-2. Another pretty big bug I dscovered at the last minute when I was
-testing the code is that at the moment the type variable of the class
-is scoped over the entire declaration, including the patterns. For
-instance, if I have the following code,
-
-class Er a where
- ...
- er {| Plus a b |} (Inl x) (Inl y) = er x y
- er {| Plus a b |} (Inr x) (Inr y) = er x y
- er {| Plus a b |} _ _ = False
-
-and I print out the types of the generic patterns, I get the
-following. Note that all the variable names for "a" are the same,
-while for "b" they are all different.
-
-check_ty
- [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
-
-This is a bug as if I change the code to
-
- er {| Plus c b |} (Inl x) (Inl y) = er x y
-
-all the names come out to be different.
-
-Thus, all the types (Plus a b) come out to be different, so I cannot
-compare them and test whether they are all the same and thus cannot
-return an error if the type variables are different.
-
-Temporary fix/hack. I am not checking for this, I just assume they are
-the same, see line "check_ty = True" in TcInstDecls. When we resolve
-the issue with variables, though - I assume that we will make them to
-be the same in all the type patterns, jus uncomment the check and
-everything should work smoothly.
-
-Hence, I have also left the rather silly construction of:
-* extracting all the type variables from all the types
-* putting them *all* into the environment
-* typechecking all the types
-* selecting one of them and using it as the instance_ty.
-
-(the alternative is to make sure that all the types are the same,
-taking one, extracting its variables, putting them into the environment,
-type checking it, using it as the instance_ty)
-
-6. What happens if we do not supply all of the generic patterns? At
-the moment, the compiler crashes with an error message "Non-exhaustive
-patterns in a generic declaration"
-
-
-What has not been addressed:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Contexts. In the generated instance declarations for the 3 primitive
-type constructors, we need contexts. It is unclear what those should
-be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
-
-Type application. We have type application in expressions
-(essentially) on the lhs of an equation. Do we want to allow it on the
-RHS?
-
-Scoping of type variables in a generic definition. At the moment, (see
-TcInstDecls) we extract the type variables inside the type patterns
-and add them to the environment. See my bug #2 above. This seems pretty
-important.
-
-
-
-%************************************************************************
-%* *
-\subsection{Getting the representation type out}
-%* *
-%************************************************************************
-
-\begin{code}
-validGenericInstanceType :: Type -> Bool
- -- Checks for validity of the type pattern in a generic
- -- declaration. It's ok to have
- -- f {| a + b |} ...
- -- but it's not OK to have
- -- f {| a + Int |}
-
-validGenericInstanceType inst_ty
- = case tcSplitTyConApp_maybe inst_ty of
- Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
- Nothing -> False
-
-validGenericMethodType :: Type -> Bool
- -- At the moment we only allow method types built from
- -- * type variables
- -- * function arrow
- -- * boxed tuples
- -- * lists
- -- * an arbitrary type not involving the class type variables
- -- e.g. this is ok: forall b. Ord b => [b] -> a
- -- where a is the class variable
-validGenericMethodType ty
- = valid tau
- where
- (local_tvs, _, tau) = tcSplitSigmaTy ty
-
- valid ty
- | not (isTauTy ty) = False -- Note [Higher ramk methods]
- | isTyVarTy ty = True
- | no_tyvars_in_ty = True
- | otherwise = case tcSplitTyConApp_maybe ty of
- Just (tc,tys) -> valid_tycon tc && all valid tys
- Nothing -> False
- where
- no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-
- valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
- -- Compare bimapApp, below
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Generating representation types}
@@ -226,25 +44,47 @@ validGenericMethodType ty
%************************************************************************
\begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
-- Called on source-code data types, to see if we should generate
--- generic functions for them. (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics data_cons
- = not (any bad_con data_cons) -- See comment below
- && not (null data_cons) -- No values of the type
+-- generic functions for them.
+-- Nothing == yes
+-- Just s == no, because of `s`
+
+canDoGenerics tycon
+ = mergeErrors (
+ -- We do not support datatypes with context
+ (if (not (null (tyConStupidTheta tycon)))
+ then (Just (ppr tycon <+> text "must not have a datatype context"))
+ else Nothing)
+ -- We don't like type families
+ : (if (isFamilyTyCon tycon)
+ then (Just (ppr tycon <+> text "must not be a family instance"))
+ else Nothing)
+ -- See comment below
+ : (map bad_con (tyConDataCons tycon)))
where
- bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
- -- If any of the constructor has an unboxed type as argument,
- -- then we can't build the embedding-projection pair, because
- -- it relies on instantiating *polymorphic* sum and product types
- -- at the argument types of the constructors
+ -- If any of the constructor has an unboxed type as argument,
+ -- then we can't build the embedding-projection pair, because
+ -- it relies on instantiating *polymorphic* sum and product types
+ -- at the argument types of the constructors
+ bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+ then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+ else (if (not (isVanillaDataCon dc))
+ then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+ else Nothing)
+
-- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+
+ mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+ mergeErrors [] = Nothing
+ mergeErrors ((Just s):t) = case mergeErrors t of
+ Nothing -> Just s
+ Just s' -> Just (s <> text ", and" $$ s')
+ mergeErrors (Nothing :t) = mergeErrors t
\end{code}
%************************************************************************
@@ -255,320 +95,302 @@ canDoGenerics data_cons
\begin{code}
type US = Int -- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
+type Alt = (LPat RdrName, LHsExpr RdrName)
-mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon
- = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
- `unionBags`
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon =
+ unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+ `unionBags`
unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+ where
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
+ loc = srcLocSpan (getSrcLoc tycon)
+ datacons = tyConDataCons tycon
+
+ -- Recurse over the sum first
+ from_alts, to_alts :: [Alt]
+ (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
+
+--------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+-- type instance Rep (D a b) = Rep_D a b
+-- type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon -- The type to generate representation for
+ -> MetaTyCons -- Metadata datatypes to refer to
+ -> TcM TyCon -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts =
+-- Consider the example input tycon `D`, where data D a b = D_ a
+ do { -- `rep0` = GHC.Generics.Rep (type family)
+ rep0 <- tcLookupTyCon repTyConName
+
+ -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+ ; rep0Ty <- tc_mkRepTy tycon metaDts
+
+ -- `rep_name` is a name we generate for the synonym
+ ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+ ; let -- `tyvars` = [a,b]
+ tyvars = tyConTyVars tycon
+
+ -- rep0Ty has kind * -> *
+ rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+ ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+ NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRepTy :: -- The type to generate representation for
+ TyCon
+ -- Metadata datatypes to refer to
+ -> MetaTyCons
+ -- Generated representation0 type
+ -> TcM Type
+tc_mkRepTy tycon metaDts =
+ do
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ par0 <- tcLookupTyCon par0TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
+ times <- tcLookupTyCon prodTyConName
+
+ let mkSum' a b = mkTyConApp plus [a,b]
+ mkProd a b = mkTyConApp times [a,b]
+ mkRec0 a = mkTyConApp rec0 [a]
+ mkPar0 a = mkTyConApp par0 [a]
+ mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ (null (dataConFieldLabels a))]
+ -- This field has no label
+ mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+ -- This field has a label
+ mkS False d a = mkTyConApp s1 [d, a]
+
+ sumP [] = mkTyConTy v1
+ sumP l = ASSERT (length metaCTyCons == length l)
+ foldBal mkSum' [ mkC i d a
+ | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+ -- The Bool is True if this constructor has labelled fields
+ prod :: Int -> [Type] -> Bool -> Type
+ prod i [] _ = ASSERT (length metaSTyCons > i)
+ ASSERT (length (metaSTyCons !! i) == 0)
+ mkTyConTy u1
+ prod i l b = ASSERT (length metaSTyCons > i)
+ ASSERT (length l == length (metaSTyCons !! i))
+ foldBal mkProd [ arg d t b
+ | (d,t) <- zip (metaSTyCons !! i) l ]
+
+ arg :: Type -> Type -> Bool -> Type
+ arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+ -- Argument is not a type variable, use Rec0
+ recOrPar t Nothing = mkRec0 t
+ -- Argument is a type variable, use Par0
+ recOrPar t (Just _) = mkPar0 t
+
+ metaDTyCon = mkTyConTy (metaD metaDts)
+ metaCTyCons = map mkTyConTy (metaC metaDts)
+ metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+
+ return (mkD tycon)
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+ metaD :: TyCon
+ -- One meta datatype per constructor
+ , metaC :: [TyCon]
+ -- One meta datatype per selector per constructor
+ , metaS :: [[TyCon]] }
+
+instance Outputable MetaTyCons where
+ ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
+
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon
+ -> ( LHsBinds RdrName -- Datatype instance
+ , [LHsBinds RdrName] -- Constructor instances
+ , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+ where
+ mkBag l = foldr1 unionBags
+ [ unitBag (L loc (mkFunBind (L loc name) matches))
+ | (name, matches) <- l ]
+ dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
+ , (moduleName_RDR, moduleName_matches)]
+
+ allConBinds = map conBinds datacons
+ conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
+ ++ ifElseEmpty (dataConIsInfix c)
+ [ (conFixity_RDR, conFixity_matches c) ]
+ ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+ [ (conIsRecord_RDR, conIsRecord_matches c) ]
+ )
+
+ ifElseEmpty p x = if p then x else []
+ fixity c = case lookupFixity fix_env (dataConName c) of
+ Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+ Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+ Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+ buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+ , nlHsIntLit (toInteger n)]
+
+ allSelBinds = map (map selBinds) datasels
+ selBinds s = mkBag [(selName_RDR, selName_matches s)]
+
+ loc = srcLocSpan (getSrcLoc tycon)
+ mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+ datacons = tyConDataCons tycon
+ datasels = map dataConFieldLabels datacons
+
+ dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
+ $ tycon
+ moduleName_matches = mkStringLHS . moduleNameString . moduleName
+ . nameModule . tyConName $ tycon
+
+ conName_matches c = mkStringLHS . showPpr . nameOccName
+ . dataConName $ c
+ conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
+ conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+ selName_matches s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: US -- Base for generating unique names
+ -> TyCon -- The type constructor
+ -> [DataCon] -- The data constructors
+ -> ([Alt], -- Alternatives for the T->Trep "from" function
+ [Alt]) -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _us tycon [] = ([from_alt], [to_alt])
+ where
+ from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
+ to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
+ -- These M1s are meta-information for the datatype
+ makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
+ errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
+ errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+ unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: US -- Base for generating unique names
+ -> Int -- The index of this constructor
+ -> Int -- Total number of constructors
+ -> DataCon -- The data constructor
+ -> (Alt, -- Alternative for the T->Trep "from" function
+ Alt) -- Alternative for the Trep->T "to" function
+mk1Sum us i n datacon = (from_alt, to_alt)
where
- from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
- to_matches = [mkSimpleHsAlt to_pat to_body]
- loc = srcLocSpan (getSrcLoc tycon)
- datacons = tyConDataCons tycon
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Recurse over the sum first
- from_alts :: [FromAlt]
- (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
- init_us = 1::Int -- Unique supply
-
-----------------------------------------------------
--- Dealing with sums
-----------------------------------------------------
-
-mk_sum_stuff :: US -- Base for generating unique names
- -> [DataCon] -- The data constructors
- -> ([FromAlt], -- Alternatives for the T->Trep "from" function
- InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
-
--- For example, given
--- data T = C | D Int Int Int
---
--- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
--- case cd of { Inl u -> C;
--- Inr abc -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- D a b c }} },
--- cd)
-
-mk_sum_stuff us [datacon]
- = ([from_alt], to_pat, to_body_fn app_exp)
- where
- n_args = dataConSourceArity datacon -- Existentials already excluded
-
- datacon_vars = map mkGenericLocal [us .. us+n_args-1]
- us' = us + n_args
-
- datacon_rdr = getRdrName datacon
- app_exp = nlHsVarApps datacon_rdr datacon_vars
- from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-
- (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
-
-mk_sum_stuff us datacons
- = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
- nlVarPat to_arg,
- noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
- mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
+ n_args = dataConSourceArity datacon -- Existentials already excluded
+
+ datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+ us' = us + n_args
+
+ datacon_rdr = getRdrName datacon
+ app_exp = nlHsVarApps datacon_rdr datacon_vars
+
+ from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+ from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
+
+ to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+ -- These M1s are meta-information for the datatype
+ to_alt_rhs = app_exp
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
+genLR_P i n p
+ | n == 0 = error "impossible"
+ | n == 1 = p
+ | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
+ | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
+ where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
+genLR_E i n e
+ | n == 0 = error "impossible"
+ | n == 1 = e
+ | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
+ | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
+ where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: US -- Base for unique names
+ -> [RdrName] -- List of variables matched on the lhs
+ -> LHsExpr RdrName -- Resulting product expression
+mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E _ vars = mkM1_E (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- (l_datacons, r_datacons) = splitInHalf datacons
- (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
- (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
-
- to_arg = mkGenericLocal us
- us' = us+1
-
- wrap :: RdrName -> [FromAlt] -> [FromAlt]
- -- Wrap an application of the Inl or Inr constructor round each alternative
- wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
-
-
-----------------------------------------------------
--- Dealing with products
-----------------------------------------------------
-mk_prod_stuff :: US -- Base for unique names
- -> [RdrName] -- arg-ids; args of the original user-defined constructor
- -- They are bound enclosing from_rhs
- -- Please bind these in the to_body_fn
- -> (US, -- Depleted unique-name supply
- LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
- InPat RdrName, -- to_pat:
- LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
-
--- For example:
--- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
--- abc,
--- \<body-code> -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- <body-code> )
-
--- We need to use different uniques in the branches
--- because the returned to_body_fns are nested.
--- Hence the returned unqique-name supply
-
-mk_prod_stuff us [] -- Unit case
- = (us+1,
- nlHsVar genUnitDataCon_RDR,
- noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
- (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
- -- Give a signature to the pattern so we get
- -- data S a = Nil | S a
- -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
- -- Inr x -> S x }
- -- The (:: Unit) signature ensures that we'll infer the right
- -- type for toS. If we leave it out, the type is too polymorphic
-
- \x -> x)
-
-mk_prod_stuff us [arg_var] -- Singleton case
- = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
-
-mk_prod_stuff us arg_vars -- Two or more
- = (us'',
- nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
- nlVarPat to_arg,
--- gaw 2004 FIX?
- \x -> noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
+ appVars = map wrapArg_E vars
+ prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: RdrName -> LHsExpr RdrName
+wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
+ -- This M1 is meta-information for the selector
+
+-- Build a product pattern
+mkProd_P :: US -- Base for unique names
+ -> [RdrName] -- List of variables to match
+ -> LPat RdrName -- Resulting product pattern
+mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P _ vars = mkM1_P (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- to_arg = mkGenericLocal us
- (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
- (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
- (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
- pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
-
-splitInHalf :: [a] -> ([a],[a])
-splitInHalf list = (left, right)
- where
- half = length list `div` 2
- left = take half list
- right = drop half list
+ appVars = map wrapArg_P vars
+ prod a b = prodDataCon_RDR `nlConPat` [a,b]
+
+wrapArg_P :: RdrName -> LPat RdrName
+wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+ -- This M1 is meta-information for the selector
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
-mkGenericNames :: TyCon -> (RdrName, RdrName)
-mkGenericNames tycon
- = (from_RDR, to_RDR)
- where
- tc_name = tyConName tycon
- tc_occ = nameOccName tc_name
- tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name
- from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
- to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating the RHS of a generic default method}
-%* *
-%************************************************************************
-
-Generating the Generic default method. Uses the bimaps to generate the
-actual method. All of this is rather incomplete, but it would be nice
-to make even this work. Example
-
- class Foo a where
- op :: Op a
-
- instance Foo T
-
-Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
-
- instance Foo T where
- op = <mkGenericRhs op a T>
-
-To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
-
- toOp :: Op Trep -> Op T
- fromOp :: Op T -> Op Trep
-
-(the bimap) and then fill in the RHS with
-
- instance Foo T where
- op = toOp op
-
-Remember, we're generating a RenamedHsExpr, so the result of all this
-will be fed to the type checker. So the 'op' on the RHS will be
-at the representation type for T, Trep.
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the class op is polymorphic:
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
- class Baz a where
- op :: forall b. Ord b => a -> b -> b
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _ x [] = x
+foldBal' _ _ [y] = y
+foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
+ in foldBal' op x a `op` foldBal' op x b
-Then we can still generate a bimap with
-
- toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
-
-and fill in the instance decl thus
-
- instance Foo T where
- op = toOp op
-
-By the time the type checker has done its stuff we'll get
-
- instance Foo T where
- op = \b. \dict::Ord b. toOp b (op Trep b dict)
-
-Note [Higher rank methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Higher-rank method types don't work, because we'd generate a bimap that
-needs impredicative polymorphism. In principle that should be possible
-(with boxy types and all) but it would take a bit of working out. Here's
-an example:
- class ChurchEncode k where
- match :: k -> z
- -> (forall a b z. a -> b -> z) {- product -}
- -> (forall a z. a -> z) {- left -}
- -> (forall a z. a -> z) {- right -}
- -> z
-
- match {| Unit |} Unit unit prod left right = unit
- match {| a :*: b |} (x :*: y) unit prod left right = prod x y
- match {| a :+: b |} (Inl l) unit prod left right = left l
- match {| a :+: b |} (Inr r) unit prod left right = right r
-
-\begin{code}
-mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
-mkGenericRhs sel_id tyvar tycon
- = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
--- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
- mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
- where
- -- Initialising the "Environment" with the from/to functions
- -- on the datatype (actually tycon) in question
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Instantiate the selector type, and strip off its class context
- (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
-
- -- Do it again! This deals with the case where the method type
- -- is polymorphic -- see Note [Polymorphic methods] above
- (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-
- -- Now we probably have a tycon in front
- -- of us, quite probably a FunTyCon.
- ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
- bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
-
-type EPEnv = (TyVar, -- The class type variable
- EP (LHsExpr RdrName), -- The EP it maps to
- [TyVar] -- Other in-scope tyvars; they have an identity EP
- )
-
--------------------
-generate_bimap :: EPEnv
- -> Type
- -> EP (LHsExpr RdrName)
--- Top level case - splitting the TyCon.
-generate_bimap env@(tv,ep,local_tvs) ty
- | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
- = idEP -- A constant type
-
- | Just tv1 <- getTyVar_maybe ty
- = ASSERT( tv == tv1 ) ep -- The class tyvar
-
- | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
- = bimapTyCon tycon (map (generate_bimap env) ty_args)
-
- | otherwise
- = pprPanic "generate_bimap" (ppr ty)
-
--------------------
-bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTyCon tycon arg_eps
- | tycon == funTyCon = bimapArrow arg_eps
- | tycon == listTyCon = bimapList arg_eps
- | isBoxedTupleTyCon tycon = bimapTuple arg_eps
- | otherwise = pprPanic "bimapTyCon" (ppr tycon)
-
--------------------
--- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
-bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapArrow [ep1, ep2]
- = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
- toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
- where
- from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
- to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
-
--------------------
--- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
-bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTuple eps
- = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
- toEP = mkHsLam [noLoc tuple_pat] to_body }
- where
- names = takeList eps gs_RDR
- tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
- eps_w_names = eps `zip` names
- to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
- from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-
--------------------
--- bimapList :: EP a b -> EP [a] [b]
-bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapList [ep]
- = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
- toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
-
--------------------
-a_RDR, b_RDR :: RdrName
-a_RDR = mkVarUnqual (fsLit "a")
-b_RDR = mkVarUnqual (fsLit "b")
-
-gs_RDR :: [RdrName]
-gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
-
-idEP :: EP (LHsExpr RdrName)
-idEP = EP idexpr idexpr
- where
- idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
\end{code}
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 07f68f7b91ce91c6c271b201f7fdce8ddcb20027..7a2a65e06bee0eb6711ad9d49c7f229eb2288fef 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -119,7 +119,7 @@ instanceDFunId = is_dfun
setInstanceDFunId :: Instance -> DFunId -> Instance
setInstanceDFunId ispec dfun
- = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
+ = ASSERT( idType dfun `eqType` idType (is_dfun ispec) )
-- We need to create the cached fields afresh from
-- the new dfun id. In particular, the is_tvs in
-- the Instance must match those in the dfun!
@@ -156,7 +156,7 @@ pprInstanceHdr ispec@(Instance { is_flag = flag })
| debugStyle sty = theta
| otherwise = drop (dfunNSilent dfun) theta
in ptext (sLit "instance") <+> ppr flag
- <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
+ <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
where
dfun = is_dfun ispec
(_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..0594f7f53af2a254e1e8c9e137552ca849d574ae
--- /dev/null
+++ b/compiler/types/Kind.lhs
@@ -0,0 +1,235 @@
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module Kind (
+ -- * Main data type
+ Kind, typeKind,
+
+ -- Kinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+ mkArrowKind, mkArrowKinds,
+
+ -- Kind constructors...
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
+
+ -- Super Kinds
+ tySuperKind, tySuperKindTyCon,
+
+ pprKind, pprParendKind,
+
+ -- ** Deconstructing Kinds
+ kindFunResult, kindAppResult, synTyConResKind,
+ splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
+
+ -- ** Predicates on Kinds
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
+ isSuperKind, isCoercionKind,
+ isLiftedTypeKindCon,
+
+ isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
+ isSubKindCon,
+
+ ) where
+
+#include "HsVersions.h"
+
+import TypeRep
+import TysPrim
+import TyCon
+import Var
+import PrelNames
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+ Predicates over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+isTySuperKind :: SuperKind -> Bool
+isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
+isTySuperKind _ = False
+
+-------------------
+-- Lastly we need a few functions on Kinds
+
+isLiftedTypeKindCon :: TyCon -> Bool
+isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
+\end{code}
+
+%************************************************************************
+%* *
+ The kind of a type
+%* *
+%************************************************************************
+
+\begin{code}
+typeKind :: Type -> Kind
+typeKind _ty@(TyConApp tc tys)
+ = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty )
+ -- Assertion checks for unsaturated application of (~)
+ -- See Note [The (~) TyCon] in TysPrim
+ kindAppResult (tyConKind tc) tys
+
+typeKind (PredTy pred) = predKind pred
+typeKind (AppTy fun _) = kindFunResult (typeKind fun)
+typeKind (ForAllTy _ ty) = typeKind ty
+typeKind (TyVarTy tyvar) = tyVarKind tyvar
+typeKind (FunTy _arg res)
+ -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
+ -- not unliftedTypKind (#)
+ -- The only things that can be after a function arrow are
+ -- (a) types (of kind openTypeKind or its sub-kinds)
+ -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
+ | isTySuperKind k = k
+ | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
+ where
+ k = typeKind res
+
+------------------
+predKind :: PredType -> Kind
+predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted
+predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are
+predKind (IParam {}) = liftedTypeKind -- always represented by lifted types
+\end{code}
+
+%************************************************************************
+%* *
+ Functions over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+-- | Essentially 'funResultTy' on kinds
+kindFunResult :: Kind -> Kind
+kindFunResult (FunTy _ res) = res
+kindFunResult k = pprPanic "kindFunResult" (ppr k)
+
+kindAppResult :: Kind -> [arg] -> Kind
+kindAppResult k [] = k
+kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+
+-- | Essentially 'splitFunTys' on kinds
+splitKindFunTys :: Kind -> ([Kind],Kind)
+splitKindFunTys (FunTy a r) = case splitKindFunTys r of
+ (as, k) -> (a:as, k)
+splitKindFunTys k = ([], k)
+
+splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
+splitKindFunTy_maybe (FunTy a r) = Just (a,r)
+splitKindFunTy_maybe _ = Nothing
+
+-- | Essentially 'splitFunTysN' on kinds
+splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
+splitKindFunTysN 0 k = ([], k)
+splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of
+ (as, k) -> (a:as, k)
+splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
+
+-- | Find the result 'Kind' of a type synonym,
+-- after applying it to its 'arity' number of type variables
+-- Actually this function works fine on data types too,
+-- but they'd always return '*', so we never need to ask
+synTyConResKind :: TyCon -> Kind
+synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
+isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
+ isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
+
+isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
+
+isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
+isOpenTypeKind _ = False
+
+isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
+
+isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
+isUbxTupleKind _ = False
+
+isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
+
+isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
+isArgTypeKind _ = False
+
+isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
+
+isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
+isUnliftedTypeKind _ = False
+
+isSubOpenTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
+isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
+ ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
+ False
+isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
+isSubOpenTypeKind other = ASSERT( isKind other ) False
+ -- This is a conservative answer
+ -- It matters in the call to isSubKind in
+ -- checkExpectedKind.
+
+isSubArgTypeKindCon kc
+ | isUnliftedTypeKindCon kc = True
+ | isLiftedTypeKindCon kc = True
+ | isArgTypeKindCon kc = True
+ | otherwise = False
+
+isSubArgTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of ArgTypeKind
+isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
+isSubArgTypeKind _ = False
+
+-- | Is this a super-kind (i.e. a type-of-kinds)?
+isSuperKind :: Type -> Bool
+isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
+isSuperKind _ = False
+
+-- | Is this a kind (i.e. a type-of-types)?
+isKind :: Kind -> Bool
+isKind k = isSuperKind (typeKind k)
+
+isSubKind :: Kind -> Kind -> Bool
+-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
+isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
+isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind _ _ = False
+
+isSubKindCon :: TyCon -> TyCon -> Bool
+-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
+isSubKindCon kc1 kc2
+ | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
+ | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
+ | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
+ | isOpenTypeKindCon kc2 = True
+ -- we already know kc1 is not a fun, its a TyCon
+ | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
+ | otherwise = False
+
+defaultKind :: Kind -> Kind
+-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
+-- information on what that means
+
+-- When we generalise, we make generic type variables whose kind is
+-- simple (* or *->* etc). So generic type variables (other than
+-- built-in constants like 'error') always have simple kinds. This is important;
+-- consider
+-- f x = True
+-- We want f to get type
+-- f :: forall (a::*). a -> Bool
+-- Not
+-- f :: forall (a::??). a -> Bool
+-- because that would allow a call like (f 3#) as well as (f True),
+--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
+defaultKind k
+ | isSubOpenTypeKind k = liftedTypeKind
+ | isSubArgTypeKind k = liftedTypeKind
+ | otherwise = k
+\end{code}
\ No newline at end of file
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index 26f3295b289b0f01f0b26b8ac77323688313dfb0..eef1ccf6722aadf685b035bfd89e2baafc4733a6 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -1,456 +1,372 @@
-%
-% (c) The University of Glasgow 2006
-%
-
-\begin{code}
-{-# OPTIONS_GHC -w #-}
-module OptCoercion (
- optCoercion
- ) where
-
-#include "HsVersions.h"
-
-import Unify ( tcMatchTy )
-import Coercion
-import Type
-import TypeRep
-import TyCon
-import Var
-import VarSet
-import VarEnv
-import PrelNames
-import StaticFlags ( opt_NoOptCoercion )
-import Util
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
- Optimising coercions
-%* *
-%************************************************************************
-
-Note [Subtle shadowing in coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Supose we optimising a coercion
- optCoercion (forall (co_X5:t1~t2). ...co_B1...)
-The co_X5 is a wild-card; the bound variable of a coercion for-all
-should never appear in the body of the forall. Indeed we often
-write it like this
- optCoercion ( (t1~t2) => ...co_B1... )
-
-Just because it's a wild-card doesn't mean we are free to choose
-whatever variable we like. For example it'd be wrong for optCoercion
-to return
- forall (co_B1:t1~t2). ...co_B1...
-because now the co_B1 (which is really free) has been captured, and
-subsequent substitutions will go wrong. That's why we can't use
-mkCoPredTy in the ForAll case, where this note appears.
-
-\begin{code}
-optCoercion :: TvSubst -> Coercion -> NormalCo
--- ^ optCoercion applies a substitution to a coercion,
--- *and* optimises it to reduce its size
-optCoercion env co
- | opt_NoOptCoercion = substTy env co
- | otherwise = opt_co env False co
-
-type NormalCo = Coercion
- -- Invariants:
- -- * The substitution has been fully applied
- -- * For trans coercions (co1 `trans` co2)
- -- co1 is not a trans, and neither co1 nor co2 is identity
- -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)
-
-type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
-
-opt_co, opt_co' :: TvSubst
- -> Bool -- True <=> return (sym co)
- -> Coercion
- -> NormalCo
-opt_co = opt_co'
-
-{- Debuggery
-opt_co env sym co
--- = pprTrace "opt_co {" (ppr sym <+> ppr co) $
--- co1 `seq`
--- pprTrace "opt_co done }" (ppr co1)
--- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1)
--- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) )
- = WARN( not (coreEqType co1 simple_result),
- (text "env=" <+> ppr env) $$
- (text "input=" <+> ppr co) $$
- (text "simple=" <+> ppr simple_result) $$
- (text "opt=" <+> ppr co1) )
- co1
- where
- co1 = opt_co' env sym co
- same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2
- (s,t) = coercionKind (substTy env co)
- (s1,t1) | sym = (t,s)
- | otherwise = (s,t)
- (s2,t2) = coercionKind co1
-
- simple_result | sym = mkSymCoercion (substTy env co)
- | otherwise = substTy env co
--}
-
-opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys))
-opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty))
-opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co)
-
-opt_co' env sym co@(TyVarTy tv)
- | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty
- | not (isCoVar tv) = co -- Identity; does not mention a CoVar
- | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto..
- | not sym = co
- | otherwise = mkSymCoercion co
- where
- (ty1,ty2) = coVarKind tv
-
-opt_co' env sym (ForAllTy tv cor)
- | isTyVar tv = case substTyVarBndr env tv of
- (env', tv') -> ForAllTy tv' (opt_co' env' sym cor)
-
-opt_co' env sym co@(ForAllTy co_var cor)
- | isCoVar co_var
- = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co )
- ForAllTy co_var' cor'
- where
- (co1,co2) = coVarKind co_var
- co1' = opt_co' env sym co1
- co2' = opt_co' env sym co2
- cor' = opt_co' env sym cor
- co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2'))
- -- See Note [Subtle shadowing in coercions]
-
-opt_co' env sym (TyConApp tc cos)
- | Just (arity, desc) <- isCoercionTyCon_maybe tc
- = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos))
- (map (opt_co env sym) (drop arity cos))
- | otherwise
- = TyConApp tc (map (opt_co env sym) cos)
-
---------
-opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo
--- Used for CoercionTyCons only
--- Arguments are *not* already simplified/substituted
-opt_co_tc_app env sym tc desc cos
- = case desc of
- CoAxiom {} -- Do *not* push sym inside top-level axioms
- -- e.g. if g is a top-level axiom
- -- g a : F a ~ a
- -- Then (sym (g ty)) /= g (sym ty) !!
- | sym -> mkSymCoercion the_co
- | otherwise -> the_co
- where
- the_co = TyConApp tc (map (opt_co env False) cos)
- -- Note that the_co does *not* have sym pushed into it
-
- CoTrans
- | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
- | otherwise -> opt_trans opt_co1 opt_co2
-
- CoUnsafe
- | sym -> mkUnsafeCoercion ty2' ty1'
- | otherwise -> mkUnsafeCoercion ty1' ty2'
-
- CoSym -> opt_co env (not sym) co1
- CoLeft -> opt_lr fst
- CoRight -> opt_lr snd
- CoCsel1 -> opt_csel fstOf3
- CoCsel2 -> opt_csel sndOf3
- CoCselR -> opt_csel thirdOf3
-
- CoInst -- See if the first arg is already a forall
- -- ...then we can just extend the current substitution
- | Just (tv, co1_body) <- splitForAllTy_maybe co1
- -> opt_co (extendTvSubst env tv ty2') sym co1_body
-
- -- See if is *now* a forall
- | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1
- -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution
-
- | otherwise
- -> TyConApp tc [opt_co1, ty2']
-
- where
- (co1 : cos1) = cos
- (co2 : _) = cos1
-
- ty1' = substTy env co1
- ty2' = substTy env co2
-
- -- These opt_cos have the sym pushed into them
- opt_co1 = opt_co env sym co1
- opt_co2 = opt_co env sym co2
-
- the_unary_opt_co = TyConApp tc [opt_co1]
-
- opt_lr sel = case splitAppTy_maybe opt_co1 of
- Nothing -> the_unary_opt_co
- Just lr -> sel lr
- opt_csel sel = case splitCoPredTy_maybe opt_co1 of
- Nothing -> the_unary_opt_co
- Just lr -> sel lr
-
--------------
-opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transL = zipWith opt_trans
-
-opt_trans :: NormalCo -> NormalCo -> NormalCo
-opt_trans co1 co2
- | isIdNormCo co1 = co2
- | otherwise = opt_trans1 co1 co2
-
-opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
--- First arg is not the identity
-opt_trans1 co1 co2
- | isIdNormCo co2 = co1
- | otherwise = opt_trans2 co1 co2
-
-opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
--- Neither arg is the identity
-opt_trans2 (TyConApp tc [co1a,co1b]) co2
- | tc `hasKey` transCoercionTyConKey
- = opt_trans1 co1a (opt_trans2 co1b co2)
-
-opt_trans2 co1 co2
- | Just co <- opt_trans_rule co1 co2
- = co
-
-opt_trans2 co1 (TyConApp tc [co2a,co2b])
- | tc `hasKey` transCoercionTyConKey
- , Just co1_2a <- opt_trans_rule co1 co2a
- = if isIdNormCo co1_2a
- then co2b
- else opt_trans2 co1_2a co2b
-
-opt_trans2 co1 co2
- = mkTransCoercion co1 co2
-
-------
-opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
-opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2)
- | tc1 == tc2
- = case isCoercionTyCon_maybe tc1 of
- Nothing
- -> Just (TyConApp tc1 (opt_transL args1 args2))
- Just (arity, desc)
- | arity == length args1
- -> opt_trans_rule_equal_tc desc args1 args2
- | otherwise
- -> case opt_trans_rule_equal_tc desc
- (take arity args1)
- (take arity args2) of
- Just co -> Just $ mkAppTys co $
- opt_transL (drop arity args1) (drop arity args2)
- Nothing -> Nothing
-
--- Push transitivity inside apply
-opt_trans_rule co1 co2
- | Just (co1a, co1b) <- splitAppTy_maybe co1
- , Just (co2a, co2b) <- etaApp_maybe co2
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
-
- | Just (co2a, co2b) <- splitAppTy_maybe co2
- , Just (co1a, co1b) <- etaApp_maybe co1
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
-
--- Push transitivity inside (s~t)=>r
--- We re-use the CoVar rather than using mkCoPredTy
--- See Note [Subtle shadowing in coercions]
-opt_trans_rule co1 co2
- | Just (cv1,r1) <- splitForAllTy_maybe co1
- , isCoVar cv1
- , Just (s1,t1) <- coVarKind_maybe cv1
- , Just (s2,t2,r2) <- etaCoPred_maybe co2
- = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
- (opt_trans r1 r2))
-
- | Just (cv2,r2) <- splitForAllTy_maybe co2
- , isCoVar cv2
- , Just (s2,t2) <- coVarKind_maybe cv2
- , Just (s1,t1,r1) <- etaCoPred_maybe co1
- = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
- (opt_trans r1 r2))
-
--- Push transitivity inside forall
-opt_trans_rule co1 co2
- | Just (tv1,r1) <- splitTypeForAll_maybe co1
- , Just (tv2,r2) <- etaForAll_maybe co2
- , let r2' = substTyWith [tv2] [TyVarTy tv1] r2
- = Just (ForAllTy tv1 (opt_trans2 r1 r2'))
-
- | Just (tv2,r2) <- splitTypeForAll_maybe co2
- , Just (tv1,r1) <- etaForAll_maybe co1
- , let r1' = substTyWith [tv1] [TyVarTy tv2] r1
- = Just (ForAllTy tv1 (opt_trans2 r1' r2))
-
-opt_trans_rule co1 co2
-{- Omitting for now, because unsound
- | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe
- , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe
- , ax_tc1 == ax_tc2
- , sym1 /= sym2
- = Just $
- if sym1
- then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs
- else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs
--}
-
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2
- = Just $
- if sym
- then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args)
- else TyConApp ax_tc (opt_transL ax_args cos)
-
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1
- = Just $
- if sym
- then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos))
- else TyConApp ax_tc (opt_transL cos ax_args)
- where
- co1_is_axiom_maybe = isAxiom_maybe co1
- co2_is_axiom_maybe = isAxiom_maybe co2
-
-opt_trans_rule co1 co2 -- Identity rule
- | (ty1,_) <- coercionKind co1
- , (_,ty2) <- coercionKind co2
- , ty1 `coreEqType` ty2
- = Just ty2
-
-opt_trans_rule _ _ = Nothing
-
------------
-isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type))
-isAxiom_maybe co
- | Just (tc, args) <- splitTyConApp_maybe co
- , Just (_, desc) <- isCoercionTyCon_maybe tc
- = case desc of
- CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }
- -> Just (False, (tc, args, tvs, lhs, rhs))
- CoSym | (arg1:_) <- args
- -> case isAxiom_maybe arg1 of
- Nothing -> Nothing
- Just (sym, stuff) -> Just (not sym, stuff)
- _ -> Nothing
- | otherwise
- = Nothing
-
-matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type]
-matchesAxiomLhs tvs ty_tmpl ty
- = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of
- Nothing -> Nothing
- Just subst -> Just (map (substTyVar subst) tvs)
-
------------
-opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion
--- Rules for Coercion TyCons only
-
--- Push transitivity inside instantiation
-opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2]
- | CoInst <- desc
- , ty1 `coreEqType` ty2
- , co1 `compatible_co` co2
- = Just (mkInstCoercion (opt_trans2 co1 co2) ty1)
-
-opt_trans_rule_equal_tc desc [co1] [co2]
- | CoLeft <- desc, is_compat = Just (mkLeftCoercion res_co)
- | CoRight <- desc, is_compat = Just (mkRightCoercion res_co)
- | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co)
- | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co)
- | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co)
- where
- is_compat = co1 `compatible_co` co2
- res_co = opt_trans2 co1 co2
-
-opt_trans_rule_equal_tc _ _ _ = Nothing
-
--------------
-compatible_co :: Coercion -> Coercion -> Bool
--- Check whether (co1 . co2) will be well-kinded
-compatible_co co1 co2
- = x1 `coreEqType` x2
- where
- (_,x1) = coercionKind co1
- (x2,_) = coercionKind co2
-
--------------
-etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion)
--- Try to make the coercion be of form (forall tv. co)
-etaForAll_maybe co
- | Just (tv, r) <- splitForAllTy_maybe co
- , not (isCoVar tv) -- Check it is a *type* forall, not a (t1~t2)=>co
- = Just (tv, r)
-
- | (ty1,ty2) <- coercionKind co
- , Just (tv1, _) <- splitTypeForAll_maybe ty1
- , Just (tv2, _) <- splitTypeForAll_maybe ty2
- , tyVarKind tv1 `eqKind` tyVarKind tv2
- = Just (tv1, mkInstCoercion co (mkTyVarTy tv1))
-
- | otherwise
- = Nothing
-
-etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion)
-etaCoPred_maybe co
- | Just (s,t,r) <- splitCoPredTy_maybe co
- = Just (s,t,r)
-
- -- co :: (s1~t1)=>r1 ~ (s2~t2)=>r2
- | (ty1,ty2) <- coercionKind co -- We know ty1,ty2 have same kind
- , Just (s1,_,_) <- splitCoPredTy_maybe ty1
- , Just (s2,_,_) <- splitCoPredTy_maybe ty2
- , typeKind s1 `eqKind` typeKind s2 -- t1,t2 have same kinds
- = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co)
-
- | otherwise
- = Nothing
-
-etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion)
--- Split a coercion g :: t1a t1b ~ t2a t2b
--- into (left g, right g) if possible
-etaApp_maybe co
- | Just (co1, co2) <- splitAppTy_maybe co
- = Just (co1, co2)
-
- | (ty1,ty2) <- coercionKind co
- , Just (ty1a, _) <- splitAppTy_maybe ty1
- , Just (ty2a, _) <- splitAppTy_maybe ty2
- , typeKind ty1a `eqKind` typeKind ty2a
- = Just (mkLeftCoercion co, mkRightCoercion co)
-
- | otherwise
- = Nothing
-
--------------
-splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type)
--- Returns Just only for a *type* forall, not a (t1~t2)=>co
-splitTypeForAll_maybe ty
- | Just (tv, rty) <- splitForAllTy_maybe ty
- , not (isCoVar tv)
- = Just (tv, rty)
-
- | otherwise
- = Nothing
-
--------------
-isIdNormCo :: NormalCo -> Bool
--- Cheap identity test: look for coercions with no coercion variables at all
--- So it'll return False for (sym g `trans` g)
-isIdNormCo ty = go ty
- where
- go (TyVarTy tv) = not (isCoVar tv)
- go (AppTy t1 t2) = go t1 && go t2
- go (FunTy t1 t2) = go t1 && go t2
- go (ForAllTy tv ty) = go (tyVarKind tv) && go ty
- go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys
- go (PredTy (IParam _ ty)) = go ty
- go (PredTy (ClassP _ tys)) = all go tys
- go (PredTy (EqPred t1 t2)) = go t1 && go t2
-\end{code}
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module OptCoercion ( optCoercion ) where
+
+#include "HsVersions.h"
+
+import Coercion
+import Type hiding( substTyVarBndr, substTy, extendTvSubst )
+import TyCon
+import Var
+import VarSet
+import VarEnv
+import StaticFlags ( opt_NoOptCoercion )
+import Outputable
+import Pair
+import Maybes( allMaybes )
+import FastString
+\end{code}
+
+%************************************************************************
+%* *
+ Optimising coercions
+%* *
+%************************************************************************
+
+Note [Subtle shadowing in coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose we optimising a coercion
+ optCoercion (forall (co_X5:t1~t2). ...co_B1...)
+The co_X5 is a wild-card; the bound variable of a coercion for-all
+should never appear in the body of the forall. Indeed we often
+write it like this
+ optCoercion ( (t1~t2) => ...co_B1... )
+
+Just because it's a wild-card doesn't mean we are free to choose
+whatever variable we like. For example it'd be wrong for optCoercion
+to return
+ forall (co_B1:t1~t2). ...co_B1...
+because now the co_B1 (which is really free) has been captured, and
+subsequent substitutions will go wrong. That's why we can't use
+mkCoPredTy in the ForAll case, where this note appears.
+
+\begin{code}
+optCoercion :: CvSubst -> Coercion -> NormalCo
+-- ^ optCoercion applies a substitution to a coercion,
+-- *and* optimises it to reduce its size
+optCoercion env co
+ | opt_NoOptCoercion = substCo env co
+ | otherwise = opt_co env False co
+
+type NormalCo = Coercion
+ -- Invariants:
+ -- * The substitution has been fully applied
+ -- * For trans coercions (co1 `trans` co2)
+ -- co1 is not a trans, and neither co1 nor co2 is identity
+ -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)
+
+type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
+
+opt_co, opt_co' :: CvSubst
+ -> Bool -- True <=> return (sym co)
+ -> Coercion
+ -> NormalCo
+opt_co = opt_co'
+{-
+opt_co env sym co
+ = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
+ co1 `seq`
+ pprTrace "opt_co done }" (ppr co1) $
+ (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
+ $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
+ WARN( not (coreEqCoercion co1 simple_result),
+ (text "env=" <+> ppr env) $$
+ (text "input=" <+> ppr co) $$
+ (text "simple=" <+> ppr simple_result) $$
+ (text "opt=" <+> ppr co1) )
+ co1)
+ where
+ co1 = opt_co' env sym co
+ same_co_kind = s1 `eqType` s2 && t1 `eqType` t2
+ Pair s t = coercionKind (substCo env co)
+ (s1,t1) | sym = (t,s)
+ | otherwise = (s,t)
+ Pair s2 t2 = coercionKind co1
+
+ simple_result | sym = mkSymCo (substCo env co)
+ | otherwise = substCo env co
+-}
+
+opt_co' env _ (Refl ty) = Refl (substTy env ty)
+opt_co' env sym (SymCo co) = opt_co env (not sym) co
+opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos)
+opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2)
+opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of
+ (env', tv') -> mkForAllCo tv' (opt_co env' sym co)
+ -- Use the "mk" functions to check for nested Refls
+
+opt_co' env sym (CoVarCo cv)
+ | Just co <- lookupCoVar env cv
+ = opt_co (zapCvSubstEnv env) sym co
+
+ | Just cv1 <- lookupInScope (getCvInScope env) cv
+ = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
+ -- cv1 might have a substituted kind!
+
+ | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
+ ASSERT( isCoVar cv )
+ wrapSym sym (CoVarCo cv)
+
+opt_co' env sym (AxiomInstCo con cos)
+ -- Do *not* push sym inside top-level axioms
+ -- e.g. if g is a top-level axiom
+ -- g a : f a ~ a
+ -- then (sym (g ty)) /= g (sym ty) !!
+ = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos)
+ -- Note that the_co does *not* have sym pushed into it
+
+opt_co' env sym (UnsafeCo ty1 ty2)
+ | ty1' `eqType` ty2' = Refl ty1'
+ | sym = mkUnsafeCo ty2' ty1'
+ | otherwise = mkUnsafeCo ty1' ty2'
+ where
+ ty1' = substTy env ty1
+ ty2' = substTy env ty2
+
+opt_co' env sym (TransCo co1 co2)
+ | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
+ | otherwise = opt_trans opt_co1 opt_co2
+ where
+ opt_co1 = opt_co env sym co1
+ opt_co2 = opt_co env sym co2
+
+opt_co' env sym (NthCo n co)
+ | TyConAppCo tc cos <- co'
+ , isDecomposableTyCon tc -- Not synonym families
+ = ASSERT( n < length cos )
+ cos !! n
+ | otherwise
+ = NthCo n co'
+ where
+ co' = opt_co env sym co
+
+opt_co' env sym (InstCo co ty)
+ -- See if the first arg is already a forall
+ -- ...then we can just extend the current substitution
+ | Just (tv, co_body) <- splitForAllCo_maybe co
+ = opt_co (extendTvSubst env tv ty') sym co_body
+
+ -- See if it is a forall after optimization
+ | Just (tv, co'_body) <- splitForAllCo_maybe co'
+ = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution
+
+ | otherwise = InstCo co' ty'
+
+ where
+ co' = opt_co env sym co
+ ty' = substTy env ty
+
+-------------
+opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList = zipWith opt_trans
+
+opt_trans :: NormalCo -> NormalCo -> NormalCo
+opt_trans co1 co2
+ | isReflCo co1 = co2
+ | otherwise = opt_trans1 co1 co2
+
+opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
+-- First arg is not the identity
+opt_trans1 co1 co2
+ | isReflCo co2 = co1
+ | otherwise = opt_trans2 co1 co2
+
+opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
+-- Neither arg is the identity
+opt_trans2 (TransCo co1a co1b) co2
+ -- Don't know whether the sub-coercions are the identity
+ = opt_trans co1a (opt_trans co1b co2)
+
+opt_trans2 co1 co2
+ | Just co <- opt_trans_rule co1 co2
+ = co
+
+opt_trans2 co1 (TransCo co2a co2b)
+ | Just co1_2a <- opt_trans_rule co1 co2a
+ = if isReflCo co1_2a
+ then co2b
+ else opt_trans1 co1_2a co2b
+
+opt_trans2 co1 co2
+ = mkTransCo co1 co2
+
+------
+-- Optimize coercions with a top-level use of transitivity.
+opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+
+-- push transitivity down through matching top-level constructors.
+opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2)
+ | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $
+ TyConAppCo tc1 (opt_transList cos1 cos2)
+
+-- push transitivity through matching destructors
+opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+ | d1 == d2
+ , co1 `compatible_co` co2
+ = fireTransRule "PushNth" in_co1 in_co2 $
+ mkNthCo d1 (opt_trans co1 co2)
+
+-- Push transitivity inside instantiation
+opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+ | ty1 `eqType` ty2
+ , co1 `compatible_co` co2
+ = fireTransRule "TrPushInst" in_co1 in_co2 $
+ mkInstCo (opt_trans co1 co2) ty1
+
+-- Push transitivity inside apply
+opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+ = fireTransRule "TrPushApp" in_co1 in_co2 $
+ mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b)
+
+opt_trans_rule co1@(TyConAppCo tc cos1) co2
+ | Just cos2 <- etaTyConAppCo_maybe tc co2
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompL" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+opt_trans_rule co1 co2@(TyConAppCo tc cos2)
+ | Just cos1 <- etaTyConAppCo_maybe tc co1
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompR" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+-- Push transitivity inside forall
+opt_trans_rule co1 co2
+ | Just (tv1,r1) <- splitForAllCo_maybe co1
+ , Just (tv2,r2) <- etaForAllCo_maybe co2
+ , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2
+ = fireTransRule "EtaAllL" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1 r2')
+
+ | Just (tv2,r2) <- splitForAllCo_maybe co2
+ , Just (tv1,r1) <- etaForAllCo_maybe co1
+ , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1
+ = fireTransRule "EtaAllR" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1' r2)
+
+-- Push transitivity inside axioms
+opt_trans_rule co1 co2
+
+ -- TrPushAxR/TrPushSymAxR
+ | Just (sym, con, cos1) <- co1_is_axiom_maybe
+ , Just cos2 <- matchAxiom sym con co2
+ = fireTransRule "TrPushAxR" co1 co2 $
+ if sym
+ then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1)
+ else AxiomInstCo con (opt_transList cos1 cos2)
+
+ -- TrPushAxL/TrPushSymAxL
+ | Just (sym, con, cos2) <- co2_is_axiom_maybe
+ , Just cos1 <- matchAxiom (not sym) con co1
+ = fireTransRule "TrPushAxL" co1 co2 $
+ if sym
+ then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1))
+ else AxiomInstCo con (opt_transList cos1 cos2)
+
+ -- TrPushAxSym/TrPushSymAx
+ | Just (sym1, con1, cos1) <- co1_is_axiom_maybe
+ , Just (sym2, con2, cos2) <- co2_is_axiom_maybe
+ , con1 == con2
+ , sym1 == not sym2
+ , let qtvs = co_ax_tvs con1
+ lhs = co_ax_lhs con1
+ rhs = co_ax_rhs con1
+ pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs)
+ , all (`elemVarSet` pivot_tvs) qtvs
+ = fireTransRule "TrPushAxSym" co1 co2 $
+ if sym2
+ then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym
+ else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs -- TrPushSymAx
+ where
+ co1_is_axiom_maybe = isAxiom_maybe co1
+ co2_is_axiom_maybe = isAxiom_maybe co2
+
+opt_trans_rule co1 co2 -- Identity rule
+ | Pair ty1 _ <- coercionKind co1
+ , Pair _ ty2 <- coercionKind co2
+ , ty1 `eqType` ty2
+ = fireTransRule "RedTypeDirRefl" co1 co2 $
+ Refl ty2
+
+opt_trans_rule _ _ = Nothing
+
+fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
+fireTransRule _rule _co1 _co2 res
+ = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $
+ Just res
+
+-----------
+wrapSym :: Bool -> Coercion -> Coercion
+wrapSym sym co | sym = SymCo co
+ | otherwise = co
+
+-----------
+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion])
+isAxiom_maybe (SymCo co)
+ | Just (sym, con, cos) <- isAxiom_maybe co
+ = Just (not sym, con, cos)
+isAxiom_maybe (AxiomInstCo con cos)
+ = Just (False, con, cos)
+isAxiom_maybe _ = Nothing
+
+matchAxiom :: Bool -- True = match LHS, False = match RHS
+ -> CoAxiom -> Coercion -> Maybe [Coercion]
+-- If we succeed in matching, then *all the quantified type variables are bound*
+-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail
+matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co
+ = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of
+ Nothing -> Nothing
+ Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
+
+-------------
+compatible_co :: Coercion -> Coercion -> Bool
+-- Check whether (co1 . co2) will be well-kinded
+compatible_co co1 co2
+ = x1 `eqType` x2
+ where
+ Pair _ x1 = coercionKind co1
+ Pair x2 _ = coercionKind co2
+
+-------------
+etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+-- Try to make the coercion be of form (forall tv. co)
+etaForAllCo_maybe co
+ | Just (tv, r) <- splitForAllCo_maybe co
+ = Just (tv, r)
+
+ | Pair ty1 ty2 <- coercionKind co
+ , Just (tv1, _) <- splitForAllTy_maybe ty1
+ , Just (tv2, _) <- splitForAllTy_maybe ty2
+ , tyVarKind tv1 `eqKind` tyVarKind tv2
+ = Just (tv1, mkInstCo co (mkTyVarTy tv1))
+
+ | otherwise
+ = Nothing
+
+etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
+-- If possible, split a coercion
+-- g :: T s1 .. sn ~ T t1 .. tn
+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
+etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2)
+ = ASSERT( tc == tc2 ) Just cos2
+
+etaTyConAppCo_maybe tc co
+ | isDecomposableTyCon tc
+ , Pair ty1 ty2 <- coercionKind co
+ , Just (tc1, tys1) <- splitTyConApp_maybe ty1
+ , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+ , tc1 == tc2
+ , let n = length tys1
+ = ASSERT( tc == tc1 )
+ ASSERT( n == length tys2 )
+ Just (decomposeCo n co)
+ -- NB: n might be <> tyConArity tc
+ -- e.g. data family T a :: * -> *
+ -- g :: T a b ~ T c d
+
+ | otherwise
+ = Nothing
+\end{code}
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index adb04700ca15b910d6482920cd1035e5d3f248c4..915207621ff2a6652a9110156efff7d1930f5d48 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -13,7 +13,9 @@ module TyCon(
AlgTyConRhs(..), visibleDataCons,
TyConParent(..), isNoParent,
SynTyConRhs(..),
- CoTyConDesc(..),
+
+ -- ** Coercion axiom constructors
+ CoAxiom(..), coAxiomName, coAxiomArity,
-- ** Constructing TyCons
mkAlgTyCon,
@@ -25,7 +27,6 @@ module TyCon(
mkTupleTyCon,
mkSynTyCon,
mkSuperKindTyCon,
- mkCoercionTyCon,
mkForeignTyCon,
mkAnyTyCon,
@@ -35,21 +36,20 @@ module TyCon(
isFunTyCon,
isPrimTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
- isSynTyCon, isClosedSynTyCon,
+ isSynTyCon, isClosedSynTyCon,
isSuperKindTyCon, isDecomposableTyCon,
- isCoercionTyCon, isCoercionTyCon_maybe,
isForeignTyCon, isAnyTyCon, tyConHasKind,
isInjectiveTyCon,
isDataTyCon, isProductTyCon, isEnumerationTyCon,
- isNewTyCon, isAbstractTyCon,
+ isNewTyCon, isAbstractTyCon,
isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon,
isUnLiftedTyCon,
isGadtSyntaxTyCon,
isTyConAssoc,
isRecursiveTyCon,
isHiBootTyCon,
- isImplicitTyCon, tyConHasGenerics,
+ isImplicitTyCon,
-- ** Extracting information out of TyCons
tyConName,
@@ -63,16 +63,16 @@ module TyCon(
tyConParent,
tyConClass_maybe,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
- synTyConDefn, synTyConRhs, synTyConType,
- tyConExtName, -- External name for foreign types
+ synTyConDefn, synTyConRhs, synTyConType,
+ tyConExtName, -- External name for foreign types
algTyConRhs,
newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
- tupleTyConBoxity,
+ tupleTyConBoxity, tupleTyConArity,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract,
- newTyConCo_maybe,
+ newTyConCo, newTyConCo_maybe,
-- * Primitive representations of Types
PrimRep(..),
@@ -113,7 +113,7 @@ Note [Type synonym families]
* Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon
-* From the user's point of view (F Int) and Bool are simply
+* From the user's point of view (F Int) and Bool are simply
equivalent types.
* A Haskell 98 type synonym is a degenerate form of a type synonym
@@ -152,6 +152,23 @@ Note [Type synonym families]
TyCon. In turn this means that type and data families can be
treated uniformly.
+* Translation of type family decl:
+ type family F a :: *
+ translates to
+ a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
+
+* Translation of type instance decl:
+ type instance F [a] = Maybe a
+ translates to
+ A SynTyCon 'R:FList a', whose
+ SynTyConRhs is (SynonymTyCon (Maybe a))
+ TyConParent is (FamInstTyCon F [a] co)
+ where co :: F [a] ~ R:FList a
+ Notice that we introduce a gratuitous vanilla type synonym
+ type R:FList a = Maybe a
+ solely so that type and data families can be treated more
+ uniformly, via a single FamInstTyCon descriptor
+
* In the future we might want to support
* closed type families (esp when we have proper kinds)
* injective type families (allow decomposition)
@@ -169,6 +186,8 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+
* The user does not see any "equivalent types" as he did with type
synonym families. He just sees constructors with types
T1 :: T Int
@@ -266,9 +285,6 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
--
-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@
--
--- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@
--- as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this
---
-- This data type also encodes a number of primitive, built in type constructors such as those
-- for function and tuple types.
data TyCon
@@ -317,11 +333,7 @@ data TyCon
algTcRec :: RecFlag, -- ^ Tells us whether the data type is part
-- of a mutually-recursive group or not
-
- hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense)
- -- to\/from functions are available in the exports
- -- of the data type's source module.
-
+
algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon'
-- for derived 'TyCon's representing class
-- or family instances, respectively.
@@ -337,8 +349,7 @@ data TyCon
tyConArity :: Arity,
tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
- dataCon :: DataCon, -- ^ Corresponding tuple data constructor
- hasGenerics :: Bool
+ dataCon :: DataCon -- ^ Corresponding tuple data constructor
}
-- | Represents type synonyms
@@ -381,17 +392,6 @@ data TyCon
-- holds the name of the imported thing
}
- -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@.
- -- INVARIANT: Coercion TyCons are always fully applied
- -- But note that a CoTyCon can be *over*-saturated in a type.
- -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int])
- | CoTyCon {
- tyConUnique :: Unique,
- tyConName :: Name,
- tyConArity :: Arity,
- coTcDesc :: CoTyConDesc
- }
-
-- | Any types. Like tuples, this is a potentially-infinite family of TyCons
-- one for each distinct Kind. They have no values at all.
-- Because there are infinitely many of them (like tuples) they are
@@ -401,7 +401,7 @@ data TyCon
| AnyTyCon {
tyConUnique :: Unique,
tyConName :: Name,
- tc_kind :: Kind -- Never = *; that is done via PrimTyCon
+ tc_kind :: Kind -- Never = *; that is done via PrimTyCon
-- See Note [Any types] in TysPrim
}
@@ -475,18 +475,14 @@ data AlgTyConRhs
-- shorter than the declared arity of the 'TyCon'.
-- See Note [Newtype eta]
-
- nt_co :: Maybe TyCon -- ^ A 'TyCon' (which is always a 'CoTyCon') that can
- -- have a 'Coercion' extracted from it to create
- -- the @newtype@ from the representation 'Type'.
- --
- -- This field is optional for non-recursive @newtype@s only.
-
- -- See Note [Newtype coercions]
- -- Invariant: arity = #tvs in nt_etad_rhs;
- -- See Note [Newtype eta]
- -- Watch out! If any newtypes become transparent
- -- again check Trac #1072.
+ nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from
+ -- the representation 'Type'.
+
+ -- See Note [Newtype coercions]
+ -- Invariant: arity = #tvs in nt_etad_rhs;
+ -- See Note [Newtype eta]
+ -- Watch out! If any newtypes become transparent
+ -- again check Trac #1072.
}
-- | Extract those 'DataCon's that we are able to learn about. Note
@@ -546,7 +542,7 @@ data TyConParent
-- and Note [Type synonym families]
TyCon -- The family TyCon
[Type] -- Argument types (mentions the tyConTyVars of this TyCon)
- TyCon -- The coercion constructor
+ CoAxiom -- The coercion constructor
-- E.g. data intance T [a] = ...
-- gives a representation tycon:
@@ -577,20 +573,6 @@ data SynTyConRhs
-- | A type synonym family e.g. @type family F x y :: * -> *@
| SynFamilyTyCon
-
---------------------
-data CoTyConDesc
- = CoSym | CoTrans
- | CoLeft | CoRight
- | CoCsel1 | CoCsel2 | CoCselR
- | CoInst
-
- | CoAxiom -- C tvs : F lhs-tys ~ rhs-ty
- { co_ax_tvs :: [TyVar]
- , co_ax_lhs :: Type
- , co_ax_rhs :: Type }
-
- | CoUnsafe
\end{code}
Note [Enumeration types]
@@ -687,6 +669,31 @@ so the coercion tycon CoT must have
and arity: 0
+%************************************************************************
+%* *
+ Coercion axioms
+%* *
+%************************************************************************
+
+\begin{code}
+-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
+data CoAxiom
+ = CoAxiom -- type equality axiom.
+ { co_ax_unique :: Unique -- unique identifier
+ , co_ax_name :: Name -- name for pretty-printing
+ , co_ax_tvs :: [TyVar] -- bound type variables
+ , co_ax_lhs :: Type -- left-hand side of the equality
+ , co_ax_rhs :: Type -- right-hand side of the equality
+ }
+
+coAxiomArity :: CoAxiom -> Arity
+coAxiomArity ax = length (co_ax_tvs ax)
+
+coAxiomName :: CoAxiom -> Name
+coAxiomName = co_ax_name
+\end{code}
+
+
%************************************************************************
%* *
\subsection{PrimRep}
@@ -776,10 +783,9 @@ mkAlgTyCon :: Name
-> AlgTyConRhs -- ^ Information about dat aconstructors
-> TyConParent
-> RecFlag -- ^ Is the 'TyCon' recursive?
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
@@ -790,14 +796,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
algTcRhs = rhs,
algTcParent = ASSERT( okParent name parent ) parent,
algTcRec = is_rec,
- algTcGadtSyntax = gadt_syn,
- hasGenerics = gen_info
+ algTcGadtSyntax = gadt_syn
}
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
mkClassTyCon name kind tyvars rhs clas is_rec =
- mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
+ mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
@@ -805,9 +810,8 @@ mkTupleTyCon :: Name
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
-> DataCon
-> Boxity -- ^ Whether the tuple is boxed or unboxed
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> TyCon
-mkTupleTyCon name kind arity tyvars con boxed gen_info
+mkTupleTyCon name kind arity tyvars con boxed
= TupleTyCon {
tyConUnique = nameUnique name,
tyConName = name,
@@ -815,8 +819,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info
tyConArity = arity,
tyConBoxed = boxed,
tyConTyVars = tyvars,
- dataCon = con,
- hasGenerics = gen_info
+ dataCon = con
}
-- ^ Foreign-imported (.NET) type constructors are represented
@@ -880,17 +883,6 @@ mkSynTyCon name kind tyvars rhs parent
synTcParent = parent
}
--- | Create a coercion 'TyCon'
-mkCoercionTyCon :: Name -> Arity
- -> CoTyConDesc
- -> TyCon
-mkCoercionTyCon name arity desc
- = CoTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConArity = arity,
- coTcDesc = desc }
-
mkAnyTyCon :: Name -> Kind -> TyCon
mkAnyTyCon name kind
= AnyTyCon { tyConName = name,
@@ -968,11 +960,11 @@ isNewTyCon _ = False
-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands
-- into, and (possibly) a coercion from the representation type to the @newtype@.
-- Returns @Nothing@ if this is not possible.
-unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon)
+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom)
unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
- algTcRhs = NewTyCon { nt_co = mb_co,
+ algTcRhs = NewTyCon { nt_co = co,
nt_rhs = rhs }})
- = Just (tvs, rhs, mb_co)
+ = Just (tvs, rhs, co)
unwrapNewTyCon_maybe _ = Nothing
isProductTyCon :: TyCon -> Bool
@@ -1004,9 +996,8 @@ isSynTyCon _ = False
isDecomposableTyCon :: TyCon -> Bool
-- True iff we can decompose (T a b c) into ((T a b) c)
--- Specifically NOT true of synonyms (open and otherwise) and coercions
+-- Specifically NOT true of synonyms (open and otherwise)
isDecomposableTyCon (SynTyCon {}) = False
-isDecomposableTyCon (CoTyCon {}) = False
isDecomposableTyCon _other = True
-- | Is this an algebraic 'TyCon' declared with the GADT syntax?
@@ -1048,7 +1039,7 @@ isInjectiveTyCon tc = not (isSynTyCon tc)
-- Ultimately we may have injective associated types
-- in which case this test will become more interesting
--
- -- It'd be unusual to call isInjectiveTyCon on a regular H98
+ -- It'd be unusual to call isInjectiveTyCon on a regular H98
-- type synonym, because you should probably have expanded it first
-- But regardless, it's not injective!
@@ -1087,6 +1078,11 @@ isBoxedTupleTyCon _ = False
tupleTyConBoxity :: TyCon -> Boxity
tupleTyConBoxity tc = tyConBoxed tc
+-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
+-- Panics otherwise
+tupleTyConArity :: TyCon -> Arity
+tupleTyConArity tc = tyConArity tc
+
-- | Is this a recursive 'TyCon'?
isRecursiveTyCon :: TyCon -> Bool
isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
@@ -1113,19 +1109,6 @@ isAnyTyCon :: TyCon -> Bool
isAnyTyCon (AnyTyCon {}) = True
isAnyTyCon _ = False
--- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of
--- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the
--- appropriate kind
-isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, CoTyConDesc)
-isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc})
- = Just (ar, desc)
-isCoercionTyCon_maybe _ = Nothing
-
--- | Is this a 'TyCon' that represents a coercion?
-isCoercionTyCon :: TyCon -> Bool
-isCoercionTyCon (CoTyCon {}) = True
-isCoercionTyCon _ = False
-
-- | Identifies implicit tycons that, in particular, do not go into interface
-- files (because they are implicitly reconstructed when the interface is
-- read).
@@ -1155,14 +1138,15 @@ isImplicitTyCon _other = True
\begin{code}
tcExpandTyCon_maybe, coreExpandTyCon_maybe
:: TyCon
- -> [Type] -- ^ Arguments to 'TyCon'
- -> Maybe ([(TyVar,Type)],
+ -> [tyco] -- ^ Arguments to 'TyCon'
+ -> Maybe ([(TyVar,tyco)],
Type,
- [Type]) -- ^ Returns a 'TyVar' substitution, the body type
- -- of the synonym (not yet substituted) and any arguments
- -- remaining from the application
+ [tyco]) -- ^ Returns a 'TyVar' substitution, the body type
+ -- of the synonym (not yet substituted) and any arguments
+ -- remaining from the application
--- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
+-- ^ Used to create the view the /typechecker/ has on 'TyCon's.
+-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs,
synTcRhs = SynonymTyCon rhs }) tys
= expand tvs rhs tys
@@ -1170,36 +1154,26 @@ tcExpandTyCon_maybe _ _ = Nothing
---------------
--- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
+-- ^ Used to create the view /Core/ has on 'TyCon's. We expand
+-- not only closed synonyms like 'tcExpandTyCon_maybe',
-- but also non-recursive @newtype@s
-coreExpandTyCon_maybe (AlgTyCon {
- algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
- = case etad_rhs of -- Don't do this in the pattern match, lest we accidentally
- -- match the etad_rhs of a *recursive* newtype
- (tvs,rhs) -> expand tvs rhs tys
-
coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
----------------
-expand :: [TyVar] -> Type -- Template
- -> [Type] -- Args
- -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion
+expand :: [TyVar] -> Type -- Template
+ -> [a] -- Args
+ -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion
expand tvs rhs tys
= case n_tvs `compare` length tys of
LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys)
EQ -> Just (tvs `zip` tys, rhs, [])
- GT -> Nothing
+ GT -> Nothing
where
n_tvs = length tvs
\end{code}
\begin{code}
--- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics'
-tyConHasGenerics :: TyCon -> Bool
-tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics _ = False -- Synonyms
tyConKind :: TyCon -> Kind
tyConKind (FunTyCon { tc_kind = k }) = k
@@ -1212,7 +1186,6 @@ tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon
tyConHasKind :: TyCon -> Bool
tyConHasKind (SuperKindTyCon {}) = False
-tyConHasKind (CoTyCon {}) = False
tyConHasKind _ = True
-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors
@@ -1265,9 +1238,14 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)
-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something
-- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon'
-- is not a @newtype@, returns @Nothing@
-newTyConCo_maybe :: TyCon -> Maybe TyCon
-newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
-newTyConCo_maybe _ = Nothing
+newTyConCo_maybe :: TyCon -> Maybe CoAxiom
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co
+newTyConCo_maybe _ = Nothing
+
+newTyConCo :: TyCon -> CoAxiom
+newTyConCo tc = case newTyConCo_maybe tc of
+ Just co -> co
+ Nothing -> pprPanic "newTyConCo" (ppr tc)
-- | Find the primitive representation of a 'TyCon'
tyConPrimRep :: TyCon -> PrimRep
@@ -1337,6 +1315,7 @@ tyConParent (AlgTyCon {algTcParent = parent}) = parent
tyConParent (SynTyCon {synTcParent = parent}) = parent
tyConParent _ = NoParentTyCon
+----------------------------------------------------------------------------
-- | Is this 'TyCon' that for a family instance, be that for a synonym or an
-- algebraic family instance?
isFamInstTyCon :: TyCon -> Bool
@@ -1344,7 +1323,7 @@ isFamInstTyCon tc = case tyConParent tc of
FamInstTyCon {} -> True
_ -> False
-tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon)
+tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom)
tyConFamInstSig_maybe tc
= case tyConParent tc of
FamInstTyCon f ts co_tc -> Just (f, ts, co_tc)
@@ -1361,7 +1340,7 @@ tyConFamInst_maybe tc
-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents
-- a coercion identifying the representation type with the type instance family.
-- Otherwise, return @Nothing@
-tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
+tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom
tyConFamilyCoercion_maybe tc
= case tyConParent tc of
FamInstTyCon _ _ co -> Just co
@@ -1395,18 +1374,6 @@ instance Ord TyCon where
instance Uniquable TyCon where
getUnique tc = tyConUnique tc
-instance Outputable CoTyConDesc where
- ppr CoSym = ptext (sLit "SYM")
- ppr CoTrans = ptext (sLit "TRANS")
- ppr CoLeft = ptext (sLit "LEFT")
- ppr CoRight = ptext (sLit "RIGHT")
- ppr CoCsel1 = ptext (sLit "CSEL1")
- ppr CoCsel2 = ptext (sLit "CSEL2")
- ppr CoCselR = ptext (sLit "CSELR")
- ppr CoInst = ptext (sLit "INST")
- ppr CoUnsafe = ptext (sLit "UNSAFE")
- ppr (CoAxiom {}) = ptext (sLit "AXIOM")
-
instance Outputable TyCon where
ppr tc = ppr (getName tc)
@@ -1421,4 +1388,34 @@ instance Data.Data TyCon where
toConstr _ = abstractConstr "TyCon"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "TyCon"
+
+-------------------
+instance Eq CoAxiom where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord CoAxiom where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = getUnique a `compare` getUnique b
+
+instance Uniquable CoAxiom where
+ getUnique = co_ax_unique
+
+instance Outputable CoAxiom where
+ ppr = ppr . getName
+
+instance NamedThing CoAxiom where
+ getName = co_ax_name
+
+instance Data.Typeable CoAxiom where
+ typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") []
+
+instance Data.Data CoAxiom where
+ -- don't traverse?
+ toConstr _ = abstractConstr "CoAxiom"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "CoAxiom"
\end{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 5f348efd35ab6626c8b2133988af15c80da1c3d4..995d7a9c1d5e69c272d243bd6dc6b50e31816ed4 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -20,7 +20,8 @@ module Type (
-- $type_classification
-- $representation_types
- TyThing(..), Type, PredType(..), ThetaType,
+ TyThing(..), Type, Pred(..), PredType, ThetaType,
+ Var, TyVar, isTyVar,
-- ** Constructing and deconstructing types
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
@@ -45,14 +46,20 @@ module Type (
-- (Type families)
tyFamInsts, predFamInsts,
- -- (Source types)
- mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred,
+ -- Pred types
+ mkPredTy, mkPredTys, mkFamilyTyConApp,
+ mkDictTy, isDictLikeTy, isClassPred,
+ isEqPred, allPred, mkEqPred,
+ mkClassPred, getClassPredTys, getClassPredTys_maybe,
+ isTyVarClassPred,
+ mkIPPred, isIPPred,
-- ** Common type constructors
funTyCon,
-- ** Predicates on types
- isTyVarTy, isFunTy, isDictTy,
+ isTyVarTy, isFunTy, isPredTy,
+ isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe,
-- (Lifting and boxity)
isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
@@ -65,8 +72,7 @@ module Type (
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
-
- tySuperKind, coSuperKind,
+ tySuperKind,
-- ** Common Kind type constructors
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
@@ -74,19 +80,18 @@ module Type (
-- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- expandTypeSynonyms,
+ exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms,
typeSize,
-- * Type comparison
- coreEqType, coreEqType2,
- tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+ eqType, eqTypeX, eqTypes, cmpType, cmpTypes,
+ eqPred, eqPredX, cmpPred, eqKind,
-- * Forcing evaluation of types
- seqType, seqTypes,
+ seqType, seqTypes, seqPred,
-- * Other views onto Types
- coreView, tcView, kindView,
+ coreView, tcView,
repType,
@@ -103,18 +108,22 @@ module Type (
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope,
+ getTvSubstEnv, setTvSubstEnv,
+ zapTvSubstEnv, getTvInScope,
extendTvInScope, extendTvInScopeList,
- extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
+ extendTvSubst, extendTvSubstList,
+ isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst, unionTvSubst,
-- ** Performing substitution on types
substTy, substTys, substTyWith, substTysWith, substTheta,
- substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
+ substPred, substTyVar, substTyVars, substTyVarBndr,
+ deShadowTy, lookupTyVar,
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
- pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+ pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
+ pprKind, pprParendKind,
pprSourceTyCon
) where
@@ -133,8 +142,11 @@ import VarSet
import Class
import TyCon
+import TysPrim
-- others
+import BasicTypes ( IPName )
+import Name ( Name )
import StaticFlags
import Util
import Outputable
@@ -219,31 +231,9 @@ coreView :: Type -> Maybe Type
-- its underlying representation type.
-- Returns Nothing if there is nothing to look through.
--
--- In the case of @newtype@s, it returns one of:
---
--- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated)
---
--- 2) The newtype representation (otherwise), meaning the
--- type written in the RHS of the newtype declaration,
--- which may itself be a newtype
---
--- For example, with:
---
--- > newtype R = MkR S
--- > newtype S = MkS T
--- > newtype T = MkT (T -> T)
---
--- 'expandNewTcApp' on:
---
--- * @R@ gives @Just S@
--- * @S@ gives @Just T@
--- * @T@ gives @Nothing@ (no expansion)
-
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
-coreView (PredTy p)
- | isEqPred p = Nothing
- | otherwise = Just (predTypeRep p)
+coreView (PredTy p) = Just (predTypeRep p)
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-- Its important to use mkAppTys, rather than (foldl AppTy),
@@ -252,7 +242,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc
coreView _ = Nothing
-
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
@@ -283,14 +272,6 @@ expandTypeSynonyms ty
go_pred (ClassP c ts) = ClassP c (map go ts)
go_pred (IParam ip t) = IParam ip (go t)
go_pred (EqPred t1 t2) = EqPred (go t1) (go t2)
-
------------------------------------------------
-{-# INLINE kindView #-}
-kindView :: Kind -> Maybe Kind
--- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
-
--- For the moment, we don't even handle synonyms in kinds
-kindView _ = Nothing
\end{code}
@@ -305,12 +286,6 @@ kindView _ = Nothing
TyVarTy
~~~~~~~
\begin{code}
-mkTyVarTy :: TyVar -> Type
-mkTyVarTy = TyVarTy
-
-mkTyVarTys :: [TyVar] -> [Type]
-mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
-
-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
getTyVar :: String -> Type -> TyVar
@@ -384,10 +359,9 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
- | isDecomposableTyCon tc || length tys > tyConArity tc
- = case snocView tys of -- never create unsaturated type family apps
- Just (tys', ty') -> Just (TyConApp tc tys', ty')
- Nothing -> Nothing
+ | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc
+ , Just (tys', ty') <- snocView tys
+ = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps!
repSplitAppTy_maybe _other = Nothing
-------------
splitAppTy :: Type -> (Type, Type)
@@ -427,8 +401,7 @@ splitAppTys ty = split ty ty []
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
-mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
-mkFunTy arg res = FunTy arg res
+mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
@@ -496,20 +469,6 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty)
~~~~~~~~
\begin{code}
--- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
--- Applies its arguments to the constructor from left to right
-mkTyConApp :: TyCon -> [Type] -> Type
-mkTyConApp tycon tys
- | isFunTyCon tycon, [ty1,ty2] <- tys
- = FunTy ty1 ty2
-
- | otherwise
- = TyConApp tycon tys
-
--- | Create the plain type constructor type which has been applied to no type arguments at all.
-mkTyConTy :: TyCon -> Type
-mkTyConTy tycon = mkTyConApp tycon []
-
-- splitTyConApp "looks through" synonyms, because they don't
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
@@ -612,13 +571,16 @@ repType ty
= go [] ty
where
go :: [TyCon] -> Type -> Type
- go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
- = go rec_nts ty'
-
- go rec_nts (ForAllTy _ ty) -- Look through foralls
+ go rec_nts (ForAllTy _ ty) -- Look through foralls
= go rec_nts ty
- go rec_nts (TyConApp tc tys) -- Expand newtypes
+ go rec_nts (PredTy p) -- Expand predicates
+ = go rec_nts (predTypeRep p)
+
+ go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms
+ | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
+ = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
+
| Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
= go rec_nts' ty'
@@ -756,13 +718,32 @@ applyTysD doc orig_fun_ty arg_tys
%************************************************************************
%* *
-\subsection{Source types}
+ Pred
%* *
%************************************************************************
-Source types are always lifted.
+Polymorphic functions over Pred
-The key function is predTypeRep which gives the representation of a source type:
+\begin{code}
+allPred :: (a -> Bool) -> Pred a -> Bool
+allPred p (ClassP _ ts) = all p ts
+allPred p (IParam _ t) = p t
+allPred p (EqPred t1 t2) = p t1 && p t2
+
+isClassPred :: Pred a -> Bool
+isClassPred (ClassP {}) = True
+isClassPred _ = False
+
+isEqPred :: Pred a -> Bool
+isEqPred (EqPred {}) = True
+isEqPred _ = False
+
+isIPPred :: Pred a -> Bool
+isIPPred (IParam {}) = True
+isIPPred _ = False
+\end{code}
+
+Make PredTypes
\begin{code}
mkPredTy :: PredType -> Type
@@ -771,91 +752,115 @@ mkPredTy pred = PredTy pred
mkPredTys :: ThetaType -> [Type]
mkPredTys preds = map PredTy preds
-isEqPred :: PredType -> Bool
-isEqPred (EqPred _ _) = True
-isEqPred _ = False
-
predTypeRep :: PredType -> Type
-- ^ Convert a 'PredType' to its representation type. However, it unwraps
-- only the outermost level; for example, the result might be a newtype application
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
- -- Result might be a newtype application, but the consumer will
- -- look through that too if necessary
-predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
-
-mkFamilyTyConApp :: TyCon -> [Type] -> Type
--- ^ Given a family instance TyCon and its arg types, return the
--- corresponding family type. E.g:
---
--- > data family T a
--- > data instance T (Maybe b) = MkT b
---
--- Where the instance tycon is :RTL, so:
---
--- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
-mkFamilyTyConApp tc tys
- | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
- , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
- = mkTyConApp fam_tc (substTys fam_subst fam_tys)
- | otherwise
- = mkTyConApp tc tys
+predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2]
--- | Pretty prints a 'TyCon', using the family instance in case of a
--- representation tycon. For example:
---
--- > data T [a] = ...
---
--- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
-pprSourceTyCon :: TyCon -> SDoc
-pprSourceTyCon tycon
- | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
- = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
- | otherwise
- = ppr tycon
+splitPredTy_maybe :: Type -> Maybe PredType
+-- Returns Just for predicates only
+splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty'
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe _ = Nothing
-isDictTy :: Type -> Bool
-isDictTy ty = case splitTyConApp_maybe ty of
- Just (tc, _) -> isClassTyCon tc
- Nothing -> False
+isPredTy :: Type -> Bool
+isPredTy ty = isJust (splitPredTy_maybe ty)
\end{code}
+--------------------- Equality types ---------------------------------
+\begin{code}
+isReflPredTy :: Type -> Bool
+isReflPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> ty1 `eqType` ty2
+ _ -> False
+
+splitEqPredTy_maybe :: Type -> Maybe (Type,Type)
+splitEqPredTy_maybe ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> Just (ty1,ty2)
+ _ -> Nothing
+
+isEqPredTy :: Type -> Bool
+isEqPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred {}) -> True
+ _ -> False
+
+-- | Creates a type equality predicate
+mkEqPred :: (a, a) -> Pred a
+mkEqPred (ty1, ty2) = EqPred ty1 ty2
+\end{code}
-%************************************************************************
-%* *
- The free variables of a type
-%* *
-%************************************************************************
-
+--------------------- Dictionary types ---------------------------------
\begin{code}
-tyVarsOfType :: Type -> TyVarSet
--- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
-tyVarsOfType (TyVarTy tv) = unitVarSet tv
-tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
-tyVarsOfType (PredTy sty) = tyVarsOfPred sty
-tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
-tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder
- -- can mention type variables!
- | isTyVar tv = inner_tvs `delVarSet` tv
- | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) )
- inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv)
- where
- inner_tvs = tyVarsOfType ty
+mkClassPred :: Class -> [Type] -> PredType
+mkClassPred clas tys = ClassP clas tys
-tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+isDictTy :: Type -> Bool
+isDictTy ty = case splitPredTy_maybe ty of
+ Just p -> isClassPred p
+ Nothing -> False
+
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys
+isTyVarClassPred _ = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys _ = panic "getClassPredTys"
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (ClassP clas tys)
+
+isDictLikeTy :: Type -> Bool
+-- Note [Dictionary-like types]
+isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
+isDictLikeTy (PredTy p) = isClassPred p
+isDictLikeTy (TyConApp tc tys)
+ | isTupleTyCon tc = all isDictLikeTy tys
+isDictLikeTy _ = False
+\end{code}
-tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty) = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
-tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+Note [Dictionary-like types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Being "dictionary-like" means either a dictionary type or a tuple thereof.
+In GHC 6.10 we build implication constraints which construct such tuples,
+and if we land up with a binding
+ t :: (C [a], Eq [a])
+ t = blah
+then we want to treat t as cheap under "-fdicts-cheap" for example.
+(Implication constraints are normally inlined, but sadly not if the
+occurrence is itself inside an INLINE function! Until we revise the
+handling of implication constraints, that is.) This turned out to
+be important in getting good arities in DPH code. Example:
+
+ class C a
+ class D a where { foo :: a -> a }
+ instance C a => D (Maybe a) where { foo x = x }
+
+ bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
+ {-# INLINE bar #-}
+ bar x y = (foo (Just x), foo (Just y))
+
+Then 'bar' should jolly well have arity 4 (two dicts, two args), but
+we ended up with something like
+ bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
+ in \x,y. <blah>)
+
+This is all a bit ad-hoc; eg it relies on knowing that implication
+constraints build tuples.
+
+--------------------- Implicit parameters ---------------------------------
-tyVarsOfTheta :: ThetaType -> TyVarSet
-tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+\begin{code}
+mkIPPred :: IPName Name -> Type -> PredType
+mkIPPred ip ty = IParam ip ty
\end{code}
-
%************************************************************************
%* *
Size
@@ -867,14 +872,9 @@ typeSize :: Type -> Int
typeSize (TyVarTy _) = 1
typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2
typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2
-typeSize (PredTy p) = predSize p
+typeSize (PredTy p) = predSize typeSize p
typeSize (ForAllTy _ t) = 1 + typeSize t
typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
-
-predSize :: PredType -> Int
-predSize (IParam _ t) = 1 + typeSize t
-predSize (ClassP _ ts) = 1 + sum (map typeSize ts)
-predSize (EqPred t1 t2) = typeSize t1 + typeSize t2
\end{code}
@@ -904,8 +904,37 @@ predFamInsts :: PredType -> [(TyCon, [Type])]
predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
predFamInsts (IParam _ ty) = tyFamInsts ty
predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
-\end{code}
+mkFamilyTyConApp :: TyCon -> [Type] -> Type
+-- ^ Given a family instance TyCon and its arg types, return the
+-- corresponding family type. E.g:
+--
+-- > data family T a
+-- > data instance T (Maybe b) = MkT b
+--
+-- Where the instance tycon is :RTL, so:
+--
+-- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
+mkFamilyTyConApp tc tys
+ | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
+ , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
+ = mkTyConApp fam_tc (substTys fam_subst fam_tys)
+ | otherwise
+ = mkTyConApp tc tys
+
+-- | Pretty prints a 'TyCon', using the family instance in case of a
+-- representation tycon. For example:
+--
+-- > data T [a] = ...
+--
+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
+pprSourceTyCon :: TyCon -> SDoc
+pprSourceTyCon tycon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
+ | otherwise
+ = ppr tycon
+\end{code}
%************************************************************************
%* *
@@ -924,6 +953,7 @@ isUnLiftedType :: Type -> Bool
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty
+isUnLiftedType (PredTy p) = isEqPred p
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
isUnLiftedType _ = False
@@ -949,9 +979,9 @@ isAlgType ty
isClosedAlgType :: Type -> Bool
isClosedAlgType ty
= case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc && not (isFamilyTyCon tc)
- _other -> False
+ Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+ -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+ _other -> False
\end{code}
\begin{code}
@@ -977,7 +1007,8 @@ isStrictType _ = False
-- poking the dictionary component, which is wrong.)
isStrictPred :: PredType -> Bool
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred _ = False
+isStrictPred (EqPred {}) = True
+isStrictPred (IParam {}) = False
\end{code}
\begin{code}
@@ -992,6 +1023,64 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of
\end{code}
+%************************************************************************
+%* *
+ The "exact" free variables of a type
+%* *
+%************************************************************************
+
+Note [Silly type synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ type T a = Int
+What are the free tyvars of (T x)? Empty, of course!
+Here's the example that Ralf Laemmel showed me:
+ foo :: (forall a. C u a -> C u a) -> u
+ mappend :: Monoid u => u -> u -> u
+
+ bar :: Monoid u => u
+ bar = foo (\t -> t `mappend` t)
+We have to generalise at the arg to f, and we don't
+want to capture the constraint (Monad (C u a)) because
+it appears to mention a. Pretty silly, but it was useful to him.
+
+exactTyVarsOfType is used by the type checker to figure out exactly
+which type variables are mentioned in a type. It's also used in the
+smart-app checking code --- see TcExpr.tcIdApp
+
+On the other hand, consider a *top-level* definition
+ f = (\x -> x) :: T a -> T a
+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
+if we have an application like (f "x") we get a confusing error message
+involving Any. So the conclusion is this: when generalising
+ - at top level use tyVarsOfType
+ - in nested bindings use exactTyVarsOfType
+See Trac #1813 for example.
+
+\begin{code}
+exactTyVarsOfType :: Type -> TyVarSet
+-- Find the free type variables (of any kind)
+-- but *expand* type synonyms. See Note [Silly type synonym] above.
+exactTyVarsOfType ty
+ = go ty
+ where
+ go ty | Just ty' <- tcView ty = go ty' -- This is the key line
+ go (TyVarTy tv) = unitVarSet tv
+ go (TyConApp _ tys) = exactTyVarsOfTypes tys
+ go (PredTy ty) = go_pred ty
+ go (FunTy arg res) = go arg `unionVarSet` go res
+ go (AppTy fun arg) = go fun `unionVarSet` go arg
+ go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
+
+ go_pred (IParam _ ty) = go ty
+ go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+ go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
+
+exactTyVarsOfTypes :: [Type] -> TyVarSet
+exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Sequencing on types}
@@ -1003,7 +1092,7 @@ seqType :: Type -> ()
seqType (TyVarTy tv) = tv `seq` ()
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
-seqType (PredTy p) = seqPred p
+seqType (PredTy p) = seqPred seqType p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
@@ -1011,115 +1100,40 @@ seqTypes :: [Type] -> ()
seqTypes [] = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
-seqPred :: PredType -> ()
-seqPred (ClassP c tys) = c `seq` seqTypes tys
-seqPred (IParam n ty) = n `seq` seqType ty
-seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2
+seqPred :: (a -> ()) -> Pred a -> ()
+seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys
+seqPred seqt (IParam n ty) = n `seq` seqt ty
+seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2
\end{code}
%************************************************************************
%* *
- Equality for Core types
+ Comparision for types
(We don't use instances so that we know where it happens)
%* *
%************************************************************************
-Note that eqType works right even for partial applications of newtypes.
-See Note [Newtype eta] in TyCon.lhs
-
\begin{code}
--- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
-coreEqType :: Type -> Type -> Bool
-coreEqType t1 t2 = coreEqType2 rn_env t1 t2
- where
- rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
-
-coreEqType2 :: RnEnv2 -> Type -> Type -> Bool
-coreEqType2 rn_env t1 t2
- = eq rn_env t1 t2
- where
- eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
- eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2
- eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2
- eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2
- eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- | tc1 == tc2, all2 (eq env) tys1 tys2 = True
- -- The lengths should be equal because
- -- the two types have the same kind
- -- NB: if the type constructors differ that does not
- -- necessarily mean that the types aren't equal
- -- (synonyms, newtypes)
- -- Even if the type constructors are the same, but the arguments
- -- differ, the two types could be the same (e.g. if the arg is just
- -- ignored in the RHS). In both these cases we fall through to an
- -- attempt to expand one side or the other.
-
- -- Now deal with newtypes, synonyms, pred-tys
- eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2
- | Just t2' <- coreView t2 = eq env t1 t2'
-
- -- Fall through case; not equal!
- eq _ _ _ = False
-\end{code}
-
+eqKind :: Kind -> Kind -> Bool
+eqKind = eqType
-%************************************************************************
-%* *
- Comparision for source types
- (We don't use instances so that we know where it happens)
-%* *
-%************************************************************************
-
-\begin{code}
-tcEqType :: Type -> Type -> Bool
+eqType :: Type -> Type -> Bool
-- ^ Type equality on source types. Does not look through @newtypes@ or
-- 'PredType's, but it does look through type synonyms.
-tcEqType t1 t2 = isEqual $ cmpType t1 t2
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-
-tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or
--- 'PredType's, but it does look through type synonyms.
-tcCmpType t1 t2 = cmpType t1 t2
+eqType t1 t2 = isEqual $ cmpType t1 t2
-tcCmpTypes :: [Type] -> [Type] -> Ordering
-tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
+eqTypeX :: RnEnv2 -> Type -> Type -> Bool
+eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
+eqTypes :: [Type] -> [Type] -> Bool
+eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
-tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
+eqPred :: PredType -> PredType -> Bool
+eqPred p1 p2 = isEqual $ cmpPred p1 p2
-tcCmpPred :: PredType -> PredType -> Ordering
-tcCmpPred p1 p2 = cmpPred p1 p2
-
-tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool
-tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-\end{code}
-
-\begin{code}
--- | Checks whether the second argument is a subterm of the first. (We don't care
--- about binders, as we are only interested in syntactic subterms.)
-tcPartOfType :: Type -> Type -> Bool
-tcPartOfType t1 t2
- | tcEqType t1 t2 = True
-tcPartOfType t1 t2
- | Just t2' <- tcView t2 = tcPartOfType t1 t2'
-tcPartOfType _ (TyVarTy _) = False
-tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
-tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
-tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
-
-tcPartOfPred :: Type -> PredType -> Bool
-tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
-tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts
-tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+eqPredX :: RnEnv2 -> PredType -> PredType -> Bool
+eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
\end{code}
Now here comes the real worker
@@ -1141,8 +1155,13 @@ cmpPred p1 p2 = cmpPredX rn_env p1 p2
rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2))
cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2
- | Just t2' <- tcView t2 = cmpTypeX env t1 t2'
+cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2
+ | Just t2' <- coreView t2 = cmpTypeX env t1 t2'
+-- We expand predicate types, because in Core-land we have
+-- lots of definitions like
+-- fOrdBool :: Ord Bool
+-- fOrdBool = D:Ord .. .. ..
+-- So the RHS has a data type
cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2
cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
@@ -1199,8 +1218,8 @@ PredTypes are used as a FM key in TcSimplify,
so we take the easy path and make them an instance of Ord
\begin{code}
-instance Eq PredType where { (==) = tcEqPred }
-instance Ord PredType where { compare = tcCmpPred }
+instance Eq PredType where { (==) = eqPred }
+instance Ord PredType where { compare = cmpPred }
\end{code}
@@ -1211,81 +1230,6 @@ instance Ord PredType where { compare = tcCmpPred }
%************************************************************************
\begin{code}
--- | Type substitution
---
--- #tvsubst_invariant#
--- The following invariants must hold of a 'TvSubst':
---
--- 1. The in-scope set is needed /only/ to
--- guide the generation of fresh uniques
---
--- 2. In particular, the /kind/ of the type variables in
--- the in-scope set is not relevant
---
--- 3. The substition is only applied ONCE! This is because
--- in general such application will not reached a fixed point.
-data TvSubst
- = TvSubst InScopeSet -- The in-scope type variables
- TvSubstEnv -- The substitution itself
- -- See Note [Apply Once]
- -- and Note [Extending the TvSubstEnv]
-
-{- ----------------------------------------------------------
-
-Note [Apply Once]
-~~~~~~~~~~~~~~~~~
-We use TvSubsts to instantiate things, and we might instantiate
- forall a b. ty
-\with the types
- [a, b], or [b, a].
-So the substition might go [a->b, b->a]. A similar situation arises in Core
-when we find a beta redex like
- (/\ a /\ b -> e) b a
-Then we also end up with a substition that permutes type variables. Other
-variations happen to; for example [a -> (a, b)].
-
- ***************************************************
- *** So a TvSubst must be applied precisely once ***
- ***************************************************
-
-A TvSubst is not idempotent, but, unlike the non-idempotent substitution
-we use during unifications, it must not be repeatedly applied.
-
-Note [Extending the TvSubst]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #tvsubst_invariant# for the invariants that must hold.
-
-This invariant allows a short-cut when the TvSubstEnv is empty:
-if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
-then (substTy subst ty) does nothing.
-
-For example, consider:
- (/\a. /\b:(a~Int). ...b..) Int
-We substitute Int for 'a'. The Unique of 'b' does not change, but
-nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
-
-This invariant has several crucial consequences:
-
-* In substTyVarBndr, we need extend the TvSubstEnv
- - if the unique has changed
- - or if the kind has changed
-
-* In substTyVar, we do not need to consult the in-scope set;
- the TvSubstEnv is enough
-
-* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
-
-
--------------------------------------------------------------- -}
-
--- | A substitition of 'Type's for 'TyVar's
-type TvSubstEnv = TyVarEnv Type
- -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
- -- invariant discussed in Note [Apply Once]), and also independently
- -- in the middle of matching, and unification (see Types.Unify)
- -- So you have to look at the context to know if it's idempotent or
- -- apply-once or whatever
-
emptyTvSubstEnv :: TvSubstEnv
emptyTvSubstEnv = emptyVarEnv
@@ -1303,11 +1247,11 @@ composeTvSubst in_scope env1 env2
subst1 = TvSubst in_scope env1
emptyTvSubst :: TvSubst
-emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
+emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv
isEmptyTvSubst :: TvSubst -> Bool
-- See Note [Extending the TvSubstEnv]
-isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv
mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
mkTvSubst = TvSubst
@@ -1321,34 +1265,34 @@ getTvInScope (TvSubst in_scope _) = in_scope
isInScope :: Var -> TvSubst -> Bool
isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
-notElemTvSubst :: TyVar -> TvSubst -> Bool
-notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
+notElemTvSubst :: TyCoVar -> TvSubst -> Bool
+notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv)
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
-setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
+setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv
zapTvSubstEnv :: TvSubst -> TvSubst
zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv
extendTvInScope :: TvSubst -> Var -> TvSubst
-extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env
+extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv
extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
-extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv
extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
-extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
+extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty)
extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
-extendTvSubstList (TvSubst in_scope env) tvs tys
- = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
+extendTvSubstList (TvSubst in_scope tenv) tvs tys
+ = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys))
unionTvSubst :: TvSubst -> TvSubst -> TvSubst
-- Works when the ranges are disjoint
-unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
- = ASSERT( not (env1 `intersectsVarEnv` env2) )
+unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2)
+ = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) )
TvSubst (in_scope1 `unionInScope` in_scope2)
- (env1 `plusVarEnv` env2)
+ (tenv1 `plusVarEnv` tenv2)
-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
@@ -1370,7 +1314,7 @@ unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
-- environment, hence "open"
mkOpenTvSubst :: TvSubstEnv -> TvSubst
-mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv
-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
-- environment, hence "open"
@@ -1396,7 +1340,7 @@ zipTopTvSubst tyvars tys
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
| debugIsOn && (length tyvars /= length tys)
- = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
+ = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv
| otherwise
= zip_ty_env tyvars tys emptyVarEnv
@@ -1421,10 +1365,10 @@ zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr
-- zip_ty_env _ _ env = env
instance Outputable TvSubst where
- ppr (TvSubst ins env)
+ ppr (TvSubst ins tenv)
= brackets $ sep[ ptext (sLit "TvSubst"),
nest 2 (ptext (sLit "In scope:") <+> ppr ins),
- nest 2 (ptext (sLit "Env:") <+> ppr env) ]
+ nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ]
\end{code}
%************************************************************************
@@ -1499,29 +1443,34 @@ subst_ty subst ty
ForAllTy tv' $! (subst_ty subst' ty)
substTyVar :: TvSubst -> TyVar -> Type
-substTyVar subst@(TvSubst _ _) tv
- = case lookupTyVar subst tv of {
- Nothing -> TyVarTy tv;
- Just ty -> ty -- See Note [Apply Once]
- }
+substTyVar (TvSubst _ tenv) tv
+ | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once]
+ | otherwise = ASSERT( isTyVar tv ) TyVarTy tv
+ -- We do not require that the tyvar is in scope
+ -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau)
+ -- and it's a nuisance to bring all the free vars of tau into
+ -- scope --- and then force that thunk at every tyvar
+ -- Instead we have an ASSERT in substTyVarBndr to check for capture
substTyVars :: TvSubst -> [TyVar] -> [Type]
substTyVars subst tvs = map (substTyVar subst) tvs
lookupTyVar :: TvSubst -> TyVar -> Maybe Type
-- See Note [Extending the TvSubst]
-lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv
+lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv
-substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
-substTyVarBndr subst@(TvSubst in_scope env) old_var
- = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
+substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
+substTyVarBndr subst@(TvSubst in_scope tenv) old_var
+ = ASSERT2( _no_capture, ppr old_var $$ ppr subst )
+ (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
where
- is_co_var = isCoVar old_var
+ new_env | no_change = delVarEnv tenv old_var
+ | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
- new_env | no_change = delVarEnv env old_var
- | otherwise = extendVarEnv env old_var (TyVarTy new_var)
+ _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv))
+ -- Check that we are not capturing something in the substitution
- no_change = new_var == old_var && not is_co_var
+ no_change = new_var == old_var
-- no_change means that the new_var is identical in
-- all respects to the old_var (same unique, same kind)
-- See Note [Extending the TvSubst]
@@ -1532,14 +1481,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var
-- (\x.e) with id_subst = [x |-> e']
-- Here we must simply zap the substitution for x
- new_var = uniqAway in_scope subst_old_var
+ new_var = uniqAway in_scope old_var
-- The uniqAway part makes sure the new variable is not already in scope
-
- subst_old_var -- subst_old_var is old_var with the substitution applied to its kind
- -- It's only worth doing the substitution for coercions,
- -- becuase only they can have free type variables
- | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var))
- | otherwise = old_var
\end{code}
----------------------------------------------------
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 85514091a4bcc06d38ae5c59c044292feea851c4..db41403a4b46b009779dbc5e342d579b63e19cfb 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -7,44 +7,35 @@
\begin{code}
-- We expose the relevant stuff from this module via the Type module
{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module TypeRep (
TyThing(..),
Type(..),
- PredType(..), -- to friends
+ Pred(..), -- to friends
- Kind, ThetaType, -- Synonyms
+ Kind, SuperKind,
+ PredType, ThetaType, -- Synonyms
- funTyCon, funTyConName,
+ -- Functions over types
+ mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
+ isLiftedTypeKind, isCoercionKind,
- -- Pretty-printing
+ -- Pretty-printing
pprType, pprParendType, pprTypeApp,
pprTyThing, pprTyThingCategory,
- pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-
- -- Kinds
- liftedTypeKind, unliftedTypeKind, openTypeKind,
- argTypeKind, ubxTupleKind,
- isLiftedTypeKindCon, isLiftedTypeKind,
- mkArrowKind, mkArrowKinds, isCoercionKind,
- coVarPred,
-
- -- Kind constructors...
- liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
- argTypeKindTyCon, ubxTupleKindTyCon,
-
- -- And their names
- unliftedTypeKindTyConName, openTypeKindTyConName,
- ubxTupleKindTyConName, argTypeKindTyConName,
- liftedTypeKindTyConName,
-
- -- Super Kinds
- tySuperKind, coSuperKind,
- isTySuperKind, isCoSuperKind,
- tySuperKindTyCon, coSuperKindTyCon,
-
- pprKind, pprParendKind
+ pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
+ pprKind, pprParendKind,
+ Prec(..), maybeParen, pprTcApp, pprTypeNameApp,
+ pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow,
+
+ -- Free variables
+ tyVarsOfType, tyVarsOfTypes,
+ tyVarsOfPred, tyVarsOfTheta,
+ varsOfPred, varsOfTheta,
+ predSize,
+
+ -- Substitutions
+ TvSubst(..), TvSubstEnv
) where
#include "HsVersions.h"
@@ -53,6 +44,8 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName )
-- friends:
import Var
+import VarEnv
+import VarSet
import Name
import BasicTypes
import TyCon
@@ -62,9 +55,12 @@ import Class
import PrelNames
import Outputable
import FastString
+import Pair
-- libraries
-import Data.Data hiding ( TyCon )
+import qualified Data.Data as Data hiding ( TyCon )
+import qualified Data.Foldable as Data
+import qualified Data.Traversable as Data
\end{code}
----------------------
@@ -120,13 +116,14 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'.
\begin{code}
-- | The key representation of types within the compiler
data Type
- = TyVarTy TyVar -- ^ Vanilla type variable
+ = TyVarTy TyVar -- ^ Vanilla type variable (*never* a coercion variable)
| AppTy
Type
Type -- ^ Type application to something other than a 'TyCon'. Parameters:
--
- -- 1) Function: must /not/ be a 'TyConApp', must be another 'AppTy', or 'TyVarTy'
+ -- 1) Function: must /not/ be a 'TyConApp',
+ -- must be another 'AppTy', or 'TyVarTy'
--
-- 2) Argument type
@@ -135,31 +132,35 @@ data Type
[Type] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
-- Invariant: saturated appliations of 'FunTyCon' must
-- use 'FunTy' and saturated synonyms must use their own
- -- constructors. However, /unsaturated/ 'FunTyCon's do appear as 'TyConApp's.
+ -- constructors. However, /unsaturated/ 'FunTyCon's
+ -- do appear as 'TyConApp's.
-- Parameters:
--
-- 1) Type constructor being applied to.
--
- -- 2) Type arguments. Might not have enough type arguments here to saturate the constructor.
- -- Even type synonyms are not necessarily saturated; for example unsaturated type synonyms
- -- can appear as the right hand side of a type synonym.
+ -- 2) Type arguments. Might not have enough type arguments
+ -- here to saturate the constructor.
+ -- Even type synonyms are not necessarily saturated;
+ -- for example unsaturated type synonyms
+ -- can appear as the right hand side of a type synonym.
| FunTy
- Type
+ Type
Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@
+ -- See Note [Equality-constrained types]
| ForAllTy
- TyVar
+ TyCoVar -- Type variable
Type -- ^ A polymorphic type
| PredTy
PredType -- ^ The type of evidence for a type predictate.
-- Note that a @PredTy (EqPred _ _)@ can appear only as the kind
- -- of a coercion variable; never as the argument or result
- -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
+ -- of a coercion variable; never as the argument or result of a
+ -- 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
-- See Note [PredTy], and Note [Equality predicates]
- deriving (Data, Typeable)
+ deriving (Data.Data, Data.Typeable)
-- | The key type representing kinds in the compiler.
-- Invariant: a kind is always in one of these forms:
@@ -177,6 +178,15 @@ type Kind = Type
type SuperKind = Type
\end{code}
+Note [Equality-constrained types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type forall ab. (a ~ [b]) => blah
+is encoded like this:
+
+ ForAllTy (a:*) $ ForAllTy (b:*) $
+ FunTy (PredTy (EqPred a [b]) $
+ blah
+
-------------------------------------
Note [PredTy]
@@ -197,11 +207,13 @@ type SuperKind = Type
-- > h :: (r\l) => {r} => {l::Int | r}
--
-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"
-data PredType
- = ClassP Class [Type] -- ^ Class predicate e.g. @Eq a@
- | IParam (IPName Name) Type -- ^ Implicit parameter e.g. @?x :: Int@
- | EqPred Type Type -- ^ Equality predicate e.g @ty1 ~ ty2@
- deriving (Data, Typeable)
+type PredType = Pred Type
+
+data Pred a -- Typically 'a' is instantiated with Type or Coercion
+ = ClassP Class [a] -- ^ Class predicate e.g. @Eq a@
+ | IParam (IPName Name) a -- ^ Implicit parameter e.g. @?x :: Int@
+ | EqPred a a -- ^ Equality predicate e.g @ty1 ~ ty2@
+ deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor)
-- | A collection of 'PredType's
type ThetaType = [PredType]
@@ -238,6 +250,89 @@ We often need to make a "wildcard" (c::PredTy..). We always use the same
name (wildCoVarName), since it's not mentioned.
+%************************************************************************
+%* *
+ Simple constructors
+%* *
+%************************************************************************
+
+These functions are here so that they can be used by TysPrim,
+which in turn is imported by Type
+
+\begin{code}
+mkTyVarTy :: TyVar -> Type
+mkTyVarTy = TyVarTy
+
+mkTyVarTys :: [TyVar] -> [Type]
+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
+
+-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
+-- Applies its arguments to the constructor from left to right
+mkTyConApp :: TyCon -> [Type] -> Type
+mkTyConApp tycon tys
+ | isFunTyCon tycon, [ty1,ty2] <- tys
+ = FunTy ty1 ty2
+
+ | otherwise
+ = TyConApp tycon tys
+
+-- | Create the plain type constructor type which has been applied to no type arguments at all.
+mkTyConTy :: TyCon -> Type
+mkTyConTy tycon = mkTyConApp tycon []
+
+isLiftedTypeKind :: Kind -> Bool
+-- This function is here because it's used in the pretty printer
+isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey
+isLiftedTypeKind _ = False
+
+isCoercionKind :: Kind -> Bool
+-- All coercions are of form (ty1 ~ ty2)
+-- This function is here rather than in Coercion, because it
+-- is used in a knot-tied way to enforce invariants in Var
+isCoercionKind (PredTy (EqPred {})) = True
+isCoercionKind _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Free variables of types and coercions
+%* *
+%************************************************************************
+
+\begin{code}
+tyVarsOfPred :: PredType -> TyCoVarSet
+tyVarsOfPred = varsOfPred tyVarsOfType
+
+tyVarsOfTheta :: ThetaType -> TyCoVarSet
+tyVarsOfTheta = varsOfTheta tyVarsOfType
+
+tyVarsOfType :: Type -> VarSet
+-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
+tyVarsOfType (TyVarTy v) = unitVarSet v
+tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
+tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty
+tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
+tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
+tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
+
+tyVarsOfTypes :: [Type] -> TyVarSet
+tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
+
+varsOfPred :: (a -> VarSet) -> Pred a -> VarSet
+varsOfPred f (IParam _ ty) = f ty
+varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys
+varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2
+
+varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet
+varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet
+
+predSize :: (a -> Int) -> Pred a -> Int
+predSize size (IParam _ t) = 1 + size t
+predSize size (ClassP _ ts) = 1 + sum (map size ts)
+predSize size (EqPred t1 t2) = size t1 + size t2
+\end{code}
+
%************************************************************************
%* *
TyThing
@@ -253,6 +348,7 @@ funTyCon and all the types in TysPrim.
data TyThing = AnId Id
| ADataCon DataCon
| ATyCon TyCon
+ | ACoAxiom CoAxiom
| AClass Class
instance Outputable TyThing where
@@ -263,6 +359,7 @@ pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor")
+pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom")
pprTyThingCategory (AClass _) = ptext (sLit "Class")
pprTyThingCategory (AnId _) = ptext (sLit "Identifier")
pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
@@ -270,6 +367,7 @@ pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
instance NamedThing TyThing where -- Can't put this with the type
getName (AnId id) = getName id -- decl, because the DataCon instance
getName (ATyCon tc) = getName tc -- isn't visible there
+ getName (ACoAxiom cc) = getName cc
getName (AClass cl) = getName cl
getName (ADataCon dc) = dataConName dc
\end{code}
@@ -277,131 +375,92 @@ instance NamedThing TyThing where -- Can't put this with the type
%************************************************************************
%* *
- Wired-in type constructors
+ Substitutions
+ Data type defined here to avoid unnecessary mutual recursion
%* *
%************************************************************************
-We define a few wired-in type constructors here to avoid module knots
-
\begin{code}
---------------------------
--- First the TyCons...
-
--- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
-funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
- openTypeKindTyCon, unliftedTypeKindTyCon,
- ubxTupleKindTyCon, argTypeKindTyCon
- :: TyCon
-funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
- openTypeKindTyConName, unliftedTypeKindTyConName,
- ubxTupleKindTyConName, argTypeKindTyConName
- :: Name
-
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
- -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
- -- But if we do that we get kind errors when saying
- -- instance Control.Arrow (->)
- -- becuase the expected kind is (*->*->*). The trouble is that the
- -- expected/actual stuff in the unifier does not go contra-variant, whereas
- -- the kind sub-typing does. Sigh. It really only matters if you use (->) in
- -- a prefix way, thus: (->) Int# Int#. And this is unusual.
-
-
-tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
-coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
-
-liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
-openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
-ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
-argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
-
---------------------------
--- ... and now their names
-
-tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
-coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon
-liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
-openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
-unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
-ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
-argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
-funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
-
-mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
-mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
- key
- (ATyCon tycon)
- BuiltInSyntax
- -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
- -- because they are never in scope in the source
-
-------------------
--- We also need Kinds and SuperKinds, locally and in TyCon
-
-kindTyConType :: TyCon -> Type
-kindTyConType kind = TyConApp kind []
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
-
-liftedTypeKind = kindTyConType liftedTypeKindTyCon
-unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
-openTypeKind = kindTyConType openTypeKindTyCon
-argTypeKind = kindTyConType argTypeKindTyCon
-ubxTupleKind = kindTyConType ubxTupleKindTyCon
+-- | Type substitution
+--
+-- #tvsubst_invariant#
+-- The following invariants must hold of a 'TvSubst':
+--
+-- 1. The in-scope set is needed /only/ to
+-- guide the generation of fresh uniques
+--
+-- 2. In particular, the /kind/ of the type variables in
+-- the in-scope set is not relevant
+--
+-- 3. The substition is only applied ONCE! This is because
+-- in general such application will not reached a fixed point.
+data TvSubst
+ = TvSubst InScopeSet -- The in-scope type variables
+ TvSubstEnv -- Substitution of types
+ -- See Note [Apply Once]
+ -- and Note [Extending the TvSubstEnv]
+
+-- | A substitition of 'Type's for 'TyVar's
+type TvSubstEnv = TyVarEnv Type
+ -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
+ -- invariant discussed in Note [Apply Once]), and also independently
+ -- in the middle of matching, and unification (see Types.Unify)
+ -- So you have to look at the context to know if it's idempotent or
+ -- apply-once or whatever
+\end{code}
--- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = FunTy k1 k2
+Note [Apply Once]
+~~~~~~~~~~~~~~~~~
+We use TvSubsts to instantiate things, and we might instantiate
+ forall a b. ty
+\with the types
+ [a, b], or [b, a].
+So the substition might go [a->b, b->a]. A similar situation arises in Core
+when we find a beta redex like
+ (/\ a /\ b -> e) b a
+Then we also end up with a substition that permutes type variables. Other
+variations happen to; for example [a -> (a, b)].
--- | Iterated application of 'mkArrowKind'
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+ ***************************************************
+ *** So a TvSubst must be applied precisely once ***
+ ***************************************************
-tySuperKind, coSuperKind :: SuperKind
-tySuperKind = kindTyConType tySuperKindTyCon
-coSuperKind = kindTyConType coSuperKindTyCon
+A TvSubst is not idempotent, but, unlike the non-idempotent substitution
+we use during unifications, it must not be repeatedly applied.
-isTySuperKind :: SuperKind -> Bool
-isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind _ = False
+Note [Extending the TvSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #tvsubst_invariant# for the invariants that must hold.
-isCoSuperKind :: SuperKind -> Bool
-isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
-isCoSuperKind _ = False
+This invariant allows a short-cut when the TvSubstEnv is empty:
+if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
+then (substTy subst ty) does nothing.
--------------------
--- Lastly we need a few functions on Kinds
+For example, consider:
+ (/\a. /\b:(a~Int). ...b..) Int
+We substitute Int for 'a'. The Unique of 'b' does not change, but
+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
-isLiftedTypeKindCon :: TyCon -> Bool
-isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
+This invariant has several crucial consequences:
-isLiftedTypeKind :: Kind -> Bool
-isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
-isLiftedTypeKind _ = False
+* In substTyVarBndr, we need extend the TvSubstEnv
+ - if the unique has changed
+ - or if the kind has changed
-isCoercionKind :: Kind -> Bool
--- All coercions are of form (ty1 ~ ty2)
--- This function is here rather than in Coercion,
--- because it's used in a knot-tied way to enforce invariants in Var
-isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind _ = False
+* In substTyVar, we do not need to consult the in-scope set;
+ the TvSubstEnv is enough
-coVarPred :: CoVar -> PredType
-coVarPred tv
- = ASSERT( isCoVar tv )
- case tyVarKind tv of
- PredTy eq -> eq
- other -> pprPanic "coVarPred" (ppr tv $$ ppr other)
+* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
\end{code}
%************************************************************************
%* *
-\subsection{The external interface}
-%* *
+ Pretty-printing types
+
+ Defined very early because of debug printing in assertions
+%* *
%************************************************************************
@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
@@ -422,43 +481,58 @@ maybeParen ctxt_prec inner_prec pretty
------------------
pprType, pprParendType :: Type -> SDoc
-pprType ty = ppr_type TopPrec ty
+pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
-pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
--- The first arg is the tycon, or sometimes class
--- Print infix if the tycon/class looks like an operator
-pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind = pprType
+pprParendKind = pprParendType
------------------
-pprPred :: PredType -> SDoc
-pprPred (ClassP cls tys) = pprClassPred cls tys
-pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
-pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
-
-pprEqPred :: (Type,Type) -> SDoc
-pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
- , nest 2 (ptext (sLit "~"))
- , ppr_type FunPrec ty2]
+pprPredTy :: PredType -> SDoc
+pprPredTy = pprPred ppr_type
+
+pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc
+pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys
+pprPred pp (IParam ip ty) = ppr ip <> dcolon <> pp TopPrec ty
+pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2)
+
+------------
+pprEqPred :: Pair Type -> SDoc
+pprEqPred = ppr_eq_pred ppr_type
+
+ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc
+ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1
+ , nest 2 (ptext (sLit "~"))
+ , pp FunPrec ty2]
-- Precedence looks like (->) so that we get
-- Maybe a ~ Bool
-- (a->a) ~ Bool
-- Note parens on the latter!
+------------
pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
+pprClassPred = ppr_class_pred ppr_type
+
+ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc
+ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys
+------------
pprTheta :: ThetaType -> SDoc
-- pprTheta [pred] = pprPred pred -- I'm in two minds about this
-pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+pprTheta theta = parens (sep (punctuate comma (map pprPredTy theta)))
-pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow [] = empty
-pprThetaArrow [pred]
- | noParenPred pred = pprPred pred <+> darrow
-pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
+pprThetaArrowTy :: ThetaType -> SDoc
+pprThetaArrowTy = pprThetaArrow ppr_type
-noParenPred :: PredType -> Bool
+pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc
+pprThetaArrow _ [] = empty
+pprThetaArrow pp [pred]
+ | noParenPred pred = pprPred pp pred <+> darrow
+pprThetaArrow pp preds = parens (sep (punctuate comma (map (pprPred pp) preds)))
+ <+> darrow
+
+noParenPred :: Pred a -> Bool
-- A predicate that can appear without parens before a "=>"
-- C a => a -> a
-- a~b => a -> b
@@ -471,8 +545,9 @@ noParenPred (IParam {}) = False
instance Outputable Type where
ppr ty = pprType ty
-instance Outputable PredType where
- ppr = pprPred
+instance Outputable (Pred Type) where
+ ppr = pprPredTy -- Not for arbitrary (Pred a), because the
+ -- (Outputable a) doesn't give precedence
instance Outputable name => OutputableBndr (IPName name) where
pprBndr _ n = ppr n -- Simple for now
@@ -480,95 +555,47 @@ instance Outputable name => OutputableBndr (IPName name) where
------------------
-- OK, here's the main printer
-pprKind, pprParendKind :: Kind -> SDoc
-pprKind = pprType
-pprParendKind = pprParendType
-
ppr_type :: Prec -> Type -> SDoc
-ppr_type _ (TyVarTy tv) -- Note [Infix type variables]
- | isSymOcc (getOccName tv) = parens (ppr tv)
- | otherwise = ppr tv
+ppr_type _ (TyVarTy tv) = ppr_tvar tv
ppr_type p (PredTy pred) = maybeParen p TyConPrec $
- ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
-ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred)
+ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
-ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty
+ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty
ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
ppr_type p (FunTy ty1 ty2)
- = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
- maybeParen p FunPrec $
- sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
where
- ppr_fun_tail (FunTy ty1 ty2)
- | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
- ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+ -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ ppr_fun_tail (FunTy ty1 ty2)
+ | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
+
is_pred (PredTy {}) = True
is_pred _ = False
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
- sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
- -- We need to be extra careful here as equality constraints will occur as
- -- type variables with an equality kind. So, while collecting quantified
- -- variables, we separate the coercion variables out and turn them into
- -- equality predicates.
- split1 tvs (ForAllTy tv ty)
- | not (isCoVar tv) = split1 (tv:tvs) ty
- split1 tvs ty = (reverse tvs, ty)
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
- split2 ps (ForAllTy tv ty)
- | isCoVar tv = split2 (coVarPred tv : ps) ty
split2 ps ty = (reverse ps, ty)
-ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app _ tc []
- = ppr_tc tc
-ppr_tc_app _ tc [ty]
- | tc `hasKey` listTyConKey = brackets (pprType ty)
- | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
- | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
- | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
- | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
- | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
- | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
-
-ppr_tc_app p tc tys
- | isTupleTyCon tc && tyConArity tc == length tys
- = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
- | otherwise
- = ppr_type_app p (getName tc) tys
-
-ppr_type_app :: Prec -> Name -> [Type] -> SDoc
--- Used for classes as well as types; that's why it's separate from ppr_tc_app
-ppr_type_app p tc tys
- | is_sym_occ -- Print infix if possible
- , [ty1,ty2] <- tys -- We know nothing of precedence though
- = maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
- pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
- | otherwise
- = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
- 2 (sep (map pprParendType tys)))
- where
- is_sym_occ = isSymOcc (getOccName tc)
-
-ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc
-ppr_tc tc
- = pp_nt_debug <> ppr tc
- where
- pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
- then ptext (sLit "<recnt>")
- 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
@@ -576,8 +603,9 @@ 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}
@@ -600,6 +628,59 @@ remember to parenthesise the operator, thus
See Trac #2766.
+\begin{code}
+pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+pprTcApp _ _ tc [] -- No brackets for SymOcc
+ = pp_nt_debug <> ppr tc
+ where
+ pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
+ then ptext (sLit "<recnt>")
+ else ptext (sLit "<nt>"))
+ | otherwise = empty
+
+pprTcApp _ pp tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pp TopPrec ty)
+ | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]")
+ | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
+ | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
+ | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
+ | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
+ | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
+
+pprTcApp p pp tc tys
+ | isTupleTyCon tc && tyConArity tc == length tys
+ = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+ | otherwise
+ = pprTypeNameApp p pp (getName tc) tys
+
+----------------
+pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
+-- The first arg is the tycon, or sometimes class
+-- Print infix if the tycon/class looks like an operator
+pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys
+pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
+-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
+pprTypeNameApp p pp tc tys
+ | is_sym_occ -- Print infix if possible
+ , [ty1,ty2] <- tys -- We know nothing of precedence though
+ = maybeParen p FunPrec $
+ sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2]
+ | otherwise
+ = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys)
+ where
+ is_sym_occ = isSymOcc (getOccName tc)
+----------------
+pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
+pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
+ hang pp_fun 2 (sep pp_tys)
+
+----------------
+pprArrowChain :: Prec -> [SDoc] -> SDoc
+-- pprArrowChain p [a,b,c] generates a -> b -> c
+pprArrowChain _ [] = empty
+pprArrowChain p (arg:args) = maybeParen p FunPrec $
+ sep [arg, sep (map (arrow <+>) args)]
+\end{code}
diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot
index d519f62d2da1e045943d525a8d6403d5685eba58..fe8fd59d1b91c99b9d1b12ca27fcf30fb379588b 100644
--- a/compiler/types/TypeRep.lhs-boot
+++ b/compiler/types/TypeRep.lhs-boot
@@ -2,9 +2,10 @@
module TypeRep where
data Type
-data PredType
+data Pred a
data TyThing
+type PredType = Pred Type
type Kind = Type
isCoercionKind :: Kind -> Bool
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 2acf71efa6e75ab6534d7e5845f9368161d81b11..9c448ce0653af13079713ebe84b28896ced3781d 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -8,9 +8,11 @@ module Unify (
-- the "tc" prefix indicates that matching always
-- respects newtypes (rather than looking through them)
tcMatchTy, tcMatchTys, tcMatchTyX,
- ruleMatchTyX, tcMatchPreds, MatchEnv(..),
-
- dataConCannotMatch,
+ ruleMatchTyX, tcMatchPreds,
+
+ MatchEnv(..), matchList,
+
+ typesCantMatch,
-- Side-effect free unification
tcUnifyTys, BindFlag(..),
@@ -23,16 +25,17 @@ module Unify (
import Var
import VarEnv
import VarSet
+import Kind
import Type
-import Coercion
import TyCon
-import DataCon
import TypeRep
import Outputable
import ErrUtils
import Util
import Maybes
import FastString
+
+import Control.Monad (guard)
\end{code}
@@ -67,9 +70,11 @@ Matching is much tricker than you might think.
\begin{code}
data MatchEnv
- = ME { me_tmpls :: VarSet -- Template tyvars
+ = ME { me_tmpls :: VarSet -- Template variables
, me_env :: RnEnv2 -- Renaming envt for nested foralls
- } -- In-scope set includes template tyvars
+ } -- In-scope set includes template variables
+ -- Nota Bene: MatchEnv isn't specific to Types. It is used
+ -- for matching terms and coercions as well as types
tcMatchTy :: TyVarSet -- Template tyvars
-> Type -- Template
@@ -121,7 +126,7 @@ tcMatchPreds
-> [PredType] -> [PredType]
-> Maybe TvSubstEnv
tcMatchPreds tmpls ps1 ps2
- = match_list (match_pred menv) emptyTvSubstEnv ps1 ps2
+ = matchList (match_pred menv) emptyTvSubstEnv ps1 ps2
where
menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars }
in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2)
@@ -155,9 +160,8 @@ match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2
match menv subst (TyVarTy tv1) ty2
| Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound
- = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
+ = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2
-- ty1 has no locally-bound variables, hence nukeRnEnvL
- -- Note tcEqType...we are doing source-type matching here
then Just subst
else Nothing -- ty2 doesn't match
@@ -201,14 +205,8 @@ match _ _ _ _
match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv
-- Match the kind of the template tyvar with the kind of Type
-- Note [Matching kinds]
-match_kind menv subst tv ty
- | isCoVar tv = do { let (ty1,ty2) = coVarKind tv
- (ty3,ty4) = coercionKind ty
- ; subst1 <- match menv subst ty1 ty3
- ; match menv subst1 ty2 ty4 }
- | otherwise = if typeKind ty `isSubKind` tyVarKind tv
- then Just subst
- else Nothing
+match_kind _ subst tv ty
+ = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst
-- Note [Matching kinds]
-- ~~~~~~~~~~~~~~~~~~~~~
@@ -226,15 +224,15 @@ match_kind menv subst tv ty
--------------
match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv
-match_tys menv subst tys1 tys2 = match_list (match menv) subst tys1 tys2
+match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2
--------------
-match_list :: (TvSubstEnv -> a -> a -> Maybe TvSubstEnv)
- -> TvSubstEnv -> [a] -> [a] -> Maybe TvSubstEnv
-match_list _ subst [] [] = Just subst
-match_list fn subst (ty1:tys1) (ty2:tys2) = do { subst' <- fn subst ty1 ty2
- ; match_list fn subst' tys1 tys2 }
-match_list _ _ _ _ = Nothing
+matchList :: (env -> a -> b -> Maybe env)
+ -> env -> [a] -> [b] -> Maybe env
+matchList _ subst [] [] = Just subst
+matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b
+ ; matchList fn subst' as bs }
+matchList _ _ _ _ = Nothing
--------------
match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv
@@ -318,26 +316,9 @@ anything, type functions (incl newtypes) match anything, and only
distinct data types fail to match. We can elaborate later.
\begin{code}
-dataConCannotMatch :: [Type] -> DataCon -> Bool
--- Returns True iff the data con *definitely cannot* match a
--- scrutinee of type (T tys)
--- where T is the type constructor for the data con
---
-dataConCannotMatch tys con
- | null eq_spec = False -- Common
- | all isTyVarTy tys = False -- Also common
- | otherwise
- = cant_match_s (map (substTyVar subst . fst) eq_spec)
- (map snd eq_spec)
+typesCantMatch :: [(Type,Type)] -> Bool
+typesCantMatch prs = any (\(s,t) -> cant_match s t) prs
where
- dc_tvs = dataConUnivTyVars con
- eq_spec = dataConEqSpec con
- subst = zipTopTvSubst dc_tvs tys
-
- cant_match_s :: [Type] -> [Type] -> Bool
- cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 )
- or (zipWith cant_match tys1 tys2)
-
cant_match :: Type -> Type -> Bool
cant_match t1 t2
| Just t1' <- coreView t1 = cant_match t1' t2
@@ -348,7 +329,7 @@ dataConCannotMatch tys con
cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| isDataTyCon tc1 && isDataTyCon tc2
- = tc1 /= tc2 || cant_match_s tys1 tys2
+ = tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2)
cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc
@@ -370,7 +351,6 @@ dataConCannotMatch tys con
\end{code}
-
%************************************************************************
%* *
Unification
@@ -415,7 +395,7 @@ niFixTvSubst env = f env
| otherwise = subst
where
range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e
- subst = mkTvSubst (mkInScopeSet range_tvs) e
+ subst = mkTvSubst (mkInScopeSet range_tvs) e
not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs
in_domain tv = tv `elemVarEnv` e
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index 097a112359601d5814d9dd6bf1658081d90c386d..700878aea6bd9428a5d9f0b1cd7364ef4b1edf9d 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -41,6 +41,7 @@ data Bag a
| UnitBag a
| TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
| ListBag [a] -- INVARIANT: the list is non-empty
+ deriving Typeable
emptyBag :: Bag a
emptyBag = EmptyBag
@@ -262,8 +263,6 @@ bagToList b = foldrBag (:) [] b
instance (Outputable a) => Outputable (Bag a) where
ppr bag = braces (pprWithCommas ppr (bagToList bag))
-INSTANCE_TYPEABLE1(Bag,bagTc,"Bag")
-
instance Data a => Data (Bag a) where
gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index e178e99f0ddd7237a54a6c5854eb0f16270e6423..fc4d919473bb19d71fcdb7a87f7b339548ffd647 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -15,7 +15,7 @@ module Outputable (
Outputable(..), OutputableBndr(..),
-- * Pretty printing combinators
- SDoc,
+ SDoc, runSDoc, initSDocContext,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
@@ -33,6 +33,9 @@ module Outputable (
hang, punctuate, ppWhen, ppUnless,
speakNth, speakNTimes, speakN, speakNOf, plural,
+ coloured, PprColour, colType, colCoerc, colDataCon,
+ colBinder, bold, keyword,
+
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printErrs, printOutput, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
@@ -41,6 +44,7 @@ module Outputable (
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showPpr,
showSDocUnqual, showsPrecSDoc,
+ renderWithStyle,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
@@ -60,7 +64,7 @@ module Outputable (
-- * Error handling and debugging utilities
pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
- pprTrace, warnPprTrace,
+ pprTrace, pprDefiniteTrace, warnPprTrace,
trace, pgmError, panic, sorry, panicFastInt, assertPanic
) where
@@ -218,38 +222,56 @@ code (either C or assembly), or generating interface files.
%************************************************************************
\begin{code}
-type SDoc = PprStyle -> Doc
+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+
+data SDocContext = SDC
+ { sdocStyle :: !PprStyle
+ , sdocLastColour :: !PprColour
+ -- ^ The most recently used colour. This allows nesting colours.
+ }
+
+initSDocContext :: PprStyle -> SDocContext
+initSDocContext sty = SDC
+ { sdocStyle = sty
+ , sdocLastColour = colReset
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
pprDeeper :: SDoc -> SDoc
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty = d other_sty
+pprDeeper d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
+ SDC{sdocStyle=PprUser q (PartWay n)} ->
+ runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ _ -> runSDoc d ctx
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds (PprUser q (PartWay n))
- | n==0 = Pretty.text "..."
- | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
- where
- go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
-
-pprDeeperList f ds other_sty
- = f ds other_sty
+pprDeeperList f ds = SDoc work
+ where
+ work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
+ | n==0 = Pretty.text "..."
+ | otherwise =
+ runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ where
+ go _ [] = []
+ go i (d:ds) | i >= n = [text "...."]
+ | otherwise = d : go (i+1) ds
+ work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
-pprSetDepth _depth doc other_sty = doc other_sty
+pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser q _} ->
+ runSDoc doc ctx{sdocStyle = PprUser q depth}
+ _ ->
+ runSDoc doc ctx
getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
+getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
\end{code}
\begin{code}
@@ -282,22 +304,24 @@ userStyle (PprUser _ _) = True
userStyle _other = False
ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _ = Pretty.empty
+ifPprDebug d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprDebug} -> runSDoc d ctx
+ _ -> Pretty.empty
\end{code}
\begin{code}
-- Unused [7/02 sof]
printSDoc :: SDoc -> PprStyle -> IO ()
printSDoc d sty = do
- Pretty.printDoc PageMode stdout (d sty)
+ Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
hFlush stdout
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
- hFlush stderr
+printErrs :: SDoc -> PprStyle -> IO ()
+printErrs doc sty = do
+ Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
+ hFlush stderr
printOutput :: Doc -> IO ()
printOutput doc = Pretty.printDoc PageMode stdout doc
@@ -307,25 +331,32 @@ printDump doc = hPrintDump stdout doc
hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
- Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+ Pretty.printDoc PageMode h
+ (runSDoc better_doc (initSDocContext defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode CStyle)))
printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode AsmStyle)))
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
@@ -337,32 +368,44 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
+
+renderWithStyle :: SDoc -> PprStyle -> String
+renderWithStyle sdoc sty =
+ Pretty.render (runSDoc sdoc (initSDocContext sty))
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc =
+ show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
showSDocUnqual :: SDoc -> String
-- Only used in the gruesome isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d =
+ show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
showSDocDump :: SDoc -> String
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d =
+ Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d =
+ Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
@@ -370,7 +413,7 @@ showPpr = showSDoc . ppr
\begin{code}
docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
+docToSDoc d = SDoc (\_ -> d)
empty :: SDoc
char :: Char -> SDoc
@@ -383,58 +426,58 @@ float :: Float -> SDoc
double :: Double -> SDoc
rational :: Rational -> SDoc
-empty _sty = Pretty.empty
-char c _sty = Pretty.char c
-text s _sty = Pretty.text s
-ftext s _sty = Pretty.ftext s
-ptext s _sty = Pretty.ptext s
-int n _sty = Pretty.int n
-integer n _sty = Pretty.integer n
-float n _sty = Pretty.float n
-double n _sty = Pretty.double n
-rational n _sty = Pretty.rational n
+empty = docToSDoc $ Pretty.empty
+char c = docToSDoc $ Pretty.char c
+text s = docToSDoc $ Pretty.text s
+ftext s = docToSDoc $ Pretty.ftext s
+ptext s = docToSDoc $ Pretty.ptext s
+int n = docToSDoc $ Pretty.int n
+integer n = docToSDoc $ Pretty.integer n
+float n = docToSDoc $ Pretty.float n
+double n = docToSDoc $ Pretty.double n
+rational n = docToSDoc $ Pretty.rational n
parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
-parens d sty = Pretty.parens (d sty)
-braces d sty = Pretty.braces (d sty)
-brackets d sty = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d = char '<' <> d <> char '>'
+parens d = SDoc $ Pretty.parens . runSDoc d
+braces d = SDoc $ Pretty.braces . runSDoc d
+brackets d = SDoc $ Pretty.brackets . runSDoc d
+doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+angleBrackets d = char '<' <> d <> char '>'
cparen :: Bool -> SDoc -> SDoc
-cparen b d sty = Pretty.cparen b (d sty)
+cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-- quotes encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
-quotes d sty = case show pp_d of
- ('\'' : _) -> pp_d
- _other -> Pretty.quotes pp_d
- where
- pp_d = d sty
+quotes d = SDoc $ \sty ->
+ let pp_d = runSDoc d sty in
+ case show pp_d of
+ ('\'' : _) -> pp_d
+ _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
-blankLine _sty = Pretty.ptext (sLit "")
-dcolon _sty = Pretty.ptext (sLit "::")
-arrow _sty = Pretty.ptext (sLit "->")
-darrow _sty = Pretty.ptext (sLit "=>")
-semi _sty = Pretty.semi
-comma _sty = Pretty.comma
-colon _sty = Pretty.colon
-equals _sty = Pretty.equals
-space _sty = Pretty.space
-underscore = char '_'
-dot = char '.'
-lparen _sty = Pretty.lparen
-rparen _sty = Pretty.rparen
-lbrack _sty = Pretty.lbrack
-rbrack _sty = Pretty.rbrack
-lbrace _sty = Pretty.lbrace
-rbrace _sty = Pretty.rbrace
+blankLine = docToSDoc $ Pretty.ptext (sLit "")
+dcolon = docToSDoc $ Pretty.ptext (sLit "::")
+arrow = docToSDoc $ Pretty.ptext (sLit "->")
+darrow = docToSDoc $ Pretty.ptext (sLit "=>")
+semi = docToSDoc $ Pretty.semi
+comma = docToSDoc $ Pretty.comma
+colon = docToSDoc $ Pretty.colon
+equals = docToSDoc $ Pretty.equals
+space = docToSDoc $ Pretty.space
+underscore = char '_'
+dot = char '.'
+lparen = docToSDoc $ Pretty.lparen
+rparen = docToSDoc $ Pretty.rparen
+lbrack = docToSDoc $ Pretty.lbrack
+rbrack = docToSDoc $ Pretty.rbrack
+lbrace = docToSDoc $ Pretty.lbrace
+rbrace = docToSDoc $ Pretty.rbrace
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
@@ -448,11 +491,11 @@ nest :: Int -> SDoc -> SDoc
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
-nest n d sty = Pretty.nest n (d sty)
-(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+nest n d = SDoc $ Pretty.nest n . runSDoc d
+(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
+($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
@@ -471,19 +514,19 @@ fcat :: [SDoc] -> SDoc
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty = Pretty.sep [d sty | d <- ds]
-cat ds sty = Pretty.cat [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
+hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
+cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
hang :: SDoc -- ^ The header
-> Int -- ^ Amount to indent the hung body
-> SDoc -- ^ The hung body, indented and placed below the header
-> SDoc
-hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
+hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
punctuate :: SDoc -- ^ The punctuation
-> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
@@ -500,6 +543,46 @@ ppWhen False _ = empty
ppUnless True _ = empty
ppUnless False doc = doc
+
+-- | A colour\/style for use with 'coloured'.
+newtype PprColour = PprColour String
+
+-- Colours
+
+colType :: PprColour
+colType = PprColour "\27[34m"
+
+colBold :: PprColour
+colBold = PprColour "\27[;1m"
+
+colCoerc :: PprColour
+colCoerc = PprColour "\27[34m"
+
+colDataCon :: PprColour
+colDataCon = PprColour "\27[31m"
+
+colBinder :: PprColour
+colBinder = PprColour "\27[32m"
+
+colReset :: PprColour
+colReset = PprColour "\27[0m"
+
+-- | Apply the given colour\/style for the argument.
+--
+-- Only takes effect if colours are enabled.
+coloured :: PprColour -> SDoc -> SDoc
+-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+coloured col@(PprColour c) sdoc =
+ SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+ let ctx' = ctx{ sdocLastColour = col } in
+ Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+
+bold :: SDoc -> SDoc
+bold = coloured colBold
+
+keyword :: SDoc -> SDoc
+keyword = bold
+
\end{code}
@@ -800,24 +883,29 @@ pprTrace str doc x
| opt_NoDebugOutput = x
| otherwise = pprAndThen trace str doc x
+pprDefiniteTrace :: String -> SDoc -> a -> a
+-- ^ Same as pprTrace, but show even if -dno-debug-output is on
+pprDefiniteTrace str doc x = pprAndThen trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
+pprPanicFastInt heading pretty_msg =
+ panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+ doc = text heading <+> pretty_msg
pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
- where
+pprAndThen cont heading pretty_msg =
+ cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
doc = sep [text heading, nest 4 pretty_msg]
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
- = panic (show (doc PprDebug))
+ = panic (show (runSDoc doc (initSDocContext PprDebug)))
where
doc = sep [hsep[text "ASSERT failed! file",
text file,
@@ -830,7 +918,7 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
- = trace (show (doc defaultDumpStyle)) x
+ = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
where
doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
msg]
diff --git a/compiler/utils/Pair.lhs b/compiler/utils/Pair.lhs
new file mode 100644
index 0000000000000000000000000000000000000000..9e847d69505503c18e22034ddf88ff6f92a20e3e
--- /dev/null
+++ b/compiler/utils/Pair.lhs
@@ -0,0 +1,47 @@
+
+A simple homogeneous pair type with useful Functor, Applicative, and
+Traversable instances.
+
+\begin{code}
+module Pair ( Pair(..), unPair, toPair, swap ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import Data.Monoid
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+data Pair a = Pair { pFst :: a, pSnd :: a }
+-- Note that Pair is a *unary* type constructor
+-- whereas (,) is binary
+
+-- The important thing about Pair is that it has a *homogenous*
+-- Functor instance, so you can easily apply the same function
+-- to both components
+instance Functor Pair where
+ fmap f (Pair x y) = Pair (f x) (f y)
+
+instance Applicative Pair where
+ pure x = Pair x x
+ (Pair f g) <*> (Pair x y) = Pair (f x) (g y)
+
+instance Foldable Pair where
+ foldMap f (Pair x y) = f x `mappend` f y
+
+instance Traversable Pair where
+ traverse f (Pair x y) = Pair <$> f x <*> f y
+
+instance Outputable a => Outputable (Pair a) where
+ ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
+
+unPair :: Pair a -> (a,a)
+unPair (Pair x y) = (x,y)
+
+toPair :: (a,a) -> Pair a
+toPair (x,y) = Pair x y
+
+swap :: Pair a -> Pair a
+swap (Pair x y) = Pair y x
+\end{code}
\ No newline at end of file
diff --git a/compiler/nativeGen/Platform.hs b/compiler/utils/Platform.hs
similarity index 95%
rename from compiler/nativeGen/Platform.hs
rename to compiler/utils/Platform.hs
index 20cb5f5e9685e37d9ae32b5f639306c318c913f2..7b2502d96e104662a3bbe04662a90f51f9f40168 100644
--- a/compiler/nativeGen/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -31,8 +31,7 @@ data Platform
-- about what instruction set extensions an architecture might support.
--
data Arch
- = ArchAlpha
- | ArchX86
+ = ArchX86
| ArchX86_64
| ArchPPC
| ArchPPC_64
@@ -70,9 +69,7 @@ defaultTargetPlatform
-- | Move the evil TARGET_ARCH #ifdefs into Haskell land.
defaultTargetArch :: Arch
-#if alpha_TARGET_ARCH
-defaultTargetArch = ArchAlpha
-#elif i386_TARGET_ARCH
+#if i386_TARGET_ARCH
defaultTargetArch = ArchX86
#elif x86_64_TARGET_ARCH
defaultTargetArch = ArchX86_64
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index a518c0b6f6f34bc97b34c085bc016fb624c040ec..f0ca69cbb9eae6a0216c48ad1a10e36ddf28ef66 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -163,7 +163,7 @@ module Pretty (
empty, isEmpty, nest,
- char, text, ftext, ptext,
+ char, text, ftext, ptext, zeroWidthText,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
@@ -224,6 +224,10 @@ The primitive @Doc@ values
\begin{code}
empty :: Doc
isEmpty :: Doc -> Bool
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags
+zeroWidthText :: String -> Doc
+
text :: String -> Doc
char :: Char -> Doc
@@ -560,6 +564,7 @@ ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
ptext :: LitString -> Doc
ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
where s = {-castPtr-} s_
+zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
#if defined(__GLASGOW_HASKELL__)
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 0e46889ec549fa3496f6fdb6c67a0eafc098e662..dc4f32ec5e7d7f4dffec59df200cd8fd6db7cf3c 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -66,6 +66,9 @@ module Util (
-- * Floating point
readRational,
+ -- * read helpers
+ maybeReadFuzzy,
+
-- * IO-ish utilities
createDirectoryHierarchy,
doesDirNameExist,
@@ -965,6 +968,17 @@ readRational top_s
_ -> error ("readRational: ambiguous parse:" ++ top_s)
+-----------------------------------------------------------------------------
+-- read helpers
+
+maybeReadFuzzy :: Read a => String -> Maybe a
+maybeReadFuzzy str = case reads str of
+ [(x, s)]
+ | all isSpace s ->
+ Just x
+ _ ->
+ Nothing
+
-----------------------------------------------------------------------------
-- Create a hierarchy of directories
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index ca6766ad2921db6743da77befdf2954b17f90e41..4994e3f1659cbd1d333bba333ba07587f6f2219d 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -19,7 +19,6 @@ import PprCore
import CoreSyn
import CoreMonad ( CoreM, getHscEnv )
import Type
-import Var
import Id
import OccName
import DynFlags
@@ -190,7 +189,7 @@ vectTopBinder var inline expr
; case vectDecl of
Nothing -> return ()
Just (vdty, _)
- | coreEqType vty vdty -> return ()
+ | eqType vty vdty -> return ()
| otherwise ->
cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $
(text "Expected type" <+> ppr vty)
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
index 69ae84ff9d7c78af9ec4d5333b513d7403851e11..8456d340fca979e46336f5c5f23e2af5cf346291 100644
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Base.hs
@@ -13,7 +13,7 @@ module Vectorise.Builtins.Base (
indexBuiltin,
-- * Projections
- selTy,
+ selTy,
selReplicate,
selPick,
selTags,
@@ -33,7 +33,6 @@ import TysWiredIn
import Type
import TyCon
import DataCon
-import Var
import Outputable
import Data.Array
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index 94de62aa72300b6b114946fed2259c3beaf9803a..5a6cf88272ad1d6ef433d07f6764bfb93c21016e 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -24,7 +24,6 @@ import CoreSyn
import Type
import Name
import Module
-import Var
import Id
import FastString
import Outputable
@@ -41,26 +40,62 @@ initBuiltins
initBuiltins pkg
= do mapM_ load dph_Orphans
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
- let [parrayDataCon] = tyConDataCons parrayTyCon
+ -- From dph-common:Data.Array.Parallel.PArray.PData
+ -- PData is a type family that maps an element type onto the type
+ -- we use to hold an array of those elements.
+ pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData")
- pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
- paClass <- externalClass dph_PArray (fsLit "PA")
+ -- PR is a type class that holds the primitive operators we can
+ -- apply to array data. Its functions take arrays in terms of PData types.
+ prClass <- externalClass dph_PArray_PData (fsLit "PR")
+ let prTyCon = classTyCon prClass
+ [prDataCon] = tyConDataCons prTyCon
+
+
+ -- From dph-common:Data.Array.Parallel.PArray.PRepr
+ preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr")
+ paClass <- externalClass dph_PArray_PRepr (fsLit "PA")
let paTyCon = classTyCon paClass
[paDataCon] = tyConDataCons paTyCon
paPRSel = classSCSelId paClass 0
- preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
- prClass <- externalClass dph_PArray (fsLit "PR")
- let prTyCon = classTyCon prClass
- [prDataCon] = tyConDataCons prTyCon
+ replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD")
+ emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD")
+ packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD")
+ combines <- mapM (externalVar dph_PArray_PRepr)
+ [mkFastString ("combine" ++ show i ++ "PD")
+ | i <- [2..mAX_DPH_COMBINE]]
+
+ let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+
- closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
+ -- From dph-common:Data.Array.Parallel.PArray.Scalar
+ -- Scalar is the class of scalar values.
+ -- The dictionary contains functions to coerce U.Arrays of scalars
+ -- to and from the PData representation.
+ scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar")
+
+
+ -- From dph-common:Data.Array.Parallel.Lifted.PArray
+ -- A PArray (Parallel Array) holds the array length and some array elements
+ -- represented by the PData type family.
+ parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray")
+ let [parrayDataCon] = tyConDataCons parrayTyCon
+
+ -- From dph-common:Data.Array.Parallel.PArray.Types
+ voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void")
+ voidVar <- externalVar dph_PArray_Types (fsLit "void")
+ fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid")
+ wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap")
+ sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
+
+ -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
+ pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid")
+ punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit")
+
+
+ closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
- -- From dph-common:Data.Array.Parallel.Lifted.Repr
- voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
- wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
-- From dph-common:Data.Array.Parallel.Lifted.Unboxed
sel_tys <- mapM (externalType dph_Unboxed)
@@ -78,8 +113,6 @@ initBuiltins pkg
sel_els <- mapM mk_elements
[(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
- sum_tcs <- mapM (externalTyCon dph_Repr)
- (numbered "Sum" 2 mAX_DPH_SUM)
let selTys = listArray (2, mAX_DPH_SUM) sel_tys
selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
@@ -89,26 +122,14 @@ initBuiltins pkg
sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
- voidVar <- externalVar dph_Repr (fsLit "void")
- pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
- fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
- punitVar <- externalVar dph_Repr (fsLit "punit")
+
closureVar <- externalVar dph_Closure (fsLit "closure")
applyVar <- externalVar dph_Closure (fsLit "$:")
liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
- replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
- emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
- packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD")
-
- combines <- mapM (externalVar dph_PArray)
- [mkFastString ("combine" ++ show i ++ "PD")
- | i <- [2..mAX_DPH_COMBINE]]
- let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
- scalarClass <- externalClass dph_PArray (fsLit "Scalar")
scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
- scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
+ scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
scalar_zips <- mapM (externalVar dph_Scalar)
(numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
@@ -163,13 +184,20 @@ initBuiltins pkg
, liftingContext = liftingContext
}
where
- mods@(Modules {
- dph_PArray = dph_PArray
- , dph_Repr = dph_Repr
- , dph_Closure = dph_Closure
- , dph_Scalar = dph_Scalar
- , dph_Unboxed = dph_Unboxed
- })
+ -- Extract out all the modules we'll use.
+ -- These are the modules from the DPH base library that contain
+ -- the primitive array types and functions that vectorised code uses.
+ mods@(Modules
+ { dph_PArray_Base = dph_PArray_Base
+ , dph_PArray_Scalar = dph_PArray_Scalar
+ , dph_PArray_PRepr = dph_PArray_PRepr
+ , dph_PArray_PData = dph_PArray_PData
+ , dph_PArray_PDataInstances = dph_PArray_PDataInstances
+ , dph_PArray_Types = dph_PArray_Types
+ , dph_Closure = dph_Closure
+ , dph_Scalar = dph_Scalar
+ , dph_Unboxed = dph_Unboxed
+ })
= dph_Modules pkg
load get_mod = dsLoadModule doc mod
@@ -249,13 +277,13 @@ initBuiltinDataCons _
-- | Get the names of all buildin instance functions for the PA class.
initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPAs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
-- | Get the names of all builtin instance functions for the PR class.
initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPRs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
-- | Get the names of all DPH instance functions for this class.
diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs
index d5b10cbba8f1039d55ba714042917f62bc03c243..6ea3595d5381c4804b7df14015b6f28fd2b75a93 100644
--- a/compiler/vectorise/Vectorise/Builtins/Modules.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Modules.hs
@@ -10,45 +10,61 @@ import FastString
-- | Ids of the modules that contain our DPH builtins.
data Modules
- = Modules
- { dph_PArray :: Module
- , dph_Repr :: Module
- , dph_Closure :: Module
- , dph_Unboxed :: Module
- , dph_Instances :: Module
- , dph_Combinators :: Module
- , dph_Scalar :: Module
- , dph_Prelude_PArr :: Module
- , dph_Prelude_Int :: Module
- , dph_Prelude_Word8 :: Module
- , dph_Prelude_Double :: Module
- , dph_Prelude_Bool :: Module
- , dph_Prelude_Tuple :: Module
- }
+ = Modules
+ { dph_PArray_Base :: Module
+ , dph_PArray_Scalar :: Module
+ , dph_PArray_ScalarInstances :: Module
+ , dph_PArray_PRepr :: Module
+ , dph_PArray_PReprInstances :: Module
+ , dph_PArray_PData :: Module
+ , dph_PArray_PDataInstances :: Module
+ , dph_PArray_Types :: Module
+
+ , dph_Closure :: Module
+ , dph_Unboxed :: Module
+ , dph_Combinators :: Module
+ , dph_Scalar :: Module
+
+ , dph_Prelude_Int :: Module
+ , dph_Prelude_Word8 :: Module
+ , dph_Prelude_Double :: Module
+ , dph_Prelude_Bool :: Module
+ , dph_Prelude_Tuple :: Module
+ }
-- | The locations of builtins in the current DPH library.
dph_Modules :: PackageId -> Modules
dph_Modules pkg
- = Modules
- { dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
- , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
- , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
- , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
- , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
- , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
- , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
+ = Modules
+ { dph_PArray_Base = mk (fsLit "Data.Array.Parallel.PArray.Base")
+ , dph_PArray_Scalar = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
+ , dph_PArray_ScalarInstances = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
+ , dph_PArray_PRepr = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
+ , dph_PArray_PReprInstances = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
+ , dph_PArray_PData = mk (fsLit "Data.Array.Parallel.PArray.PData")
+ , dph_PArray_PDataInstances = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
+ , dph_PArray_Types = mk (fsLit "Data.Array.Parallel.PArray.Types")
+
+ , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
+ , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
+ , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
+ , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
- , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
- , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
- , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
- , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
- , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
- , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
- }
- where mk = mkModule pkg . mkModuleNameFS
+ , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
+ , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
+ , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
+ , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
+ , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
+ }
+ where mk = mkModule pkg . mkModuleNameFS
--- | Project out ids of modules that contain orphan instances that we need to load.
dph_Orphans :: [Modules -> Module]
-dph_Orphans = [dph_Repr, dph_Instances]
+dph_Orphans
+ = [ dph_PArray_Scalar
+ , dph_PArray_ScalarInstances
+ , dph_PArray_PReprInstances
+ , dph_PArray_PDataInstances
+ , dph_Scalar
+ ]
diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
index b0f305da73a94c04b1bdfe27b4747e7a21f8fefb..51b3d140544bda05870e08f7613f7c6b7ecae800 100644
--- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
@@ -25,36 +25,18 @@ preludeVars :: Modules
-> [( Module, FastString -- Maps the original variable to the one in the DPH
, Module, FastString)] -- packages that it should be rewritten to.
preludeVars (Modules { dph_Combinators = _dph_Combinators
- , dph_PArray = _dph_PArray
, dph_Prelude_Int = dph_Prelude_Int
, dph_Prelude_Word8 = dph_Prelude_Word8
, dph_Prelude_Double = dph_Prelude_Double
, dph_Prelude_Bool = dph_Prelude_Bool
- , dph_Prelude_PArr = _dph_Prelude_PArr
})
- -- Functions that work on whole PArrays, defined in GHC.PArr
- = [ {- mk gHC_PARR' (fsLit "mapP") dph_Combinators (fsLit "mapPA")
- , mk gHC_PARR' (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
- , mk gHC_PARR' (fsLit "zipP") dph_Combinators (fsLit "zipPA")
- , mk gHC_PARR' (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
- , mk gHC_PARR' (fsLit "filterP") dph_Combinators (fsLit "filterPA")
- , mk gHC_PARR' (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
- , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
- , mk gHC_PARR' (fsLit "!:") dph_Combinators (fsLit "indexPA")
- , mk gHC_PARR' (fsLit "sliceP") dph_Combinators (fsLit "slicePA")
- , mk gHC_PARR' (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
- , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
- , mk gHC_PARR' (fsLit "concatP") dph_Combinators (fsLit "concatPA")
- , mk gHC_PARR' (fsLit "+:+") dph_Combinators (fsLit "appPA")
- , mk gHC_PARR' (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
-
+ = [
-- Map scalar functions to versions using closures.
- , -} mk' dph_Prelude_Int "div" "divV"
+ mk' dph_Prelude_Int "div" "divV"
, mk' dph_Prelude_Int "mod" "modV"
, mk' dph_Prelude_Int "sqrt" "sqrtV"
, mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
- -- , mk' dph_Prelude_Int "upToP" "upToPA"
]
++ vars_Ord dph_Prelude_Int
++ vars_Num dph_Prelude_Int
@@ -80,17 +62,7 @@ preludeVars (Modules { dph_Combinators = _dph_Combinators
, mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV")
, mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV")
, mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV")
-
-{-
- -- FIXME: temporary
- , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
- , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
- , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
- , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
- , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA")
- , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA")
- , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA")
--} ]
+ ]
where
mk = (,,,)
mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index dbdf6e1c8d6d17ea917a69ea8d68b965312d31d4..4676e182a9221aad77b1041842f0f713a03d20db 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -234,7 +234,8 @@ vectScalarFun forceScalar recFns expr
scalars' = scalars `extendVarSet` var
is_scalar scalars (Cast e _coe) = is_scalar scalars e
is_scalar scalars (Note _ e ) = is_scalar scalars e
- is_scalar _scalars (Type _) = True
+ is_scalar _scalars (Type {}) = True
+ is_scalar _scalars (Coercion {}) = True
-- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var)
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 84844101a357a06798e8659c57b5a1862aa8b425..49104647097c983857688a2b38df73aa6b973aaa 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -27,7 +27,6 @@ import FamInstEnv
import OccName
import Id
import MkId
-import Var
import NameEnv
import Unique
diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs
index 332344bdc235c519f767399b0317494d4dec5317..b7bd95e9405640db9c2e21fef31a87d74e9a0861 100644
--- a/compiler/vectorise/Vectorise/Type/PData.hs
+++ b/compiler/vectorise/Vectorise/Type/PData.hs
@@ -31,7 +31,6 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
[] -- no stupid theta
rhs
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
(Just $ mk_fam_inst pdata vect_tc)
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
index 1556626690231ecf364f33e41fdee26b1e4bef8b..c30bfed6edebbd250c2287ccaba8286264e07d4a 100644
--- a/compiler/vectorise/Vectorise/Type/PRepr.hs
+++ b/compiler/vectorise/Vectorise/Type/PRepr.hs
@@ -15,6 +15,7 @@ import CoreUtils
import MkCore ( mkWildCase )
import TyCon
import Type
+import Kind
import BuildTyCl
import OccName
import Coercion
@@ -180,9 +181,9 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc r
pdata_co <- mkBuiltinCo pdataTyCon
let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion pdata_co
- . mkSymCoercion
- $ mkTyConApp repr_co ty_args
+ co = mkAppCo pdata_co
+ . mkSymCo
+ $ mkAxInstCo repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
@@ -262,8 +263,8 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc r
pdata_co <- mkBuiltinCo pdataTyCon
let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion pdata_co
- $ mkTyConApp repr_co var_tys
+ co = mkAppCo pdata_co
+ $ mkAxInstCo repr_co var_tys
scrut = mkCoerce co (Var arg)
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 0fa8482d6b4a0afa716158c33c8ae662ba31a26a..cbfea455b65daa82f2898ca402eca10c17209bb0 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -82,7 +82,6 @@ vectTyConDecl tycon
[] -- no stupid theta.
rhs' -- new constructor defs.
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
Nothing -- not a family instance
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
index 8cc2bec5193ed04725f8392b2f72dc3a6621f2ef..a6d9b2a4fd75299c876ebd6a752cb8a0830edf75 100644
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ b/compiler/vectorise/Vectorise/Type/Type.hs
@@ -10,7 +10,6 @@ import Vectorise.Builtins
import TypeRep
import Type
import TyCon
-import Var
import Outputable
import Control.Monad
import Data.List
diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs
index 1a099e3174579bb5000f9a774fe23edbfa51d081..c7020ea1aecc43b0e70f5909f28dd8015a65c85e 100644
--- a/compiler/vectorise/Vectorise/Utils.hs
+++ b/compiler/vectorise/Vectorise/Utils.hs
@@ -33,7 +33,6 @@ import Vectorise.Builtins
import CoreSyn
import CoreUtils
import Type
-import Var
import Control.Monad
@@ -47,7 +46,7 @@ collectAnnTypeArgs expr = go expr []
collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
collectAnnTypeBinders expr = go [] expr
where
- go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e
+ go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
go bs e = (reverse bs, e)
collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index 0ffaa60d9490a904332a039b511a7aa0efebda2f..d41be1e87a77a1d669ec3822168c1d08e8968884 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -133,7 +133,7 @@ mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
mkBuiltinCo get_tc
= do
tc <- builtin get_tc
- return $ mkTyConApp tc []
+ return $ mkTyConAppCo tc []
mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
index 152c51de1bb80da7b90009f52c5b97400e74b08c..d784984f21e014bbacdeeac0a48b2b6652c49d84 100644
--- a/compiler/vectorise/Vectorise/Utils/Closure.hs
+++ b/compiler/vectorise/Vectorise/Utils/Closure.hs
@@ -17,7 +17,6 @@ import Vectorise.Utils.Hoisting
import CoreSyn
import Type
-import Var
import MkCore
import CoreUtils
import TyCon
diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
index 12b1b6fe4f4d5154c7cd52e26b93127745f6d11f..d0785e51488d92c793a0961a432785d9d0fa3557 100644
--- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs
+++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
@@ -20,7 +20,6 @@ import CoreSyn
import CoreUtils
import CoreUnfold
import Type
-import Var
import Id
import BasicTypes( Arity )
import FastString
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 329cb6368d8eb4173fec86a1ad24ee9a4b6c653b..9c7af44ca94568a4800eb12f2f2bb78dcdda9c0b 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -31,7 +31,6 @@ import Control.Monad
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
where
- go ty k | Just k' <- kindView k = go ty k'
go ty (FunTy k1 k2)
= do
tv <- newTyVar (fsLit "a") k1
@@ -136,9 +135,9 @@ prDictOfPReprInstTyCon ty prepr_tc prepr_args
dict <- prDictOfReprType' rhs
pr_co <- mkBuiltinCo prTyCon
let Just arg_co = tyConFamilyCoercion_maybe prepr_tc
- let co = mkAppCoercion pr_co
- $ mkSymCoercion
- $ mkTyConApp arg_co prepr_args
+ let co = mkAppCo pr_co
+ $ mkSymCo
+ $ mkAxInstCo arg_co prepr_args
return $ mkCoerce co dict
| otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs
index 8856afd832c45d56a775566570f1957a6ba6ef76..a27afeaf992c0b00aadf015f67ac8af04b575c59 100644
--- a/compiler/vectorise/Vectorise/Utils/Poly.hs
+++ b/compiler/vectorise/Vectorise/Utils/Poly.hs
@@ -11,7 +11,6 @@ import Vectorise.Monad
import Vectorise.Utils.PADict
import CoreSyn
import Type
-import Var
import FastString
import Control.Monad
diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs
index f32cf780882cd4c31485e85fee352848387889ac..9c81d301183d0a7f26f235af21dd7396219eb4cf 100644
--- a/compiler/vectorise/Vectorise/Var.hs
+++ b/compiler/vectorise/Vectorise/Var.hs
@@ -17,7 +17,6 @@ import Vectorise.Vect
import Vectorise.Type.Type
import CoreSyn
import Type
-import Var
import VarEnv
import Literal
import Id
diff --git a/configure.ac b/configure.ac
index 7baa3ddb5cc6a0d02b79790fd7a36c9696f76cc3..2de4d8ad4859f977418a0e3d81074ec8741f8a62 100644
--- a/configure.ac
+++ b/configure.ac
@@ -132,10 +132,15 @@ if test "$WithGhc" != ""; then
GhcCanonVersion="$GhcMajVersion$GhcMinVersion2"
if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi
AC_SUBST(ghc_ge_613)dnl
+
+ BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command],['$(AR)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags],['$(AR_OPTS)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file],['$(ArSupportsAtFile)'])
fi
dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on
-if test "$BootingFromHc" = "NO" -a -d "$srcdir/compiler"; then
+if test "$BootingFromHc" = "NO"; then
if test "$WithGhc" = ""; then
AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.])
fi
@@ -237,7 +242,6 @@ case $host in
;;
esac
-# Sync this with cTargetArch in compiler/ghc.mk
checkArch() {
case $1 in
alpha|arm|hppa|hppa1_1|i386|ia64|m68k|mips|mipseb|mipsel|powerpc|powerpc64|rs6000|s390|sparc|sparc64|vax|x86_64)
@@ -303,12 +307,15 @@ checkOS "$TargetOS"
# Verify that the installed (bootstrap) GHC is capable of generating
# code for the requested build platform.
-if test "$BuildPlatform" != "$bootstrap_target"
+if test "$BootingFromHc" = "NO"
then
- echo "This GHC (${WithGhc}) does not generate code for the build platform"
- echo " GHC target platform : $bootstrap_target"
- echo " Desired build platform : $BuildPlatform"
- exit 1
+ if test "$BuildPlatform" != "$bootstrap_target"
+ then
+ echo "This GHC (${WithGhc}) does not generate code for the build platform"
+ echo " GHC target platform : $bootstrap_target"
+ echo " Desired build platform : $BuildPlatform"
+ exit 1
+ fi
fi
echo "GHC build : $BuildPlatform"
@@ -537,7 +544,7 @@ dnl ** look for GCC and find out which version
dnl Figure out which C compiler to use. Gcc is preferred.
dnl If gcc, make sure it's at least 2.1
dnl
-FP_HAVE_GCC
+FP_GCC_VERSION
FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS])
FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0])
@@ -578,7 +585,6 @@ AC_DEFINE([HAVE_BIN_SH], [1], [Define to 1 if you have /bin/sh.])
dnl ** how to invoke `ar' and `ranlib'
FP_PROG_AR_SUPPORTS_ATFILE
FP_PROG_AR_NEEDS_RANLIB
-FP_PROG_AR_SUPPORTS_INPUT
dnl ** Check to see whether ln -s works
AC_PROG_LN_S
@@ -624,8 +630,6 @@ FP_CHECK_DOCBOOK_DTD
FP_DOCBOOK_XSL
FP_PROG_DBLATEX
-FP_PROG_HSTAGS
-
dnl ** check for ghc-pkg command
FP_PROG_GHC_PKG
@@ -931,7 +935,7 @@ if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then
AC_MSG_ERROR([compiler/ghc.cabal.in contains tab characters; please remove them])
fi
-AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec extra-gcc-opts docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac])
+AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac])
AC_CONFIG_COMMANDS([mk/stamp-h],[echo timestamp > mk/stamp-h])
AC_OUTPUT
diff --git a/distrib/Makefile b/distrib/Makefile
index f1d63bc28edf7251d1877a344e7e69160b124339..7f8add1f5034b74b526c673bd258a1b021448ded 100644
--- a/distrib/Makefile
+++ b/distrib/Makefile
@@ -34,7 +34,7 @@ install::
$(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
diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in
index d5aa2be68dfd043e35d5ceebc908cd77d1552ba8..7df0f3b52be79ba13d3cdb51992da541cd1fdbee 100644
--- a/distrib/configure.ac.in
+++ b/distrib/configure.ac.in
@@ -55,7 +55,7 @@ export CC
WhatGccIsCalled="$CC"
AC_SUBST(WhatGccIsCalled)
-FP_HAVE_GCC
+FP_GCC_VERSION
AC_PROG_CPP
#
@@ -88,7 +88,7 @@ dnl ** how to invoke `ar' and `ranlib'
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
diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml
index 6fc1413bb1af5334931128f2a2f7037f096f16e0..9c48f7d96e7e7db5091868444be4fb07c7d274cf 100644
--- a/docs/users_guide/debugging.xml
+++ b/docs/users_guide/debugging.xml
@@ -24,8 +24,9 @@
a short form…). You can get all of these at once
(<emphasis>lots</emphasis> of output) by using
<option>-v5</option>, or most of them with
- <option>-v4</option>. Some of the most useful ones
- are:</para>
+ <option>-v4</option>. You can prevent them from clogging up
+ your standard output by passing <option>-ddump-to-file</option>.
+ Some of the most useful ones are:</para>
<variablelist>
<varlistentry>
@@ -476,6 +477,88 @@
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>
@@ -483,7 +566,7 @@
<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>
@@ -493,12 +576,13 @@
<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>
@@ -508,36 +592,39 @@ shorter.</para>
<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>
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index e0940aec0d4c43106ba2fed740111e4d8fbcd10b..bfc28d82cb2c37e360d41fb04e3819abbe5ef4f1 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -35,13 +35,7 @@
<entry>mode</entry>
<entry>-</entry>
</row>
- <row>
- <entry><option>-n</option></entry>
- <entry>do a dry run</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
+ <row>
<entry><option>-v</option></entry>
<entry>verbose mode (equivalent to <option>-v3</option>)</entry>
<entry>dynamic</entry>
@@ -682,7 +676,9 @@
</row>
<row>
<entry><option>-XGenerics</option></entry>
- <entry>Enable <link linkend="generic-classes">generic classes</link></entry>
+ <entry>Deprecated, does nothing. No longer enables <link linkend="generic-classes">generic classes</link>.
+ See also GHC's support for
+ <link linkend="generic-programming">generic programming</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoGenerics</option></entry>
</row>
@@ -898,6 +894,12 @@
<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>
@@ -970,6 +972,12 @@
<entry>dynamic</entry>
<entry><option>-XNoDeriveDataTypeable</option></entry>
</row>
+ <row>
+ <entry><option>-XDeriveGeneric</option></entry>
+ <entry>Enable <link linkend="deriving-typeable">deriving for the Generic class</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDeriveGeneric</option></entry>
+ </row>
<row>
<entry><option>-XGeneralizedNewtypeDeriving</option></entry>
<entry>Enable <link linkend="newtype-deriving">newtype deriving</link>.</entry>
@@ -1001,6 +1009,12 @@
<entry>dynamic</entry>
<entry><option>-XNoConstrainedClassMethods</option></entry>
</row>
+ <row>
+ <entry><option>-XDefaultSignatures</option></entry>
+ <entry>Enable <link linkend="class-default-signatures">default signatures</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDefaultSignatures</option></entry>
+ </row>
<row>
<entry><option>-XMultiParamTypeClasses</option></entry>
<entry>Enable <link linkend="multi-param-type-classes">multi parameter type classes</link>.</entry>
@@ -1179,6 +1193,13 @@
<entry><option>-fno-warn-missing-signatures</option></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>
@@ -2219,6 +2240,12 @@ phase <replaceable>n</replaceable></entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
+ <row>
+ <entry><option>-ddump-to-file</option></entry>
+ <entry>Dump to files instead of stdout</entry>
+ <entry>dynamic</entry>
+ <entry>-</entry>
+ </row>
<row>
<entry><option>-ddump-asm</option></entry>
<entry>Dump assembly</entry>
@@ -2460,33 +2487,69 @@ phase <replaceable>n</replaceable></entry>
<entry>static</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>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index a5fba51788c7abf19760dae1980a24d057164e51..0f37953d5dcde24079a9c8c0daf8864f65a89b7b 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1201,6 +1201,234 @@ output = [ x
</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">
@@ -2984,6 +3212,12 @@ then writing the data type instance by hand.
</para>
</listitem>
+<listitem><para> With <option>-XDeriveGeneric</option>, you can derive
+instances of the class <literal>Generic</literal>, defined in
+<literal>GHC.Generics</literal>. You can use these to define generic functions,
+as described in <xref linkend="generic-programming"/>.
+</para></listitem>
+
<listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
the class <literal>Functor</literal>,
defined in <literal>GHC.Base</literal>.
@@ -3304,6 +3538,47 @@ GHC lifts this restriction (flag <option>-XConstrainedClassMethods</option>).
</para>
+</sect3>
+
+
+<sect3 id="class-default-signatures">
+<title>Default signatures</title>
+
+<para>
+Haskell 98 allows you to define a default implementation when declaring a class:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ enum = []
+</programlisting>
+The type of the <literal>enum</literal> method is <literal>[a]</literal>, and
+this is also the type of the default method. You can lift this restriction
+and give another type to the default method using the flag
+<option>-XDefaultSignatures</option>. For instance, if you have written a
+generic implementation of enumeration in a class <literal>GEnum</literal>
+with method <literal>genum</literal> in terms of <literal>GHC.Generics</literal>,
+you can specify a default method that uses that generic implementation:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ default enum :: (Generic a, GEnum (Rep a)) => [a]
+ enum = map to genum
+</programlisting>
+We reuse the keyword <literal>default</literal> to signal that a signature
+applies to the default method only; when defining instances of the
+<literal>Enum</literal> class, the original type <literal>[a]</literal> of
+<literal>enum</literal> still applies. When giving an empty instance, however,
+the default implementation <literal>map to0 genum</literal> is filled-in,
+and type-checked with the type
+<literal>(Generic a, GEnum (Rep a)) => [a]</literal>.
+</para>
+
+<para>
+We use default signatures to simplify generic programming in GHC
+(<xref linkend="generic-programming"/>).
+</para>
+
+
</sect3>
</sect2>
@@ -5884,7 +6159,7 @@ type variables, in the annotated expression. For example:
<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>
@@ -8899,7 +9174,7 @@ allows control over inlining on a per-call-site basis.
restrains the strictness analyser.
</para></listitem>
<listitem><para>
-<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>lazy</literal></ulink>
+<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink>
allows you to fool the type checker.
</para></listitem>
</itemizedlist>
@@ -8911,257 +9186,185 @@ allows you to fool the type checker.
<title>Generic classes</title>
<para>
-The ideas behind this extension are described in detail in "Derivable type classes",
-Ralf Hinze and Simon Peyton Jones, Haskell Workshop, Montreal Sept 2000, pp94-105.
-An example will give the idea:
+GHC used to have an implementation of generic classes as defined in the paper
+"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop,
+Montreal Sept 2000, pp94-105. These have been removed and replaced by the more
+general <link linkend="generic-programming">support for generic programming</link>.
</para>
-<programlisting>
- import Data.Generics
-
- class Bin a where
- toBin :: a -> [Int]
- fromBin :: [Int] -> (a, [Int])
-
- toBin {| Unit |} Unit = []
- toBin {| a :+: b |} (Inl x) = 0 : toBin x
- toBin {| a :+: b |} (Inr y) = 1 : toBin y
- toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
-
- fromBin {| Unit |} bs = (Unit, bs)
- fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs
- fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs
- fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs
- (y,bs'') = fromBin bs'
-</programlisting>
-<para>
-This class declaration explains how <literal>toBin</literal> and <literal>fromBin</literal>
-work for arbitrary data types. They do so by giving cases for unit, product, and sum,
-which are defined thus in the library module <literal>Data.Generics</literal>:
-</para>
-<programlisting>
- data Unit = Unit
- data a :+: b = Inl a | Inr b
- data a :*: b = a :*: b
-</programlisting>
-<para>
-Now you can make a data type into an instance of Bin like this:
-<programlisting>
- instance (Bin a, Bin b) => Bin (a,b)
- instance Bin a => Bin [a]
-</programlisting>
-That is, just leave off the "where" clause. Of course, you can put in the
-where clause and over-ride whichever methods you please.
-</para>
+</sect1>
- <sect2>
- <title> Using generics </title>
- <para>To use generics you need to</para>
- <itemizedlist>
- <listitem>
- <para>
- Use the flags <option>-XGenerics</option> (to enable the
- extra syntax and generate extra per-data-type code),
- and <option>-package syb</option> (to make the
- <literal>Data.Generics</literal> module available.
- </para>
- </listitem>
- <listitem>
- <para>Import the module <literal>Data.Generics</literal> from the
- <literal>syb</literal> package. This import brings into
- scope the data types <literal>Unit</literal>,
- <literal>:*:</literal>, and <literal>:+:</literal>. (You
- don't need this import if you don't mention these types
- explicitly; for example, if you are simply giving instance
- declarations.)</para>
- </listitem>
- </itemizedlist>
- </sect2>
-<sect2> <title> Changes wrt the paper </title>
-<para>
-Note that the type constructors <literal>:+:</literal> and <literal>:*:</literal>
-can be written infix (indeed, you can now use
-any operator starting in a colon as an infix type constructor). Also note that
-the type constructors are not exactly as in the paper (Unit instead of 1, etc).
-Finally, note that the syntax of the type patterns in the class declaration
-uses "<literal>{|</literal>" and "<literal>|}</literal>" brackets; curly braces
-alone would ambiguous when they appear on right hand sides (an extension we
-anticipate wanting).
-</para>
-</sect2>
+<sect1 id="generic-programming">
+<title>Generic programming</title>
-<sect2> <title>Terminology and restrictions</title>
<para>
-Terminology. A "generic default method" in a class declaration
-is one that is defined using type patterns as above.
-A "polymorphic default method" is a default method defined as in Haskell 98.
-A "generic class declaration" is a class declaration with at least one
-generic default method.
+Using a combination of <option>-XDeriveGeneric</option>
+(<xref linkend="deriving-typeable"/>) and
+<option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>),
+you can easily do datatype-generic
+programming using the <literal>GHC.Generics</literal> framework. This section
+gives a very brief overview of how to do it. For more detail please refer to the
+<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink>
+or the original paper:
</para>
-<para>
-Restrictions:
<itemizedlist>
<listitem>
<para>
-Alas, we do not yet implement the stuff about constructor names and
-field labels.
+José Pedro Magalhães, Atze Dijkstra, Johan Jeuring, and Andres Löh.
+<ulink url="http://dreixel.net/research/pdf/gdmh.pdf">
+ A generic deriving mechanism for Haskell</ulink>.
+<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle>
+(Haskell'2010), pp. 37-48, ACM, 2010.
</para>
</listitem>
+</itemizedlist>
-<listitem>
-<para>
-A generic class can have only one parameter; you can't have a generic
-multi-parameter class.
-</para>
-</listitem>
+<emphasis>Note</emphasis>: the current support for generic programming in GHC
+is preliminary. In particular, we only allow deriving instances for the
+<literal>Generic</literal> class. Support for deriving
+<literal>Generic1</literal> (and thus enabling generic functions of kind
+<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a
+later stage.
-<listitem>
-<para>
-A default method must be defined entirely using type patterns, or entirely
-without. So this is illegal:
-<programlisting>
- class Foo a where
- op :: a -> (a, Bool)
- op {| Unit |} Unit = (Unit, True)
- op x = (x, False)
-</programlisting>
-However it is perfectly OK for some methods of a generic class to have
-generic default methods and others to have polymorphic default methods.
-</para>
-</listitem>
-<listitem>
-<para>
-The type variable(s) in the type pattern for a generic method declaration
-scope over the right hand side. So this is legal (note the use of the type variable ``p'' in a type signature on the right hand side:
-<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| p :*: q |} (x :*: y) = op (x :: p)
- ...
-</programlisting>
-</para>
-</listitem>
+<sect2>
+<title>Deriving representations</title>
-<listitem>
<para>
-The type patterns in a generic default method must take one of the forms:
-<programlisting>
- a :+: b
- a :*: b
- Unit
-</programlisting>
-where "a" and "b" are type variables. Furthermore, all the type patterns for
-a single type constructor (<literal>:*:</literal>, say) must be identical; they
-must use the same type variables. So this is illegal:
+The first thing we need is generic representations. The
+<literal>GHC.Generics</literal> module defines a couple of primitive types
+that can be used to represent most Haskell datatypes:
+
<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| a :+: b |} (Inl x) = True
- op {| p :+: q |} (Inr y) = False
+-- | Unit: used for constructors without arguments
+data U1 p = U1
+
+-- | Constants, additional parameters and recursion of kind *
+newtype K1 i c p = K1 { unK1 :: c }
+
+-- | Meta-information (constructor names, etc.)
+newtype M1 i c f p = M1 { unM1 :: f p }
+
+-- | Sums: encode choice between constructors
+infixr 5 :+:
+data (:+:) f g p = L1 (f p) | R1 (g p)
+
+-- | Products: encode multiple arguments to constructors
+infixr 6 :*:
+data (:*:) f g p = f p :*: g p
+</programlisting>
+
+For example, a user-defined datatype of trees <literal>data UserTree a = Node a
+(UserTree a) (UserTree a) | Leaf</literal> gets the following representation:
+
+<programlisting>
+instance Generic (UserTree a) where
+ -- Representation type
+ type Rep (UserTree a) =
+ M1 D D1UserTree (
+ M1 C C1_0UserTree (
+ M1 S NoSelector (K1 P a)
+ :*: M1 S NoSelector (K1 R (UserTree a))
+ :*: M1 S NoSelector (K1 R (UserTree a)))
+ :+: M1 C C1_1UserTree U1)
+
+ -- Conversion functions
+ from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))
+ from Leaf = M1 (R1 (M1 U1))
+ to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r
+ to (M1 (R1 (M1 U1))) = Leaf
+
+-- Meta-information
+data D1UserTree
+data C1_0UserTree
+data C1_1UserTree
+
+instance Datatype D1UserTree where
+ datatypeName _ = "UserTree"
+ moduleName _ = "Main"
+
+instance Constructor C1_0UserTree where
+ conName _ = "Node"
+
+instance Constructor C1_1UserTree where
+ conName _ = "Leaf"
</programlisting>
-The type patterns must be identical, even in equations for different methods of the class.
-So this too is illegal:
-<programlisting>
- class Foo a where
- op1 :: a -> Bool
- op1 {| a :*: b |} (x :*: y) = True
- op2 :: a -> Bool
- op2 {| p :*: q |} (x :*: y) = False
-</programlisting>
-(The reason for this restriction is that we gather all the equations for a particular type constructor
-into a single generic instance declaration.)
+This representation is generated automatically if a
+<literal>deriving Generic</literal> clause is attached to the datatype.
+<link linkend="stand-alone-deriving">Standalone deriving</link> can also be
+used.
</para>
-</listitem>
+</sect2>
-<listitem>
-<para>
-A generic method declaration must give a case for each of the three type constructors.
-</para>
-</listitem>
+<sect2>
+<title>Writing generic functions</title>
-<listitem>
<para>
-The type for a generic method can be built only from:
- <itemizedlist>
- <listitem> <para> Function arrows </para> </listitem>
- <listitem> <para> Type variables </para> </listitem>
- <listitem> <para> Tuples </para> </listitem>
- <listitem> <para> Arbitrary types not involving type variables </para> </listitem>
- </itemizedlist>
-Here are some example type signatures for generic methods:
+A generic function is defined by creating a class and giving instances for
+each of the representation types of <literal>GHC.Generics</literal>. As an
+example we show generic serialization:
<programlisting>
- op1 :: a -> Bool
- op2 :: Bool -> (a,Bool)
- op3 :: [Int] -> a -> a
- op4 :: [a] -> Bool
-</programlisting>
-Here, op1, op2, op3 are OK, but op4 is rejected, because it has a type variable
-inside a list.
-</para>
-<para>
-This restriction is an implementation restriction: we just haven't got around to
-implementing the necessary bidirectional maps over arbitrary type constructors.
-It would be relatively easy to add specific type constructors, such as Maybe and list,
-to the ones that are allowed.</para>
-</listitem>
+data Bin = O | I
-<listitem>
-<para>
-In an instance declaration for a generic class, the idea is that the compiler
-will fill in the methods for you, based on the generic templates. However it can only
-do so if
- <itemizedlist>
- <listitem>
- <para>
- The instance type is simple (a type constructor applied to type variables, as in Haskell 98).
- </para>
- </listitem>
- <listitem>
- <para>
- No constructor of the instance type has unboxed fields.
- </para>
- </listitem>
- </itemizedlist>
-(Of course, these things can only arise if you are already using GHC extensions.)
-However, you can still give an instance declarations for types which break these rules,
-provided you give explicit code to override any generic default methods.
-</para>
-</listitem>
+class GSerialize f where
+ gput :: f a -> [Bin]
-</itemizedlist>
-</para>
+instance GSerialize U1 where
+ gput U1 = []
-<para>
-The option <option>-ddump-deriv</option> dumps incomprehensible stuff giving details of
-what the compiler does with generic declarations.
-</para>
+instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
+ gput (a :*: b) = gput a ++ gput b
+
+instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where
+ gput (L1 x) = O : gput x
+ gput (R1 x) = I : gput x
+
+instance (GSerialize a) => GSerialize (M1 i c a) where
+ gput (M1 x) = gput x
+instance (Serialize a) => GSerialize (K1 i c a) where
+ gput (K1 x) = put x
+</programlisting>
+
+Typically this class will not be exported, as it only makes sense to have
+instances for the representation types.
+</para>
</sect2>
-<sect2> <title> Another example </title>
+<sect2>
+<title>Generic defaults</title>
+
<para>
-Just to finish with, here's another example I rather like:
+The only thing left to do now is to define a "front-end" class, which is
+exposed to the user:
<programlisting>
- class Tag a where
- nCons :: a -> Int
- nCons {| Unit |} _ = 1
- nCons {| a :*: b |} _ = 1
- nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
+class Serialize a where
+ put :: a -> [Bin]
- tag :: a -> Int
- tag {| Unit |} _ = 1
- tag {| a :*: b |} _ = 1
- tag {| a :+: b |} (Inl x) = tag x
- tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
+ default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
+ put = gput . from
</programlisting>
+Here we use a <link linkend="class-default-signatures">default signature</link>
+to specify that the user does not have to provide an implementation for
+<literal>put</literal>, as long as there is a <literal>Generic</literal>
+instance for the type to instantiate. For the <literal>UserTree</literal> type,
+for instance, the user can just write:
+
+<programlisting>
+instance (Serialize a) => Serialize (UserTree a)
+</programlisting>
+
+The default method for <literal>put</literal> is then used, corresponding to the
+generic implementation of serialization.
</para>
</sect2>
+
</sect1>
+
<sect1 id="monomorphism">
<title>Control over monomorphism</title>
diff --git a/docs/users_guide/shared_libs.xml b/docs/users_guide/shared_libs.xml
index def773c0a8ad8c02502b5ed6a3c52109355ab4dc..29dcb37f7fe7bfffe00cd3a0e62d81ae5f6c118c 100644
--- a/docs/users_guide/shared_libs.xml
+++ b/docs/users_guide/shared_libs.xml
@@ -16,7 +16,7 @@
shared between several programs. In contrast, with static linking the
code is copied into each program. Using shared libraries can thus save
disk space. They also allow a single copy of code to be shared in memory
- between several programs that use it. Shared libraires are often used as
+ between several programs that use it. Shared libraries are often used as
a way of structuring large projects, especially where different parts are
written in different programming languages. Shared libraries are also
commonly used as a plugin mechanism by various applications. This is
@@ -24,12 +24,10 @@
</para>
<para>
- In GHC version 6.12 building shared libraries is supported for Linux on
- x86 and x86-64 architectures and there is partial support on Windows (see
- <xref linkend="win32-dlls"/>). The crucial difference in support on
- Windows is that it is not currently possible to build each Haskell
- package as a separate DLL, it is only possible to link an entire Haskell
- program as one massive DLL.
+ In GHC version 6.12 building shared libraries is supported for Linux (on
+ x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+ (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+ Solaris (x86) and Mac OS X (x86 and PowerPC).
</para>
<para>
@@ -59,7 +57,7 @@ ghc --make -dynamic Main.hs
that it can be linked against shared library versions of Haskell
packages (such as base). The second is when linking, to link against
the shared versions of the packages' libraries rather than the static
- versions. Obviously this requires that the packages were build with
+ versions. Obviously this requires that the packages were built with
shared libraries. On supported platforms GHC comes with shared
libraries for all the core packages, but if you install extra packages
(e.g. with Cabal) then they would also have to be built with shared
@@ -87,10 +85,7 @@ ghc --make -dynamic Main.hs
In particular Haskell shared libraries <emphasis>must</emphasis> be
made into packages. You cannot freely assign which modules go in which
shared libraries. The Haskell shared libraries must match the package
- boundaries. Most of the conventions GHC expects when using packages are
- described in <xref linkend="building-packages"/>.
- </para>
- <para>
+ boundaries. The reason for this is that
GHC handles references to symbols <emphasis>within</emphasis> the same
shared library (or main executable binary) differently from references
to symbols <emphasis>between</emphasis> different shared libraries. GHC
@@ -153,8 +148,6 @@ ghc -dynamic -shared Foo.o -o libfoo.so
<literal>-dynamic</literal> in the link step. That means to
statically link the rts all the base libraries into your new shared
library. This would make a very big, but standalone shared library.
- Indeed this is exactly what we must currently do on Windows where
- -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
On most platforms however that would require all the static libraries
to have been built with <literal>-fPIC</literal> so that the code is
suitable to include into a shared library and we do not do that at the
@@ -176,6 +169,8 @@ ghc -dynamic -shared Foo.o -o libfoo.so
The details of how this works varies between platforms, in particular
the three major systems: Unix ELF platforms, Windows and Mac OS X.
</para>
+ <sect3 id="finding-shared-libs-unix">
+ <title>Unix</title>
<para>
On Unix there are two mechanisms. Shared libraries can be installed
into standard locations that the dynamic linker knows about. For
@@ -190,20 +185,21 @@ ghc -dynamic -shared Foo.o -o libfoo.so
<para>
GHC has a <literal>-dynload</literal> linking flag to select the method
that is used to find shared libraries at runtime. There are currently
- three modes:
+ two modes:
<variablelist>
<varlistentry>
<term>sysdep</term>
<listitem>
<para>
A system-dependent mode. This is also the default mode. On Unix
- ELF systems this embeds rpaths into the shared library or
- executable. In particular it uses absolute paths to where the
- shared libraries for the rts and each package can be found.
- This means the program can immediately be run and it will be
- able to find the libraries it needs. However it may not be
- suitable for deployment if the libraries are installed in a
- different location on another machine.
+ ELF systems this embeds
+ <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+ shared library or executable. In particular it uses absolute paths to
+ where the shared libraries for the rts and each package can be found.
+ This means the program can immediately be run and it will be able to
+ find the libraries it needs. However it may not be suitable for
+ deployment if the libraries are installed in a different location on
+ another machine.
</para>
</listitem>
</varlistentry>
@@ -220,8 +216,7 @@ ghc -dynamic -shared Foo.o -o libfoo.so
</varlistentry>
</variablelist>
To use relative paths for dependent libraries on Linux and Solaris you
- can use the <literal>deploy</literal> mode and pass suitable a -rpath
- flag to the linker:
+ can pass a suitable <literal>-rpath</literal> flag to the linker:
<programlisting>
ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
</programlisting>
@@ -232,7 +227,24 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
</para>
<para>
- The standard assumption on Darwin/MacOS X is that dynamic libraries will
+ This relative path technique can be used with either of the two
+ <literal>-dynload</literal> modes, though it makes most sense with the
+ <literal>deploy</literal> mode. The difference is that with the
+ <literal>deploy</literal> mode, the above example will end up with an ELF
+ <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+ the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+ <literal>$ORIGIN</literal> followed by all the library directories of all
+ the packages that the program depends on (e.g. <literal>base</literal>
+ and <literal>rts</literal> packages etc.) which are typically absolute
+ paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+ inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+ entries in ELF shared libraries and executables.
+ </para>
+ </sect3>
+ <sect3 id="finding-shared-libs-mac">
+ <title>Mac OS X</title>
+ <para>
+ The standard assumption on Darwin/Mac OS X is that dynamic libraries will
be stamped at build time with an "install name", which is the full
ultimate install path of the library file. Any libraries or executables
that subsequently link against it (even if it hasn't been installed yet)
@@ -244,6 +256,7 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
for you. It automatically sets the install name for dynamic libraries to
the absolute path of the ultimate install location.
</para>
+ </sect3>
</sect2>
</sect1>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index 8b08d9d5266107bdcd0686705d76f5f9e578aee9..df015213d88de845703dc8de223432abb0466e89 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -781,18 +781,6 @@ ghc -c Foo.hs</screen>
<para>See also the <option>--help</option>, <option>--version</option>, <option>--numeric-version</option>,
and <option>--print-libdir</option> modes in <xref linkend="modes"/>.</para>
<variablelist>
- <varlistentry>
- <term>
- <option>-n</option>
- <indexterm><primary><option>-n</option></primary></indexterm>
- </term>
- <listitem>
- <para>Does a dry-run, i.e. GHC goes through all the motions
- of compiling as normal, but does not actually run any
- external commands.</para>
- </listitem>
- </varlistentry>
-
<varlistentry>
<term>
<option>-v</option>
@@ -1372,6 +1360,20 @@ module M where
</listitem>
</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>
diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml
index f00e1e2c388927abcdf3730665841416782f99c1..44f589adf2a032a39687c7fef4265b8dd38e2904 100644
--- a/docs/users_guide/win32-dlls.xml
+++ b/docs/users_guide/win32-dlls.xml
@@ -208,15 +208,6 @@ make-sessions running under cygwin.
<title>Building and using Win32 DLLs
</title>
-<para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>). Note that
-building an entire Haskell application as a single DLL is still supported: it's
- just multi-DLL Haskell programs that don't work. The Windows
- distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
<para>
<indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
<indexterm><primary>DLLs, Win32</primary></indexterm>
@@ -225,6 +216,33 @@ dynamic link libraries (DLLs) containing ghc-compiled code. This
section shows you how to make use of this facility.
</para>
+<para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+ <listitem>
+ <para>
+ You can turn each Haskell package into a DLL, so that multiple
+ Haskell executables using the same packages can share the DLL files.
+ (As opposed to linking the libraries statically, which in effect
+ creates a new copy of the RTS and all libraries for each executable
+ produced.)
+ </para>
+ <para>
+ That is the same as the dynamic linking on other platforms, and it
+ is described in <xref linkend="using-shared-libs"/>.
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ You can package up a complete Haskell program as a DLL, to be called
+ by some external (usually non-Haskell) program. This is usually used
+ to implement plugins and the like, and is described below.
+ </para>
+ </listitem>
+</itemizedlist>
+</para>
+
+<!--
<para>
Until recently, <command>strip</command> didn't work reliably on DLLs, so you
should test your version with care, or make sure you have the latest
diff --git a/extra-gcc-opts.in b/extra-gcc-opts.in
deleted file mode 100644
index 8c9832c835feb54efa708ace3f4e45e74362cf4b..0000000000000000000000000000000000000000
--- a/extra-gcc-opts.in
+++ /dev/null
@@ -1 +0,0 @@
-@GccExtraViaCOpts@
diff --git a/ghc.mk b/ghc.mk
index 863ddc265148d5396bb00d8e7cd8afc363c8e606..4508b683b02d8b9727c77076ede950ec4c72034f 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -227,6 +227,7 @@ include rules/package-config.mk
# -----------------------------------------------------------------------------
# Building dependencies
+include rules/dependencies.mk
include rules/build-dependencies.mk
include rules/include-dependencies.mk
@@ -438,13 +439,13 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk
# package-data.mk is sufficient, as that in turn depends on all the
# libraries
utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
-utils/ghc-pwd/dist/package-data.mk: compiler/stage2/package-data.mk
+utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk
-utils/compare_sizes/dist/package-data.mk: compiler/stage2/package-data.mk
-utils/runghc/dist/package-data.mk: compiler/stage2/package-data.mk
+utils/compare_sizes/dist-install/package-data.mk: compiler/stage2/package-data.mk
+utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk
# add the final two package.conf dependencies: ghc-prim depends on RTS,
# and RTS depends on libffi.
@@ -749,7 +750,7 @@ TAGS: TAGS_compiler
# -----------------------------------------------------------------------------
# Installation
-install: install_packages install_libs install_libexecs install_headers \
+install: install_libs install_packages install_libexecs install_headers \
install_libexec_scripts install_bins install_topdirs
ifeq "$(HADDOCK_DOCS)" "YES"
install: install_docs
@@ -903,13 +904,13 @@ $(eval $(call bindist,.,\
README \
INSTALL \
configure config.sub config.guess install-sh \
- extra-gcc-opts.in \
+ settings.in \
packages \
Makefile \
mk/config.mk.in \
$(INPLACE_BIN)/mkdirhier \
utils/ghc-cabal/dist-install/build/tmp/ghc-cabal \
- utils/ghc-pwd/dist/build/tmp/ghc-pwd \
+ utils/ghc-pwd/dist-install/build/tmp/ghc-pwd \
$(BINDIST_WRAPPERS) \
$(BINDIST_PERL_SOURCES) \
$(BINDIST_LIBS) \
@@ -932,7 +933,7 @@ $(eval $(call bindist,.,\
compiler/stage2/doc \
$(wildcard libraries/*/dist-install/doc/) \
$(wildcard libraries/*/*/dist-install/doc/) \
- $(filter-out extra-gcc-opts,$(INSTALL_LIBS)) \
+ $(filter-out settings,$(INSTALL_LIBS)) \
$(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \
mk/project.mk \
mk/install.mk.in \
@@ -953,7 +954,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk
unix-binary-dist-prep:
"$(RM)" $(RM_OPTS_REC) bindistprep/
"$(MKDIRHIER)" $(BIN_DIST_PREP_DIR)
- set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh extra-gcc-opts.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
+ set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
echo "HADDOCK_DOCS = $(HADDOCK_DOCS)" >> $(BIN_DIST_MK)
echo "LATEX_DOCS = $(LATEX_DOCS)" >> $(BIN_DIST_MK)
echo "BUILD_DOCBOOK_HTML = $(BUILD_DOCBOOK_HTML)" >> $(BIN_DIST_MK)
@@ -1042,7 +1043,7 @@ SRC_DIST_DIRS = mk rules docs distrib bindisttest libffi includes utils docs rts
SRC_DIST_FILES += \
configure.ac config.guess config.sub configure \
aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \
- ghc.spec.in ghc.spec extra-gcc-opts.in VERSION \
+ ghc.spec.in ghc.spec settings.in VERSION \
boot boot-pkgs packages ghc.mk
SRC_DIST_TARBALL = $(SRC_DIST_NAME)-src.tar.bz2
@@ -1157,7 +1158,7 @@ distclean : clean
"$(RM)" $(RM_OPTS) config.cache config.status config.log mk/config.h mk/stamp-h
"$(RM)" $(RM_OPTS) mk/config.mk mk/are-validating.mk mk/project.mk
"$(RM)" $(RM_OPTS) mk/config.mk.old mk/project.mk.old
- "$(RM)" $(RM_OPTS) extra-gcc-opts docs/users_guide/ug-book.xml
+ "$(RM)" $(RM_OPTS) settings docs/users_guide/ug-book.xml
"$(RM)" $(RM_OPTS) compiler/ghc.cabal compiler/ghc.cabal.old
"$(RM)" $(RM_OPTS) ghc/ghc-bin.cabal
"$(RM)" $(RM_OPTS) libraries/base/include/HsBaseConfig.h
diff --git a/ghc.spec.in b/ghc.spec.in
index c8eab264c217a86f499ae76b6a7896b784bc6509..2a70043eea2f302489b86d40427f168b6975d248 100644
--- a/ghc.spec.in
+++ b/ghc.spec.in
@@ -177,7 +177,6 @@ fi
%{_prefix}/bin/ghci
%{_prefix}/bin/ghci-%{version}
%{_prefix}/bin/ghcprof
-%{_prefix}/bin/hasktags
%{_prefix}/bin/hp2ps
%{_prefix}/bin/hpc
%{_prefix}/bin/hsc2hs-ghc
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 2aff48385e3d5962cb00282ea11d3f6415e3f13f..52b28efdffc3d60078fa9b0167452deb8a3681c3 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -56,7 +56,7 @@ data GHCiState = GHCiState
editor :: String,
stop :: String,
options :: [GHCiOption],
- prelude :: GHC.Module,
+ prelude :: GHC.ModuleName,
line_number :: !Int, -- input line
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
@@ -78,7 +78,7 @@ data GHCiState = GHCiState
ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
}
-data CtxtCmd -- In each case, the first [String] are the starred modules
+data CtxtCmd -- In each case, the first [String] are the starred modules
-- and the second are the unstarred ones
= SetContext [String] [String]
| AddModules [String] [String]
@@ -210,7 +210,7 @@ instance ExceptionMonad (InputT GHCi) where
gunblock = Haskeline.unblock
-- for convenience...
-getPrelude :: GHCi Module
+getPrelude :: GHCi ModuleName
getPrelude = getGHCiState >>= return . prelude
getDynFlags :: GhcMonad m => m DynFlags
diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs
index c2e6973e1857ca5095ec4bc14752cda7e04fc4d4..fc5cf00e4b03db6dfa9a1ed7029ce6747f225304 100644
--- a/ghc/GhciTags.hs
+++ b/ghc/GhciTags.hs
@@ -101,10 +101,11 @@ listModuleTags m = do
]
where
- tyThing2TagKind (AnId _) = 'v'
+ tyThing2TagKind (AnId _) = 'v'
tyThing2TagKind (ADataCon _) = 'd'
- tyThing2TagKind (ATyCon _) = 't'
- tyThing2TagKind (AClass _) = 'c'
+ tyThing2TagKind (ATyCon _) = 't'
+ tyThing2TagKind (AClass _) = 'c'
+ tyThing2TagKind (ACoAxiom _) = 'x'
data TagInfo = TagInfo
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 2685377500f467c59317f4869d0871f9709dbced..757b634cc1754a1c0f1f84086d38c1ed7b8db104 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -38,7 +38,7 @@ import HscTypes ( handleFlagWarnings )
import HsImpExp
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import RdrName (RdrName)
-import Outputable hiding (printForUser, printForUserPartWay)
+import Outputable hiding (printForUser, printForUserPartWay, bold)
import Module -- for ModuleEnv
import Name
import SrcLoc
@@ -137,7 +137,7 @@ builtin_commands = [
("kind", keepGoing' kindOfType, completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion),
- ("module", keepGoing setContext, completeSetModule),
+ ("module", keepGoing moduleCmd, completeSetModule),
("main", keepGoing runMain, completeFilename),
("print", keepGoing printCmd, completeExpression),
("quit", quit, noCompletion),
@@ -346,8 +346,8 @@ interactiveUI srcs maybe_exprs = do
#endif
-- initial context is just the Prelude
- prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
- GHC.setContext [] [(prel_mod, Nothing)]
+ let prel_mn = GHC.mkModuleName "Prelude"
+ GHC.setContext [] [simpleImportDecl prel_mn]
default_editor <- liftIO $ findEditor
@@ -359,7 +359,7 @@ interactiveUI srcs maybe_exprs = do
editor = default_editor,
-- session = session,
options = [],
- prelude = prel_mod,
+ prelude = prel_mn,
line_number = 1,
break_ctr = 0,
breaks = [],
@@ -544,7 +544,7 @@ fileLoop hdl = do
mkPrompt :: GHCi String
mkPrompt = do
- (toplevs,exports) <- GHC.getContext
+ (toplevs,imports) <- GHC.getContext
resumes <- GHC.getResumeContext
-- st <- getGHCiState
@@ -570,7 +570,7 @@ mkPrompt = do
-- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
-- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
- hsep (map (ppr . GHC.moduleName) (nub (map fst exports)))
+ hsep (map ppr (nub (map ideclName imports)))
deflt_prompt = dots <> context_bit <> modules_bit
@@ -1151,7 +1151,7 @@ reloadModule m = do
else LoadUpTo (GHC.mkModuleName m)
return ()
-doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag
doLoad retain_context prev_context howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
@@ -1160,7 +1160,7 @@ doLoad retain_context prev_context howmuch = do
afterLoad ok retain_context prev_context
return ok
-afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi ()
+afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi ()
afterLoad ok retain_context prev_context = do
lift revertCAFs -- always revert CAFs on load.
lift discardTickArrays
@@ -1172,10 +1172,10 @@ afterLoad ok retain_context prev_context = do
lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
-setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi ()
setContextAfterLoad prev keep_ctxt [] = do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)])
+ setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod])
setContextAfterLoad prev keep_ctxt ms = do
-- load a target if one is available, otherwise load the topmost module.
targets <- GHC.getTargets
@@ -1203,25 +1203,40 @@ setContextAfterLoad prev keep_ctxt ms = do
if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
else do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)])
+ setContextKeepingPackageModules prev keep_ctxt
+ ([], [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName m)])
-- | Keep any package modules (except Prelude) when changing the context.
setContextKeepingPackageModules
- :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context
+ :: ([Module],[ImportDecl RdrName]) -- previous context
-> Bool -- re-execute :module commands
- -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context
+ -> ([Module],[ImportDecl RdrName]) -- new context
-> GHCi ()
setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
- let (_,bs0) = prev_context
+ let (_,imports0) = prev_context
prel_mod <- getPrelude
-- filter everything, not just lefts
- let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0
- let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs
- GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules))
+
+ let is_pkg_mod i
+ | unLoc (ideclName i) == prel_mod = return False
+ | otherwise = do
+ e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ case e :: Either SomeException Module of
+ Left _ -> return False
+ Right m -> return (not (isHomeModule m))
+
+ pkg_modules <- filterM is_pkg_mod imports0
+
+ let bs1 = if null as
+ then nubBy sameMod (simpleImportDecl prel_mod : bs)
+ else bs
+
+ GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules))
if keep_ctxt
then do
st <- getGHCiState
- mapM_ (playCtxtCmd False) (remembered_ctx st)
+ playCtxtCmds False (remembered_ctx st)
else do
st <- getGHCiState
setGHCiState st{ remembered_ctx = [] }
@@ -1229,8 +1244,8 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
isHomeModule :: Module -> Bool
isHomeModule mod = GHC.modulePackageId mod == mainPackageId
-sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool
-sameFst x y = fst x == fst y
+sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool
+sameMod x y = unLoc (ideclName x) == unLoc (ideclName y)
modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
modulesLoadedMsg ok mods = do
@@ -1321,7 +1336,10 @@ browseCmd bang m =
-- recently-added module occurs last, it seems.
case (as,bs) of
(as@(_:_), _) -> browseModule bang (last as) True
- ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True
+ ([], bs@(_:_)) -> do
+ let i = last bs
+ m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ browseModule bang m True
([], []) -> ghcError (CmdLineError ":browse: no current module")
_ -> ghcError (CmdLineError "syntax: :browse <module>")
@@ -1337,7 +1355,8 @@ browseModule bang modl exports_only = do
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- GHC.getContext
prel_mod <- lift getPrelude
- if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)]
+ if exports_only then GHC.setContext [] [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName modl)]
else GHC.setContext [modl] []
target_unqual <- GHC.getPrintUnqual
GHC.setContext as bs
@@ -1415,13 +1434,13 @@ browseModule bang modl exports_only = do
newContextCmd :: CtxtCmd -> GHCi ()
newContextCmd cmd = do
- playCtxtCmd True cmd
+ playCtxtCmds True [cmd]
st <- getGHCiState
let cmds = remembered_ctx st
setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
-setContext :: String -> GHCi ()
-setContext str
+moduleCmd :: String -> GHCi ()
+moduleCmd str
| all sensible strs = newContextCmd cmd
| otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
@@ -1441,53 +1460,65 @@ setContext str
starred ('*':m) = Left m
starred m = Right m
-playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
-playCtxtCmd fail cmd = do
- (prev_as,prev_bs) <- GHC.getContext
+type Context = ([GHC.Module], [GHC.ImportDecl GHC.RdrName])
+
+playCtxtCmds :: Bool -> [CtxtCmd] -> GHCi ()
+playCtxtCmds fail cmds = do
+ ctx <- GHC.getContext
+ (as,bs) <- foldM (playCtxtCmd fail) ctx cmds
+ GHC.setContext as bs
+
+playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context
+playCtxtCmd fail (prev_as, prev_bs) cmd = do
case cmd of
SetContext as bs -> do
(as',bs') <- do_checks as bs
prel_mod <- getPrelude
- let bs'' = if null as && prel_mod `notElem` (map fst bs')
- then (prel_mod,Nothing):bs'
+ let bs'' = if null as && prel_mod `notElem` bs'
+ then prel_mod : bs'
else bs'
- GHC.setContext as' bs''
+ return (as', map simpleImportDecl bs'')
AddModules as bs -> do
(as',bs') <- do_checks as bs
- -- it should replace the old stuff, not the other way around
- -- need deleteAllBy, not deleteFirstsBy for sameFst
- let remaining_as = prev_as \\ (as' ++ map fst bs')
- remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as')
- GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs')
+ let (remaining_as, remaining_bs) =
+ prev_without (map moduleName as' ++ bs')
+ return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl bs')
RemModules as bs -> do
(as',bs') <- do_checks as bs
- let new_as = prev_as \\ (as' ++ map fst bs')
- new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs')
- GHC.setContext new_as new_bs
+ let (new_as, new_bs) = prev_without (map moduleName as' ++ bs')
+ return (new_as, new_bs)
Import str -> do
m_idecl <- maybe_fail $ GHC.parseImportDecl str
case m_idecl of
- Nothing -> return ()
+ Nothing -> return (prev_as, prev_bs)
Just idecl -> do
m_mdl <- maybe_fail $ loadModuleName idecl
case m_mdl of
- Nothing -> return ()
- Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)])
-
+ Nothing -> return (prev_as, prev_bs)
+ Just _ -> return (prev_as, prev_bs ++ [idecl])
+ -- we don't filter the module out of the old declarations,
+ -- because 'import' is supposed to be cumulative.
where
maybe_fail | fail = liftM Just
| otherwise = trymaybe
+ prev_without names = (as',bs')
+ where as' = deleteAllBy sameModName prev_as names
+ bs' = deleteAllBy importsSameMod prev_bs names
+
do_checks as bs = do
as' <- mapM (maybe_fail . wantInterpretedModule) as
- bs' <- mapM (maybe_fail . lookupModule) bs
- return (catMaybes as', map contextualize (catMaybes bs'))
+ bs' <- mapM (maybe_fail . liftM moduleName . lookupModule) bs
+ return (catMaybes as', catMaybes bs')
+
+ sameModName a b = moduleName a == b
+ importsSameMod a b = unLoc (ideclName a) == b
- contextualize x = (x,Nothing)
- deleteAllBy f a b = filter (\x->(not (any (f x) b))) a
+ deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a]
+ deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as
trymaybe ::GHCi a -> GHCi (Maybe a)
trymaybe m = do
@@ -1828,8 +1859,8 @@ completeModule = wrapIdentCompleter $ \w -> do
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
modules <- case m of
Just '-' -> do
- (toplevs, exports) <- GHC.getContext
- return $ map GHC.moduleName (nub (map fst exports) ++ toplevs)
+ (toplevs, imports) <- GHC.getContext
+ return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports
_ -> do
dflags <- GHC.getSessionDynFlags
let pkg_mods = allExposedModules dflags
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 9c993345bb7fa093f2722e668466f637359a298d..12d8dd202b4bbe07f139bec9881e7f3ac177950a 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -78,7 +78,8 @@ import Data.Maybe
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
- GHC.defaultErrorHandler defaultDynFlags $ do
+ let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings")
+ GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
@@ -358,9 +359,6 @@ showVersionMode = mkPreStartupMode ShowVersion
showNumVersionMode = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
-printMode :: String -> Mode
-printMode str = mkPreStartupMode (Print str)
-
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left
@@ -383,8 +381,10 @@ showGhcUsageMode = mkPreLoadMode ShowGhcUsage
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
showInfoMode = mkPreLoadMode ShowInfo
-printWithDynFlagsMode :: (DynFlags -> String) -> Mode
-printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f)
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+ $ lookup k (compilerInfo dflags)
mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = Right . Left
@@ -504,14 +504,30 @@ mode_flags =
, Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
, Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
] ++
- [ Flag k' (PassFlag (setMode mode))
- | (k, v) <- compilerInfo,
+ [ Flag k' (PassFlag (setMode (printSetting k)))
+ | k <- ["Project version",
+ "Booter version",
+ "Stage",
+ "Build platform",
+ "Host platform",
+ "Target platform",
+ "Have interpreter",
+ "Object splitting supported",
+ "Have native code generator",
+ "Support SMP",
+ "Unregisterised",
+ "Tables next to code",
+ "RTS ways",
+ "Leading underscore",
+ "Debug on",
+ "LibDir",
+ "Global Package DB",
+ "C compiler flags",
+ "Gcc Linker flags",
+ "Ld Linker flags"],
let k' = "-print-" ++ map (replaceSpace . toLower) k
replaceSpace ' ' = '-'
replaceSpace c = c
- mode = case v of
- String str -> printMode str
- FromDynFlags f -> printWithDynFlagsMode f
] ++
------- interfaces ----------------------------------------------------
[ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
@@ -649,9 +665,7 @@ showBanner _postLoadMode dflags = do
showInfo :: DynFlags -> IO ()
showInfo dflags = do
let sq x = " [" ++ x ++ "\n ]"
- putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo
- where flatten (k, String v) = (k, v)
- flatten (k, FromDynFlags f) = (k, f dflags)
+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
showSupportedExtensions :: IO ()
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 420c9186157590739c188b95f3506b22eece0320..61b7b340acff33cb67ac6b1eb088e5ae2e72ec9e 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -14,7 +14,7 @@ Description:
XXX
Category: XXX
Data-Dir: ..
-Data-Files: extra-gcc-opts
+Data-Files: settings
Build-Type: Simple
Cabal-Version: >= 1.2
diff --git a/ghc/ghc.mk b/ghc/ghc.mk
index 8776566106c1cbf7480fb9a1a737ff5ad56a9c75..da9fd8a2936a14d43e147f84ec9572524a8b2630 100644
--- a/ghc/ghc.mk
+++ b/ghc/ghc.mk
@@ -108,24 +108,26 @@ all_ghc_stage1 : $(GHC_STAGE1)
all_ghc_stage2 : $(GHC_STAGE2)
all_ghc_stage3 : $(GHC_STAGE3)
-$(INPLACE_LIB)/extra-gcc-opts : extra-gcc-opts
+$(INPLACE_LIB)/settings : settings
"$(CP)" $< $@
-# The GHC programs need to depend on all the helper programs they might call
+# The GHC programs need to depend on all the helper programs they might call,
+# and the settings files they use
+
+$(GHC_STAGE1) : | $(UNLIT) $(INPLACE_LIB)/settings
+$(GHC_STAGE2) : | $(UNLIT) $(INPLACE_LIB)/settings
+$(GHC_STAGE3) : | $(UNLIT) $(INPLACE_LIB)/settings
+
ifeq "$(GhcUnregisterised)" "NO"
-$(GHC_STAGE1) : $(SPLIT)
-$(GHC_STAGE2) : $(SPLIT)
-$(GHC_STAGE3) : $(SPLIT)
+$(GHC_STAGE1) : | $(SPLIT)
+$(GHC_STAGE2) : | $(SPLIT)
+$(GHC_STAGE3) : | $(SPLIT)
endif
-$(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts
-$(GHC_STAGE2) : $(INPLACE_LIB)/extra-gcc-opts
-$(GHC_STAGE3) : $(INPLACE_LIB)/extra-gcc-opts
-
ifeq "$(Windows)" "YES"
-$(GHC_STAGE1) : $(TOUCHY)
-$(GHC_STAGE2) : $(TOUCHY)
-$(GHC_STAGE3) : $(TOUCHY)
+$(GHC_STAGE1) : | $(TOUCHY)
+$(GHC_STAGE2) : | $(TOUCHY)
+$(GHC_STAGE3) : | $(TOUCHY)
endif
ifeq "$(BootingFromHc)" "YES"
@@ -135,7 +137,7 @@ endif
endif
-INSTALL_LIBS += extra-gcc-opts
+INSTALL_LIBS += settings
ifeq "$(Windows)" "NO"
install: install_ghc_link
diff --git a/ghc/ghc.wrapper b/ghc/ghc.wrapper
index 5003f9ae4000d9a8a5f352e0e9e68997cbce21d8..083a66db7e7d55a0a3eeb887d5cf431533d0d678 100644
--- a/ghc/ghc.wrapper
+++ b/ghc/ghc.wrapper
@@ -1 +1 @@
-exec "$executablename" -B"$topdir" -pgmc "$pgmgcc" -pgma "$pgmgcc" -pgml "$pgmgcc" -pgmP "$pgmgcc -E -undef -traditional" ${1+"$@"}
+exec "$executablename" -B"$topdir" ${1+"$@"}
diff --git a/includes/Cmm.h b/includes/Cmm.h
index d5a996ddc7b611c9954b55cb576ccb8665db6099..ad9eccd48149ea1f391ccb2526c04d2bdbc12ca2 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -468,8 +468,10 @@
#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i)
#endif
-#define mutArrPtrsCardWords(n) \
- ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
#define isGlobalPrim(bd,p) \
(TO_W_(bdescr_gen_ix(bd)) >= TO_W_(CInt[global_gen_ix]) || (W_[(p) - WDS(1)] != 0))
diff --git a/includes/Rts.h b/includes/Rts.h
index 51351fab0d595717926f0fb020ccfd97ce7bdd46..91ec76d4675de9f11eb476f76e4e45a04839ae7b 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -219,6 +219,12 @@ DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell *
DLL_IMPORT_RTS extern int prog_argc;
DLL_IMPORT_RTS extern char *prog_name;
+#ifdef mingw32_HOST_OS
+// We need these two from Haskell too
+void getWin32ProgArgv(int *argc, wchar_t **argv[]);
+void setWin32ProgArgv(int argc, wchar_t *argv[]);
+#endif
+
void stackOverflow(void);
void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
@@ -242,9 +248,6 @@ int stg_sig_install (int, int, void *);
Miscellaneous garbage
-------------------------------------------------------------------------- */
-/* declarations for runtime flags/values */
-#define MAX_RTS_ARGS 32
-
#ifdef DEBUG
#define TICK_VAR(arity) \
extern StgInt SLOW_CALLS_##arity; \
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index 7e116c449fd821e28dbe9b92d6134bde364db574..dc0db746b145077bef99e4e4274d6ec7362d8ffe 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -112,6 +112,7 @@
#define EVENT_GC_END 10 /* () */
#define EVENT_REQUEST_SEQ_GC 11 /* () */
#define EVENT_REQUEST_PAR_GC 12 /* () */
+/* 13, 14 deprecated */
#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */
#define EVENT_LOG_MSG 16 /* (message ...) */
#define EVENT_STARTUP 17 /* (num_capabilities) */
@@ -120,12 +121,40 @@
#define EVENT_GC_IDLE 20 /* () */
#define EVENT_GC_WORK 21 /* () */
#define EVENT_GC_DONE 22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */
+#define EVENT_CAPSET_DELETE 26 /* (capset) */
+#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */
+#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */
+/* the RTS identifier is in the form of "GHC-version rts_way" */
+#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings */
+#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */
+#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */
+#define EVENT_OSPROCESS_PID 32 /* (capset, pid) */
+#define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */
-#define NUM_EVENT_TAGS 23
+
+/* Range 34 - 59 is available for new events */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_EVENT_TAGS 34
#if 0 /* DEPRECATED EVENTS: */
+/* ghc changed how it handles sparks so these are no longer applicable */
#define EVENT_CREATE_SPARK 13 /* (cap, thread) */
#define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION 23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */
#endif
/*
@@ -168,6 +197,13 @@
* #define BlockedOnMsgGlobalise 18
*/
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */
+
#ifndef EVENTLOG_CONSTANTS_ONLY
typedef StgWord16 EventTypeNum;
@@ -176,6 +212,8 @@ typedef StgWord32 EventThreadID;
typedef StgWord16 EventCapNo;
typedef StgWord16 EventPayloadSize; /* variable-size events */
typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */
#endif
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index 86b7ef02b1c7d2ba672d29f4a5a8f91bda0bc2f9..c979bbc1097809c72e3ec513b440546a348fce71 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -246,7 +246,7 @@ extern RTS_FLAGS RtsFlags;
extern int prog_argc;
extern char **prog_argv;
*/
-extern int rts_argc; /* ditto */
-extern char *rts_argv[];
+extern int rts_argc; /* ditto */
+extern char **rts_argv;
#endif /* RTS_FLAGS_H */
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
index 87fa277226bfe3d0c40072b669d0dfc9376cb81c..85525f01b65afccaac3e9143c41e037be608a198 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -53,9 +53,17 @@
*
* ------------------------------------------------------------------------- */
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size. The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord. Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
typedef struct nursery_ {
bdescr * blocks;
- unsigned int n_blocks;
+ memcount n_blocks;
} nursery;
typedef struct generation_ {
@@ -67,19 +75,19 @@ typedef struct generation_ {
unsigned int cap; // capability this gen is local to
bdescr * blocks; // blocks in this gen
- unsigned int n_blocks; // number of blocks
- unsigned int n_words; // number of used words
+ memcount n_blocks; // number of blocks
+ memcount n_words; // number of used words
bdescr * large_objects; // large objects (doubly linked)
- unsigned int n_large_blocks; // no. of blocks used by large objs
- unsigned long n_new_large_words; // words of new large objects
+ memcount n_large_blocks; // no. of blocks used by large objs
+ memcount n_new_large_words; // words of new large objects
// (for allocation stats)
bdescr * prim_blocks; // blocks of primitive objects
- unsigned int n_prim_blocks; // these blocks are marked/swept,
- unsigned int n_prim_words; // not copied.
+ memcount n_prim_blocks; // these blocks are marked/swept,
+ memcount n_prim_words; // not copied.
- unsigned int max_blocks; // max blocks
+ memcount max_blocks; // max blocks
StgTSO * threads; // threads in this gen
// linked via global_link
@@ -112,11 +120,11 @@ typedef struct generation_ {
// are copied into the following two fields. After GC, these blocks
// are freed.
bdescr * old_blocks; // bdescr of first from-space block
- unsigned int n_old_blocks; // number of blocks in from-space
- unsigned int live_estimate; // for sweeping: estimate of live data
+ memcount n_old_blocks; // number of blocks in from-space
+ memcount live_estimate; // for sweeping: estimate of live data
bdescr * scavenged_large_objects; // live large objs after GC (d-link)
- unsigned int n_scavenged_large_blocks; // size (not count) of above
+ memcount n_scavenged_large_blocks; // size (not count) of above
bdescr * bitmap; // bitmap for compacting collection
diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h
index cd9866671c4d37fdf0901394437d220b4b160e41..6b1d31986bdd75c3d6d754434e9d0b2d85738b38 100644
--- a/includes/stg/MachRegs.h
+++ b/includes/stg/MachRegs.h
@@ -67,6 +67,11 @@
Caller-saves regs have to be saved around C-calls made from STG
land, so this file defines CALLER_SAVES_<reg> for each <reg> that
is designated caller-saves in that machine's C calling convention.
+
+ As it stands, the only registers that are ever marked caller saves
+ are the RX, FX, DX and USER registers; as a result, if you
+ decide to caller save a system register (e.g. SP, HP, etc), note that
+ this code path is completely untested! -- EZY
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h
index f1b04220094a146371cffdac4989c9fc9cff5d55..52fd6f1bc69b99dfc39c168e3e2d55451fb57cfe 100644
--- a/includes/stg/SMP.h
+++ b/includes/stg/SMP.h
@@ -306,6 +306,7 @@ load_load_barrier(void) {
#define store_load_barrier() /* nothing */
#define load_load_barrier() /* nothing */
+#if !IN_STG_CODE || IN_STGCRUN
INLINE_HEADER StgWord
xchg(StgPtr p, StgWord w)
{
@@ -337,6 +338,7 @@ atomic_dec(StgVolatilePtr p)
{
return --(*p);
}
+#endif
#define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p)))
diff --git a/libffi/ghc.mk b/libffi/ghc.mk
index 080c43f850d676932151e87a20bf43115980b5b9..f7caeda782e39395d121f82a9d42f75744072f51 100644
--- a/libffi/ghc.mk
+++ b/libffi/ghc.mk
@@ -34,8 +34,6 @@
#
# We use libffi's own configuration stuff.
-PLATFORM := $(shell echo $(HOSTPLATFORM) | sed 's/i[567]86/i486/g')
-
# 2007-07-05
# Passing
# as_ln_s='cp -p'
@@ -116,16 +114,16 @@ $(libffi_STAMP_CONFIGURE):
PATH=`pwd`:$$PATH; \
export PATH; \
cd build && \
- CC=$(WhatGccIsCalled) \
+ CC=$(CC_STAGE1) \
LD=$(LD) \
- AR=$(AR) \
+ AR=$(AR_STAGE1) \
NM=$(NM) \
CFLAGS="$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -w" \
LDFLAGS="$(SRC_LD_OPTS) $(CONF_GCC_LINKER_OPTS_STAGE1) -w" \
"$(SHELL)" configure \
--enable-static=yes \
--enable-shared=$(libffi_EnableShared) \
- --host=$(PLATFORM) --build=$(PLATFORM)
+ --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM)
# libffi.so needs to be built with the correct soname.
# NOTE: this builds libffi_convience.so with the incorrect
@@ -179,7 +177,7 @@ $(eval $(call all-target,libffi,$(INSTALL_HEADERS) $(INSTALL_LIBS)))
libffi/dist-install/build/HSffi.o: libffi/dist-install/build/libHSffi.a
cd libffi/dist-install/build && \
touch empty.c && \
- "$(CC)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o
+ "$(CC_STAGE1)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -c empty.c -o HSffi.o
$(eval $(call all-target,libffi,libffi/dist-install/build/HSffi.o))
@@ -227,4 +225,3 @@ $(eval $(call manual-package-config,libffi))
# binary-dist
BINDIST_EXTRAS += libffi/package.conf.in
-
diff --git a/libraries/Makefile.common b/libraries/Makefile.common
deleted file mode 100644
index 8fe1462d642b07ac59c8a2bc4fc5c53184ec311b..0000000000000000000000000000000000000000
--- a/libraries/Makefile.common
+++ /dev/null
@@ -1,118 +0,0 @@
-# This Makefile.common is used only in an nhc98 build of the libraries.
-# It is included from each package's individual Makefile.nhc98.
-# We assume the following definitions have already been made in
-# the importing Makefile.
-#
-# THISPKG = e.g. mypkg
-# SEARCH = e.g. -P../IO -P../PreludeIO -package base
-# SRCS = all .hs .gc and .c files
-#
-# EXTRA_H_FLAGS = e.g. -prelude
-# EXTRA_C_FLAGS = e.g. -I../Binary
-include ../Makefile.inc
-
-# nasty hack - replace flags for ghc, nhc98, with hbc specific ones
-ifeq "hbc" "${BUILDCOMP}"
-EXTRA_H_FLAGS := ${EXTRA_HBC_FLAGS}
-endif
-
-DIRS = $(shell ${LOCAL}pkgdirlist ${THISPKG})
-
-OBJDIR = ${BUILDDIR}/${OBJ}/libraries/${THISPKG}
-OBJDIRS = $(patsubst %, ${OBJDIR}/%, ${DIRS})
-FINALLIB = ${DST}/libHS${THISPKG}.$A
-INCDIRS = ${INCDIR}/packages/${THISPKG} \
- $(patsubst %, ${INCDIR}/packages/${THISPKG}/%, ${DIRS})
-.SUFFIXES: .hi .hs .lhs .o .gc .c .hc .p.o .p.c .z.o .z.c .hsc
-
-SRCS_HS = $(filter %.hs, ${SRCS})
-SRCS_LHS = $(filter %.lhs,${SRCS})
-SRCS_GC = $(filter %.gc, ${SRCS})
-SRCS_HSC = $(filter %.hsc,${SRCS})
-SRCS_C = $(filter %.c, ${SRCS})
-SRCS_HASK= $(SRCS_HS) $(SRCS_LHS) $(SRCS_GC) $(SRCS_HSC)
-
-OBJS_HS = $(patsubst %.hs, ${OBJDIR}/%.$O, ${SRCS_HS})
-OBJS_LHS = $(patsubst %.lhs,${OBJDIR}/%.$O, ${SRCS_LHS})
-OBJS_GC = $(patsubst %.gc, ${OBJDIR}/%.$O, ${SRCS_GC})
-OBJS_HSC = $(patsubst %.hsc,${OBJDIR}/%.$O, ${SRCS_HSC})
-OBJS_C = $(patsubst %.c, ${OBJDIR}/%.$O, ${SRCS_C})
-OBJS_HASK= ${OBJS_HS} ${OBJS_LHS} ${OBJS_GC} ${OBJS_HSC}
-OBJS = $(OBJS_HASK) $(OBJS_C)
-
-CFILES_HS = $(patsubst %.hs, %.$C, ${SRCS_HS})
-CFILES_LHS = $(patsubst %.lhs,%.$C, ${SRCS_LHS})
-CFILES_GC = $(patsubst %.gc, %.$C, ${SRCS_GC})
-CFILES_XS = $(patsubst %.gc, %_.$C, ${SRCS_GC}) \
- $(patsubst %.gc, %_.hs, ${SRCS_GC})
-CFILES_HSC = $(patsubst %.hsc,%.$C, ${SRCS_HSC})
-CFILES_GEN = ${CFILES_HS} ${CFILES_LHS} ${CFILES_GC} ${CFILES_HSC}
-
-ifeq "p" "${PROFILING}"
-HC += -p
-endif
-
-ifeq "z" "${TPROF}"
-HC += -z
-endif
-
-all: ${OBJDIR} ${OBJDIRS} ${INCDIRS} extra ${OBJS} ${FINALLIB}
-extra:
-cfiles: extracfiles ${CFILES_GEN}
-extracfiles:
-fromC: ${OBJDIR} ${OBJS_C} ${OBJDIRS}
- $(HC) -c -d $(OBJDIR) $(EXTRA_C_FLAGS) ${SEARCH} ${CFILES_GEN}
- echo $(OBJS) | xargs ar cr ${FINALLIB}
-objdir: ${OBJDIR} ${OBJDIRS} ${INCDIRS}
-${OBJDIR} ${OBJDIRS} ${INCDIRS}:
- mkdir -p $@
-${FINALLIB}: ${OBJS}
- echo $(OBJS) | xargs ar cr $@
-cleanhi:
- -rm -f $(patsubst %, %/*.hi, ${DIRS})
-cleanC: cleanExtraC
- -rm -f ${CFILES_GEN} ${CFILES_XS}
-clean: cleanhi
- -rm -f $(patsubst %, ${OBJDIR}/%/*.$O, ${DIRS})
- -rm -f $(patsubst %.gc, %_.hs, $(filter %.gc, $(SRCS)))
- -rm -f $(patsubst %.gc, %_.$C, $(filter %.gc, $(SRCS)))
-cleanExtraC:
-
-# general build rules for making objects from Haskell files
-$(OBJS_HASK): #$(OBJDIR) $(OBJDIRS) $(SRCS_HASK)
- $(LOCAL)hmake -hc=$(HC) -hidir $(INCDIR)/packages/$(THISPKG) \
- $(SEARCH) $(EXTRA_H_FLAGS) -d$(OBJDIR) \
- $(SRCS_HASK)
-${OBJS_HS}: ${OBJDIR}/%.$O : %.hs
-${OBJS_LHS}: ${OBJDIR}/%.$O : %.lhs
-${OBJS_GC}: ${OBJDIR}/%.$O : %.gc
-${OBJS_HSC}: ${OBJDIR}/%.$O : %.hsc
-
-# general build rule for making objects from C files
-${OBJS_C}: ${OBJDIR}/%.$O : cbits/%.c
- $(CC) -c -I$(INCDIR) $(ENDIAN) $(filter -I%, ${SEARCH}) \
- $(EXTRA_C_FLAGS) -o $@ $<
-
-# general build rules for making bootstrap C files from Haskell files
-$(CFILES_GEN):
- $(LOCAL)hmake -hc=$(HC) -C -hidir $(INCDIR)/packages/$(THISPKG) \
- $(SEARCH) $(EXTRA_H_FLAGS) \
- $(SRCS_HASK)
-${CFILES_HS}: %.$C : %.hs
-${CFILES_LHS}: %.$C : %.lhs
-${CFILES_GC}: %.$C : %.gc
-${CFILES_HSC}: %.$C : %.hsc
-
-# hack to get round mutual recursion between libraries
-HIFILES = $(patsubst %.hs,../${THISLIB}/%.${HISUFFIX},$(filter %.hs, ${SRCS}))
-${HIFILES}: ../${THISLIB}/%.${HISUFFIX} : %.hs
- $(HC) -c $(PART_FLAGS) -o /dev/null $<
-
-# The importing Makefile may now define extra individual dependencies
-# e.g.
-# ${OBJDIR}/Function.$O: Function.hs ${OBJDIR}/Other.$O
-#
-# and C-files dependencies likewise
-# e.g.
-# AlignBin.c: BinHandle.c
-
diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc
deleted file mode 100644
index 0b54f52bded9810d51534d0fd91eac69f19543a1..0000000000000000000000000000000000000000
--- a/libraries/Makefile.inc
+++ /dev/null
@@ -1,8 +0,0 @@
-ifeq "" "${MKDIR}"
-MKDIR:=$(shell pwd)
-#MKDIR:=$(PWD)
-else
-MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR})
-endif
-include ${MKDIR}/Makefile.inc
-
diff --git a/libraries/Makefile.local b/libraries/Makefile.local
deleted file mode 100644
index 84b90a65639cc4f296dfbe734080ef5fc96f58d7..0000000000000000000000000000000000000000
--- a/libraries/Makefile.local
+++ /dev/null
@@ -1,38 +0,0 @@
-# Local GHC-build-tree customization for Cabal makefiles. We want to build
-# libraries using flags that the user has put in build.mk/validate.mk and
-# appropriate flags for Mac OS X deployment targets.
-
-# Careful here: including boilerplate.mk breaks things, because paths.mk and
-# opts.mk overrides some of the variable settings in the Cabal Makefile, so
-# we just include config.mk and custom-settings.mk.
-include ../defineTOP.mk
-SAVE_GHC := $(GHC)
-SAVE_AR := $(AR)
-SAVE_LD := $(LD)
-include $(TOP)/mk/config.mk
-include $(TOP)/mk/custom-settings.mk
-GHC := $(SAVE_GHC)
-AR := $(SAVE_AR)
-LD := $(SAVE_LD)
-
-# We want all warnings on
-GhcLibHcOpts += -Wall
-
-# Cabal has problems with deprecated flag warnings, as it needs to pass
-# deprecated flags in pragmas in order to support older GHCs. Thus for
-# now at least we just disable them completely.
-GhcLibHcOpts += -fno-warn-deprecated-flags
-
-ifeq "$(filter-out Win32-% dph%,$(package))" ""
-# XXX We are one of the above list, i.e. we are a package that is not
-# yet warning-clean. Thus turn warnings off for now so that validate
-# goes through.
-GhcLibHcOpts += -w
-endif
-
-# Now add flags from the GHC build system to the Cabal build:
-GHC_OPTS += $(SRC_HC_OPTS)
-GHC_OPTS += $(GhcLibHcOpts)
-
-include $(TOP)/mk/bindist.mk
-
diff --git a/libraries/tarballs/time-1.2.0.3.tar.gz b/libraries/tarballs/time-1.2.0.3.tar.gz
deleted file mode 100644
index 525b01955619e519d3a1172e347bc38bd178306c..0000000000000000000000000000000000000000
Binary files a/libraries/tarballs/time-1.2.0.3.tar.gz and /dev/null differ
diff --git a/libraries/tarballs/time-1.2.0.4.tar.gz b/libraries/tarballs/time-1.2.0.4.tar.gz
new file mode 100644
index 0000000000000000000000000000000000000000..6bbbd75703a06a71c56cfe40de59759c730ba752
Binary files /dev/null and b/libraries/tarballs/time-1.2.0.4.tar.gz differ
diff --git a/mk/build.mk.sample b/mk/build.mk.sample
index a7764e2e46116408de06b8bf34d55dc39f2b4d28..a31b57618b9258499f10b31b967615de0ebc1962 100644
--- a/mk/build.mk.sample
+++ b/mk/build.mk.sample
@@ -39,7 +39,7 @@ SRC_HC_OPTS = -O -H64m
GhcStage1HcOpts = -O -fasm
GhcStage2HcOpts = -O2 -fasm
GhcHcOpts = -Rghc-timing
-GhcLibHcOpts = -O2 -XGenerics
+GhcLibHcOpts = -O2
GhcLibWays += p
ifeq "$(PlatformSupportsSharedLibs)" "YES"
@@ -136,15 +136,6 @@ endif
# -----------------------------------------------------------------------------
# Other settings that might be useful
-# profiled RTS
-#GhcRtsCcOpts = -pg -g
-
-# Optimised/profiled RTS
-#GhcRtsCcOpts = -O2 -pg
-
-#GhcRtsWithFrontPanel = YES
-#SRC_HC_OPTS += `gtk-config --libs`
-
# NoFib settings
NoFibWays =
STRIP_CMD = :
diff --git a/mk/config.mk.in b/mk/config.mk.in
index be8b57bcb701f74dd068168cc8f3e7c2d7e8e743..d4a7cbeaf0b830214ead9bc8bc9f5a186a72ee76 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -282,13 +282,8 @@ GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO)
#
# -O(2) is pretty desirable, otherwise no inlining of prelude
# things (incl "+") happens when compiling with this compiler
-#
-# -XGenerics switches on generation of support code for
-# derivable type classes. This is now off by default,
-# but we switch it on for the libraries so that we generate
-# the code in case someone importing wants it
-GhcLibHcOpts=-O2 -XGenerics
+GhcLibHcOpts=-O2
# Strip local symbols from libraries? This can make the libraries smaller,
# but makes debugging somewhat more difficult. Doesn't work with all ld's.
@@ -540,18 +535,19 @@ endif
# 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
@@ -601,10 +597,24 @@ DLLTOOL = inplace/mingw/bin/dlltool.exe
AR = @ArCmd@
AR_OPTS = @ArArgs@
-ArSupportsInput = @ArSupportsInput@
ArSupportsAtFile = @ArSupportsAtFile@
-# Yuckage: for ghc/utils/parallel -- todo: nuke this dependency!!
-BASH = /usr/local/bin/bash
+
+AR_STAGE0 = @AR_STAGE0@
+AR_STAGE1 = $(AR)
+AR_STAGE2 = $(AR)
+AR_STAGE3 = $(AR)
+AR_OPTS_STAGE0 = @AR_OPTS_STAGE0@
+AR_OPTS_STAGE1 = $(AR_OPTS)
+AR_OPTS_STAGE2 = $(AR_OPTS)
+AR_OPTS_STAGE3 = $(AR_OPTS)
+EXTRA_AR_ARGS_STAGE0 = $(EXTRA_AR_ARGS)
+EXTRA_AR_ARGS_STAGE1 = $(EXTRA_AR_ARGS)
+EXTRA_AR_ARGS_STAGE2 = $(EXTRA_AR_ARGS)
+EXTRA_AR_ARGS_STAGE3 = $(EXTRA_AR_ARGS)
+ArSupportsAtFile_STAGE0 = @ArSupportsAtFile_STAGE0@
+ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile)
+ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile)
+ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile)
CONTEXT_DIFF = @ContextDiffCmd@
CP = cp
@@ -637,7 +647,6 @@ NROFF = nroff
PERL = @PerlCmd@
PYTHON = @PythonCmd@
PIC = pic
-PREPROCESSCMD = $(CC) -E
RANLIB = @RANLIB@
SED = @SedCmd@
TR = tr
@@ -760,8 +769,6 @@ ALEX_VERSION = @AlexVersion@
#
SRC_ALEX_OPTS = -g
-HSTAGS = @HstagsCmd@
-
# Should we build haddock docs?
HADDOCK_DOCS = YES
# And HsColour the sources?
diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk
index c000f852a5289c60b0c4a2a33f133a5f74c801b6..b7f788b6b9bd4b34c494df37fc9e713048666f44 100644
--- a/mk/validate-settings.mk
+++ b/mk/validate-settings.mk
@@ -36,8 +36,7 @@ ifeq "$(ValidateHpc)" "YES"
GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/
endif
ifeq "$(ValidateSlow)" "YES"
-GhcStage2HcOpts += -XGenerics -DDEBUG
-GhcLibHcOpts += -XGenerics
+GhcStage2HcOpts += -DDEBUG
endif
######################################################################
diff --git a/rts/Capability.c b/rts/Capability.c
index 0586cf2f9b77430247214aff7977254aba911a12..2bec0de43256ee84d926de15a4469b812af627ce 100644
--- a/rts/Capability.c
+++ b/rts/Capability.c
@@ -253,6 +253,8 @@ initCapability( Capability *cap, nat i )
cap->transaction_tokens = 0;
cap->context_switch = 0;
cap->pinned_object_block = NULL;
+
+ traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
}
/* ---------------------------------------------------------------------------
@@ -266,6 +268,10 @@ initCapability( Capability *cap, nat i )
void
initCapabilities( void )
{
+ /* Declare a single capability set representing the process.
+ Each capability will get added to this capset. */
+ traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
+
#if defined(THREADED_RTS)
nat i;
@@ -676,6 +682,31 @@ prodCapability (Capability *cap, Task *task)
RELEASE_LOCK(&cap->lock);
}
+/* ----------------------------------------------------------------------------
+ * tryGrabCapability
+ *
+ * Attempt to gain control of a Capability if it is free.
+ *
+ * ------------------------------------------------------------------------- */
+
+rtsBool
+tryGrabCapability (Capability *cap, Task *task)
+{
+ if (cap->running_task != NULL) return rtsFalse;
+ ACQUIRE_LOCK(&cap->lock);
+ if (cap->running_task != NULL) {
+ RELEASE_LOCK(&cap->lock);
+ return rtsFalse;
+ }
+ task->cap = cap;
+ cap->running_task = task;
+ RELEASE_LOCK(&cap->lock);
+ return rtsTrue;
+}
+
+
+#endif /* THREADED_RTS */
+
/* ----------------------------------------------------------------------------
* shutdownCapability
*
@@ -692,8 +723,11 @@ prodCapability (Capability *cap, Task *task)
* ------------------------------------------------------------------------- */
void
-shutdownCapability (Capability *cap, Task *task, rtsBool safe)
+shutdownCapability (Capability *cap,
+ Task *task USED_IF_THREADS,
+ rtsBool safe USED_IF_THREADS)
{
+#if defined(THREADED_RTS)
nat i;
task->cap = cap;
@@ -785,33 +819,23 @@ shutdownCapability (Capability *cap, Task *task, rtsBool safe)
// threads performing foreign calls that will eventually try to
// return via resumeThread() and attempt to grab cap->lock.
// closeMutex(&cap->lock);
-}
+
+#endif /* THREADED_RTS */
-/* ----------------------------------------------------------------------------
- * tryGrabCapability
- *
- * Attempt to gain control of a Capability if it is free.
- *
- * ------------------------------------------------------------------------- */
+ traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no);
+}
-rtsBool
-tryGrabCapability (Capability *cap, Task *task)
+void
+shutdownCapabilities(Task *task, rtsBool safe)
{
- if (cap->running_task != NULL) return rtsFalse;
- ACQUIRE_LOCK(&cap->lock);
- if (cap->running_task != NULL) {
- RELEASE_LOCK(&cap->lock);
- return rtsFalse;
+ nat i;
+ for (i=0; i < n_capabilities; i++) {
+ ASSERT(task->incall->tso == NULL);
+ shutdownCapability(&capabilities[i], task, safe);
}
- task->cap = cap;
- cap->running_task = task;
- RELEASE_LOCK(&cap->lock);
- return rtsTrue;
+ traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
}
-
-#endif /* THREADED_RTS */
-
static void
freeCapability (Capability *cap)
{
diff --git a/rts/Capability.h b/rts/Capability.h
index 2944f3089988d4064cde5243ca58e3d941423dec..ac51e1e10374636464527896abe4442db144cdc9 100644
--- a/rts/Capability.h
+++ b/rts/Capability.h
@@ -248,11 +248,6 @@ void prodCapability (Capability *cap, Task *task);
//
void prodAllCapabilities (void);
-// Waits for a capability to drain of runnable threads and workers,
-// and then acquires it. Used at shutdown time.
-//
-void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
-
// Attempt to gain control of a Capability if it is free.
//
rtsBool tryGrabCapability (Capability *cap, Task *task);
@@ -278,6 +273,15 @@ extern void grabCapability (Capability **pCap);
#endif /* !THREADED_RTS */
+// Waits for a capability to drain of runnable threads and workers,
+// and then acquires it. Used at shutdown time.
+//
+void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
+
+// Shut down all capabilities.
+//
+void shutdownCapabilities(Task *task, rtsBool wait_foreign);
+
// cause all capabilities to context switch as soon as possible.
void setContextSwitches(void);
INLINE_HEADER void contextSwitchCapability(Capability *cap);
diff --git a/rts/GetEnv.h b/rts/GetEnv.h
new file mode 100644
index 0000000000000000000000000000000000000000..5e3d0cf1841891ab9bb0ed04e13ba9aa866657e4
--- /dev/null
+++ b/rts/GetEnv.h
@@ -0,0 +1,23 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * OS-independent interface to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef GETENV_H
+#define GETENV_H
+
+#include "BeginPrivate.h"
+
+/* Get the process environment vector (same style interface as argc/argv)
+ */
+void getProgEnvv (int *out_envc, char **out_envv[]);
+void freeProgEnvv (int envc, char *envv[]);
+
+/* calls to getProgEnvv must have a corresponding freeProgEnvv */
+
+#include "EndPrivate.h"
+
+#endif /* GETENV_H */
diff --git a/rts/Hash.c b/rts/Hash.c
index 09d0a06808dd83a8ddfcc98f32239cb268e3fbba..9c9b2bce423974e13e5acb3afe0caa6a2b132002 100644
--- a/rts/Hash.c
+++ b/rts/Hash.c
@@ -27,13 +27,16 @@
/* Linked list of (key, data) pairs for separate chaining */
-struct hashlist {
+typedef struct hashlist {
StgWord key;
void *data;
struct hashlist *next; /* Next cell in bucket chain (same hash value) */
-};
+} HashList;
-typedef struct hashlist HashList;
+typedef struct chunklist {
+ HashList *chunk;
+ struct chunklist *next;
+} HashListChunk;
struct hashtable {
int split; /* Next bucket to split when expanding */
@@ -43,7 +46,9 @@ struct hashtable {
int kcount; /* Number of keys */
int bcount; /* Number of buckets */
HashList **dir[HDIRSIZE]; /* Directory of segments */
- HashFunction *hash; /* hash function */
+ HashList *freeList; /* free list of HashLists */
+ HashListChunk *chunks;
+ HashFunction *hash; /* hash function */
CompareFunction *compare; /* key comparison function */
};
@@ -207,30 +212,23 @@ lookupHashTable(HashTable *table, StgWord key)
* no effort to actually return the space to the malloc arena.
* -------------------------------------------------------------------------- */
-static HashList *freeList = NULL;
-
-static struct chunkList {
- void *chunk;
- struct chunkList *next;
-} *chunks;
-
static HashList *
-allocHashList(void)
+allocHashList (HashTable *table)
{
HashList *hl, *p;
- struct chunkList *cl;
+ HashListChunk *cl;
- if ((hl = freeList) != NULL) {
- freeList = hl->next;
+ if ((hl = table->freeList) != NULL) {
+ table->freeList = hl->next;
} else {
hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList");
cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList");
- cl->chunk = hl;
- cl->next = chunks;
- chunks = cl;
+ cl->chunk = hl;
+ cl->next = table->chunks;
+ table->chunks = cl;
- freeList = hl + 1;
- for (p = freeList; p < hl + HCHUNK - 1; p++)
+ table->freeList = hl + 1;
+ for (p = table->freeList; p < hl + HCHUNK - 1; p++)
p->next = p + 1;
p->next = NULL;
}
@@ -238,10 +236,10 @@ allocHashList(void)
}
static void
-freeHashList(HashList *hl)
+freeHashList (HashTable *table, HashList *hl)
{
- hl->next = freeList;
- freeList = hl;
+ hl->next = table->freeList;
+ table->freeList = hl;
}
void
@@ -264,7 +262,7 @@ insertHashTable(HashTable *table, StgWord key, void *data)
segment = bucket / HSEGSIZE;
index = bucket % HSEGSIZE;
- hl = allocHashList();
+ hl = allocHashList(table);
hl->key = key;
hl->data = data;
@@ -292,7 +290,7 @@ removeHashTable(HashTable *table, StgWord key, void *data)
table->dir[segment][index] = hl->next;
else
prev->next = hl->next;
- freeHashList(hl);
+ freeHashList(table,hl);
table->kcount--;
return hl->data;
}
@@ -317,6 +315,7 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) )
long index;
HashList *hl;
HashList *next;
+ HashListChunk *cl, *cl_next;
/* The last bucket with something in it is table->max + table->split - 1 */
segment = (table->max + table->split - 1) / HSEGSIZE;
@@ -328,14 +327,18 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) )
next = hl->next;
if (freeDataFun != NULL)
(*freeDataFun)(hl->data);
- freeHashList(hl);
- }
+ }
index--;
}
stgFree(table->dir[segment]);
segment--;
index = HSEGSIZE - 1;
}
+ for (cl = table->chunks; cl != NULL; cl = cl_next) {
+ cl_next = cl->next;
+ stgFree(cl->chunk);
+ stgFree(cl);
+ }
stgFree(table);
}
@@ -363,6 +366,8 @@ allocHashTable_(HashFunction *hash, CompareFunction *compare)
table->mask2 = 2 * HSEGSIZE - 1;
table->kcount = 0;
table->bcount = HSEGSIZE;
+ table->freeList = NULL;
+ table->chunks = NULL;
table->hash = hash;
table->compare = compare;
@@ -385,11 +390,5 @@ allocStrHashTable(void)
void
exitHashTable(void)
{
- struct chunkList *cl;
-
- while ((cl = chunks) != NULL) {
- chunks = cl->next;
- stgFree(cl->chunk);
- stgFree(cl);
- }
+ /* nothing to do */
}
diff --git a/rts/Linker.c b/rts/Linker.c
index e33a66e88f660a997830b838a809a5ca31a7748a..b1955f6bd57c6f36c5b8f2bcdee538786f4e2e70 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -387,6 +387,8 @@ typedef struct _RtsSymbolVal {
SymI_HasProto(stg_asyncReadzh) \
SymI_HasProto(stg_asyncWritezh) \
SymI_HasProto(stg_asyncDoProczh) \
+ SymI_HasProto(getWin32ProgArgv) \
+ SymI_HasProto(setWin32ProgArgv) \
SymI_HasProto(memset) \
SymI_HasProto(inet_ntoa) \
SymI_HasProto(inet_addr) \
@@ -1187,11 +1189,11 @@ initLinker( void )
# endif /* RTLD_DEFAULT */
compileResult = regcomp(&re_invalid,
- "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header",
+ "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)",
REG_EXTENDED);
ASSERT( compileResult == 0 );
compileResult = regcomp(&re_realso,
- "GROUP *\\( *(([^ )])+)",
+ "(GROUP|INPUT) *\\( *(([^ )])+)",
REG_EXTENDED);
ASSERT( compileResult == 0 );
# endif
@@ -1362,8 +1364,8 @@ addDLL( char *dll_name )
if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) {
// success -- try to dlopen the first named file
IF_DEBUG(linker, debugBelch("match%s\n",""));
- line[match[1].rm_eo] = '\0';
- errmsg = internal_dlopen(line+match[1].rm_so);
+ line[match[2].rm_eo] = '\0';
+ errmsg = internal_dlopen(line+match[2].rm_so);
break;
}
// if control reaches here, no GROUP ( ... ) directive was found
@@ -2336,6 +2338,7 @@ unloadObj( char *path )
// stgFree(oc->image);
// #endif
stgFree(oc->fileName);
+ stgFree(oc->archiveMemberName);
stgFree(oc->symbols);
stgFree(oc->sections);
stgFree(oc);
@@ -3681,31 +3684,6 @@ PLTSize(void)
* Generic ELF functions
*/
-static char *
-findElfSection ( void* objImage, Elf_Word sh_type )
-{
- char* ehdrC = (char*)objImage;
- Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- char* ptr = NULL;
- int i;
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type
- /* Ignore the section header's string table. */
- && i != ehdr->e_shstrndx
- /* Ignore string tables named .stabstr, as they contain
- debugging info. */
- && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
- ) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
static int
ocVerifyImage_ELF ( ObjectCode* oc )
{
@@ -3713,7 +3691,6 @@ ocVerifyImage_ELF ( ObjectCode* oc )
Elf_Sym* stab;
int i, j, nent, nstrtab, nsymtabs;
char* sh_strtab;
- char* strtab;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
@@ -3795,20 +3772,64 @@ ocVerifyImage_ELF ( ObjectCode* oc )
ehdrC + shdr[i].sh_offset,
ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
- if (shdr[i].sh_type == SHT_REL) {
- IF_DEBUG(linker,debugBelch("Rel " ));
- } else if (shdr[i].sh_type == SHT_RELA) {
- IF_DEBUG(linker,debugBelch("RelA " ));
- } else {
- IF_DEBUG(linker,debugBelch(" "));
+#define SECTION_INDEX_VALID(ndx) (ndx > SHN_UNDEF && ndx < ehdr->e_shnum)
+
+ switch (shdr[i].sh_type) {
+
+ case SHT_REL:
+ case SHT_RELA:
+ IF_DEBUG(linker,debugBelch( shdr[i].sh_type == SHT_REL ? "Rel " : "RelA "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ if (shdr[i].sh_link == SHN_UNDEF)
+ errorBelch("\n%s: relocation section #%d has no symbol table\n"
+ "This object file has probably been fully striped. "
+ "Such files cannot be linked.\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ else
+ errorBelch("\n%s: relocation section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_SYMTAB) {
+ errorBelch("\n%s: relocation section #%d does not link to a symbol table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ return 0;
+ }
+ if (!SECTION_INDEX_VALID(shdr[i].sh_info)) {
+ errorBelch("\n%s: relocation section #%d has an invalid info field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_info);
+ return 0;
+ }
+
+ break;
+ case SHT_SYMTAB:
+ IF_DEBUG(linker,debugBelch("Sym "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ errorBelch("\n%s: symbol table section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_STRTAB) {
+ errorBelch("\n%s: symbol table section #%d does not link to a string table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+
+ return 0;
+ }
+ break;
+ case SHT_STRTAB: IF_DEBUG(linker,debugBelch("Str ")); break;
+ default: IF_DEBUG(linker,debugBelch(" ")); break;
}
if (sh_strtab) {
IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
}
}
- IF_DEBUG(linker,debugBelch( "\nString tables" ));
- strtab = NULL;
+ IF_DEBUG(linker,debugBelch( "\nString tables\n" ));
nstrtab = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type == SHT_STRTAB
@@ -3818,18 +3839,16 @@ ocVerifyImage_ELF ( ObjectCode* oc )
debugging info. */
&& 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
) {
- IF_DEBUG(linker,debugBelch(" section %d is a normal string table", i ));
- strtab = ehdrC + shdr[i].sh_offset;
+ IF_DEBUG(linker,debugBelch(" section %d is a normal string table\n", i ));
nstrtab++;
}
}
- if (nstrtab != 1) {
- errorBelch("%s: no string tables, or too many", oc->fileName);
- return 0;
+ if (nstrtab == 0) {
+ IF_DEBUG(linker,debugBelch(" no normal string tables (potentially, but not necessarily a problem)\n"));
}
nsymtabs = 0;
- IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
+ IF_DEBUG(linker,debugBelch( "Symbol tables\n" ));
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type != SHT_SYMTAB) continue;
IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
@@ -3871,13 +3890,17 @@ ocVerifyImage_ELF ( ObjectCode* oc )
}
IF_DEBUG(linker,debugBelch(" " ));
- IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
+ IF_DEBUG(linker,debugBelch("name=%s\n",
+ ehdrC + shdr[shdr[i].sh_link].sh_offset
+ + stab[j].st_name ));
}
}
if (nsymtabs == 0) {
- errorBelch("%s: didn't find any symbol tables", oc->fileName);
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker,debugBelch(" no symbol tables (potentially, but not necessarily a problem)\n"));
}
return 1;
@@ -3924,16 +3947,11 @@ ocGetNames_ELF ( ObjectCode* oc )
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
+ char* strtab;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
ASSERT(symhash != NULL);
- if (!strtab) {
- errorBelch("%s: no strtab", oc->fileName);
- return 0;
- }
-
k = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
/* Figure out what kind of section it is. Logic derived from
@@ -3966,12 +3984,16 @@ ocGetNames_ELF ( ObjectCode* oc )
/* copy stuff into this module's object symbol table */
stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
+ strtab = ehdrC + shdr[shdr[i].sh_link].sh_offset;
nent = shdr[i].sh_size / sizeof(Elf_Sym);
oc->n_symbols = nent;
oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
"ocGetNames_ELF(oc->symbols)");
+ //TODO: we ignore local symbols anyway right? So we can use the
+ // shdr[i].sh_info to get the index of the first non-local symbol
+ // ie we should use j = shdr[i].sh_info
for (j = 0; j < nent; j++) {
char isLocal = FALSE; /* avoids uninit-var warning */
@@ -4069,21 +4091,24 @@ ocGetNames_ELF ( ObjectCode* oc )
relocations appear to be of this form. */
static int
do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol;
Elf_Word* targ;
Elf_Rel* rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx ));
+ IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d and strtab %d\n",
+ target_shndx, symtab_shndx, strtab_shndx ));
/* Skip sections that we're not interested in. */
{
@@ -4169,18 +4194,21 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
sparc-solaris relocations appear to be of this form. */
static int
do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol = NULL;
Elf_Addr targ;
Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
target_shndx, symtab_shndx ));
@@ -4449,35 +4477,20 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
static int
ocResolve_ELF ( ObjectCode* oc )
{
- char *strtab;
int shnum, ok;
- Elf_Sym* stab = NULL;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*) ehdrC;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
- /* first find "the" symbol table */
- stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- /* also go find the string table */
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (stab == NULL || strtab == NULL) {
- errorBelch("%s: can't find string or symbol table", oc->fileName);
- return 0;
- }
-
/* Process the relocation sections. */
for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
if (shdr[shnum].sh_type == SHT_REL) {
- ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
else
if (shdr[shnum].sh_type == SHT_RELA) {
- ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
}
@@ -4510,8 +4523,12 @@ static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
if( i == ehdr->e_shnum )
{
- errorBelch( "This ELF file contains no symtab" );
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker, debugBelch( "The ELF file %s contains no symtab\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName ));
+ return 1;
}
if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 9529dd800fb8cb7bb6682d00d463e2bf41e8715a..c7b8e6b47af6eaac473feef92c0f5fb452904bbf 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -211,6 +211,7 @@ stg_unsafeThawArrayzh
}
}
+
/* -----------------------------------------------------------------------------
MutVar primitives
-------------------------------------------------------------------------- */
diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index be2cf152bf38feee7a8b39ae2b7a39ac3722339f..705d2c2a9bb256912a488e688a0c1509f66123da 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -18,6 +18,7 @@
#include "LdvProfile.h"
#include "Arena.h"
#include "Printer.h"
+#include "sm/GCThread.h"
#include <string.h>
@@ -812,7 +813,7 @@ dumpCensus( Census *census )
rs->id = -(rs->id);
// report in the unit of bytes: * sizeof(StgWord)
- printRetainerSetShort(hp_file, rs);
+ printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength);
break;
}
default:
@@ -1058,8 +1059,9 @@ heapCensusChain( Census *census, bdescr *bd )
void
heapCensus( void )
{
- nat g;
+ nat g, n;
Census *census;
+ gen_workspace *ws;
census = &censuses[era];
census->time = mut_user_time();
@@ -1081,6 +1083,13 @@ heapCensus( void )
// Are we interested in large objects? might be
// confusing to include the stack in a heap profile.
heapCensusChain( census, all_generations[g].large_objects );
+
+ for (n = 0; n < n_capabilities; n++) {
+ ws = &gc_threads[n]->gens[g];
+ heapCensusChain(census, ws->todo_bd);
+ heapCensusChain(census, ws->part_list);
+ heapCensusChain(census, ws->scavd_list);
+ }
}
// dump out the census info
diff --git a/rts/RetainerSet.c b/rts/RetainerSet.c
index 5e9b37c04ce81d0a1aaacbaa7f4078b088b4ac5b..d93ae4bd16609399dec430a7cb4d1c0589fddb98 100644
--- a/rts/RetainerSet.c
+++ b/rts/RetainerSet.c
@@ -265,35 +265,34 @@ printRetainer(FILE *f, retainer cc)
#if defined(RETAINER_SCHEME_INFO)
// Retainer scheme 1: retainer = info table
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
- strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
- strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
// size = strlen(tmp);
}
}
@@ -302,10 +301,9 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
#elif defined(RETAINER_SCHEME_CC)
// Retainer scheme 3: retainer = cost centre
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
@@ -313,35 +311,34 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
#elif defined(RETAINER_SCHEME_CCS)
// Retainer scheme 2: retainer = cost centre stack
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
- int size;
+ char tmp[max_length + 1];
+ nat size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
- strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
- strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
// size = strlen(tmp);
}
}
@@ -350,46 +347,44 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
#elif defined(RETAINER_SCHEME_CC)
// Retainer scheme 3: retainer = cost centre
static void
-printRetainerSetShort(FILE *f, retainerSet *rs)
+printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
strncpy(tmp + size, rs->element[j]->label,
- MAX_RETAINER_SET_SPACE - size);
+ max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
strncpy(tmp + size, rs->element[j]->label,
- MAX_RETAINER_SET_SPACE - size);
+ max_length - size);
// size = strlen(tmp);
}
}
fprintf(f, tmp);
/*
- #define MAX_RETAINER_SET_SPACE 24
#define DOT_NUMBER 3
- // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0')
- // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for
+ // 1. 32 > max_length + 1 (1 for '\0')
+ // 2. (max_length - DOT_NUMBER ) characters should be enough for
// printing one natural number (plus '(' and ')').
char tmp[32];
int size, ts;
@@ -400,12 +395,12 @@ printRetainerSetShort(FILE *f, retainerSet *rs)
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER);
+ ASSERT(size < max_length - DOT_NUMBER);
for (j = 0; j < rs->num; j++) {
ts = strlen(rs->element[j]->label);
if (j < rs->num - 1) {
- if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ if (size + ts + 1 > max_length - DOT_NUMBER) {
sprintf(tmp + size, "...");
break;
}
@@ -413,7 +408,7 @@ printRetainerSetShort(FILE *f, retainerSet *rs)
size += ts + 1;
}
else {
- if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ if (size + ts > max_length - DOT_NUMBER) {
sprintf(tmp + size, "...");
break;
}
diff --git a/rts/RetainerSet.h b/rts/RetainerSet.h
index 74152b96950faef0c1665c1a8eb673af69261390..5004527d21732b3d6870452715419dbf58657f1b 100644
--- a/rts/RetainerSet.h
+++ b/rts/RetainerSet.h
@@ -165,7 +165,7 @@ void traverseAllRetainerSet(void (*f)(RetainerSet *));
#ifdef SECOND_APPROACH
// Prints a single retainer set.
-void printRetainerSetShort(FILE *, RetainerSet *);
+void printRetainerSetShort(FILE *, RetainerSet *, nat);
#endif
// Print the statistics on all the retainer sets.
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 38da0c8d836ff4bc4156c3e6cead6c4d17230376..656ae28a9d117ea2c18def1a2f79f15013086a52 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -33,7 +33,15 @@ int full_prog_argc = 0; /* an "int" so as to match normal "argc" */
char **full_prog_argv = NULL;
char *prog_name = NULL; /* 'basename' of prog_argv[0] */
int rts_argc = 0; /* ditto */
-char *rts_argv[MAX_RTS_ARGS];
+char **rts_argv = NULL;
+#if defined(mingw32_HOST_OS)
+// On Windows, we want to use GetCommandLineW rather than argc/argv,
+// but we need to mutate the command line arguments for withProgName and
+// friends. The System.Environment module achieves that using this bit of
+// shared state:
+int win32_prog_argc = 0;
+wchar_t **win32_prog_argv = NULL;
+#endif
/*
* constants, used later
@@ -65,6 +73,10 @@ static void read_trace_flags(char *arg);
static void errorUsage (void) GNU_ATTRIBUTE(__noreturn__);
+static char * copyArg (char *arg);
+static char ** copyArgv (int argc, char *argv[]);
+static void freeArgv (int argc, char *argv[]);
+
/* -----------------------------------------------------------------------------
* Command-line option parsing routines.
* ---------------------------------------------------------------------------*/
@@ -382,15 +394,11 @@ static void splitRtsFlags(char *s)
if (c1 == c2) { break; }
- 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;
- } else {
- barf("too many RTS arguments (max %d)", 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;
+
c1 = c2;
} while (*c1 != '\0');
}
@@ -402,13 +410,13 @@ static void splitRtsFlags(char *s)
- 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_argv[] (global) contains a copy of 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_argv[] (global) contains a copy of 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]
+ - prog_name (global) contains the basename of prog_argv[0]
-------------------------------------------------------------------------- */
@@ -425,6 +433,8 @@ void setupRtsFlags (int *argc, char *argv[])
*argc = 1;
rts_argc = 0;
+ rts_argv = stgCallocBytes(total_arg + 1, sizeof (char *), "setupRtsFlags");
+
rts_argc0 = rts_argc;
// process arguments from the ghc_rts_opts global variable first.
@@ -476,14 +486,11 @@ void setupRtsFlags (int *argc, char *argv[])
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_argv[rts_argc++] = copyArg(argv[arg]);
}
- else if (mode == PGM) {
- argv[(*argc)++] = argv[arg];
- }
- else {
- barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
+ else {
+ argv[(*argc)++] = argv[arg];
}
}
// process remaining program arguments
@@ -1466,6 +1473,41 @@ bad_option(const char *s)
stg_exit(EXIT_FAILURE);
}
+/* ----------------------------------------------------------------------------
+ Copying and freeing argc/argv
+ ------------------------------------------------------------------------- */
+
+static char * copyArg(char *arg)
+{
+ char *new_arg = stgMallocBytes(strlen(arg) + 1, "copyArg");
+ strcpy(new_arg, arg);
+ return new_arg;
+}
+
+static char ** copyArgv(int argc, char *argv[])
+{
+ int i;
+ char **new_argv;
+
+ new_argv = stgCallocBytes(argc + 1, sizeof (char *), "copyArgv 1");
+ for (i = 0; i < argc; i++) {
+ new_argv[i] = copyArg(argv[i]);
+ }
+ new_argv[argc] = NULL;
+ return new_argv;
+}
+
+static void freeArgv(int argc, char *argv[])
+{
+ int i;
+ if (argv != NULL) {
+ for (i = 0; i < argc; i++) {
+ stgFree(argv[i]);
+ }
+ stgFree(argv);
+ }
+}
+
/* -----------------------------------------------------------------------------
Getting/Setting the program's arguments.
@@ -1507,10 +1549,29 @@ void
setProgArgv(int argc, char *argv[])
{
prog_argc = argc;
- prog_argv = argv;
+ prog_argv = copyArgv(argc,argv);
setProgName(prog_argv);
}
+static void
+freeProgArgv(void)
+{
+ freeArgv(prog_argc,prog_argv);
+ prog_argc = 0;
+ prog_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ The full argv - a copy of the original program's argc/argv
+ ------------------------------------------------------------------------- */
+
+void
+setFullProgArgv(int argc, char *argv[])
+{
+ full_prog_argc = argc;
+ full_prog_argv = copyArgv(argc,argv);
+}
+
/* These functions record and recall the full arguments, including the
+RTS ... -RTS options. The reason for adding them was so that the
ghc-inplace program can pass /all/ the arguments on to the real ghc. */
@@ -1522,32 +1583,91 @@ getFullProgArgv(int *argc, char **argv[])
}
void
-setFullProgArgv(int argc, char *argv[])
+freeFullProgArgv (void)
{
- int i;
- full_prog_argc = argc;
- full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *),
- "setFullProgArgv 1");
- for (i = 0; i < argc; i++) {
- full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1,
- "setFullProgArgv 2");
- strcpy(full_prog_argv[i], argv[i]);
- }
- full_prog_argv[argc] = NULL;
+ freeArgv(full_prog_argc, full_prog_argv);
+ full_prog_argc = 0;
+ full_prog_argv = NULL;
}
+/* ----------------------------------------------------------------------------
+ The Win32 argv
+ ------------------------------------------------------------------------- */
+
+#if defined(mingw32_HOST_OS)
+void freeWin32ProgArgv (void);
+
void
-freeFullProgArgv (void)
+freeWin32ProgArgv (void)
{
+ freeArgv(win32_prog_argc, win32_prog_argv);
+
int i;
- if (full_prog_argv != NULL) {
- for (i = 0; i < full_prog_argc; i++) {
- stgFree(full_prog_argv[i]);
+ if (win32_prog_argv != NULL) {
+ for (i = 0; i < win32_prog_argc; i++) {
+ stgFree(win32_prog_argv[i]);
}
- stgFree(full_prog_argv);
+ stgFree(win32_prog_argv);
}
- full_prog_argc = 0;
- full_prog_argv = NULL;
+ win32_prog_argc = 0;
+ win32_prog_argv = NULL;
+}
+
+void
+getWin32ProgArgv(int *argc, wchar_t **argv[])
+{
+ *argc = win32_prog_argc;
+ *argv = win32_prog_argv;
+}
+
+void
+setWin32ProgArgv(int argc, wchar_t *argv[])
+{
+ int i;
+
+ freeWin32ProgArgv();
+
+ win32_prog_argc = argc;
+ if (argv == NULL) {
+ win32_prog_argv = NULL;
+ return;
+ }
+
+ win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *),
+ "setWin32ProgArgv 1");
+ for (i = 0; i < argc; i++) {
+ win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t),
+ "setWin32ProgArgv 2");
+ wcscpy(win32_prog_argv[i], argv[i]);
+ }
+ win32_prog_argv[argc] = NULL;
+}
+#endif
+
+/* ----------------------------------------------------------------------------
+ The RTS argv
+ ------------------------------------------------------------------------- */
+
+static void
+freeRtsArgv(void)
+{
+ freeArgv(rts_argc,rts_argv);
+ rts_argc = 0;
+ rts_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ All argvs
+ ------------------------------------------------------------------------- */
+
+void freeRtsArgs(void)
+{
+#if defined(mingw32_HOST_OS)
+ freeWin32ProgArgv();
+#endif
+ freeFullProgArgv();
+ freeProgArgv();
+ freeRtsArgv();
}
diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h
index 3ebfef64477b6e1a64e1937bc668d81740adaf92..a6bfe0a924b6d034592121df4d67f3c3d7488589 100644
--- a/rts/RtsFlags.h
+++ b/rts/RtsFlags.h
@@ -17,6 +17,7 @@
void initRtsFlagsDefaults (void);
void setupRtsFlags (int *argc, char *argv[]);
void setProgName (char *argv[]);
+void freeRtsArgs (void);
#include "EndPrivate.h"
diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d
index dbc5111e46edb36023da2bed3002cb29a27bd0b0..bd32fca385a366498c0def0b3866406e8f24bc2e 100644
--- a/rts/RtsProbes.d
+++ b/rts/RtsProbes.d
@@ -23,6 +23,8 @@
* typedef uint16_t EventCapNo;
* typedef uint16_t EventPayloadSize; // variable-size events
* typedef uint16_t EventThreadStatus;
+ * typedef uint32_t EventCapsetID;
+ * typedef uint16_t EventCapsetType; // types for EVENT_CAPSET_CREATE
*/
/* -----------------------------------------------------------------------------
@@ -60,5 +62,9 @@ provider HaskellEvent {
probe gc__idle (EventCapNo);
probe gc__work (EventCapNo);
probe gc__done (EventCapNo);
+ probe capset__create(EventCapsetID, EventCapsetType);
+ probe capset__delete(EventCapsetID);
+ probe capset__assign__cap(EventCapsetID, EventCapNo);
+ probe capset__remove__cap(EventCapsetID, EventCapNo);
};
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 23c3d114e270cd53b46d64e048f4864f5490d95d..c942a55e8865c43b16b6ca32e8da7cc1e6f208e1 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -141,15 +141,18 @@ hs_init(int *argc, char **argv[])
#ifdef TRACING
initTracing();
#endif
- /* Dtrace events are always enabled
+ /* Trace the startup event
*/
- dtraceEventStartup();
+ traceEventStartup();
/* initialise scheduler data structures (needs to be done before
* initStorage()).
*/
initScheduler();
+ /* Trace some basic information about the process */
+ traceOSProcessInfo();
+
/* initialize the storage manager */
initStorage();
@@ -300,9 +303,6 @@ hs_exit_(rtsBool wait_foreign)
checkFPUStack();
#endif
- // Free the full argv storage
- freeFullProgArgv();
-
#if defined(THREADED_RTS)
ioManagerDie();
#endif
@@ -405,6 +405,8 @@ hs_exit_(rtsBool wait_foreign)
// heap memory (e.g. by being passed a ByteArray#).
freeStorage(wait_foreign);
+ // Free the various argvs
+ freeRtsArgs();
}
// The real hs_exit():
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 156b82954cce31385d785ff1a8aae1e938c89d43..92c1d19a85757401cdec547b58dbfa580e7f7ea4 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1485,6 +1485,12 @@ delete_threads_and_gc:
recent_activity = ACTIVITY_YES;
}
+ if (heap_census) {
+ debugTrace(DEBUG_sched, "performing heap census");
+ heapCensus();
+ performHeapProfile = rtsFalse;
+ }
+
#if defined(THREADED_RTS)
if (gc_type == GC_PAR)
{
@@ -1492,12 +1498,6 @@ delete_threads_and_gc:
}
#endif
- if (heap_census) {
- debugTrace(DEBUG_sched, "performing heap census");
- heapCensus();
- performHeapProfile = rtsFalse;
- }
-
if (heap_overflow && sched_state < SCHED_INTERRUPTING) {
// GC set the heap_overflow flag, so we should proceed with
// an orderly shutdown now. Ultimately we want the main
@@ -2075,16 +2075,7 @@ exitScheduler (rtsBool wait_foreign USED_IF_THREADS)
}
sched_state = SCHED_SHUTTING_DOWN;
-#if defined(THREADED_RTS)
- {
- nat i;
-
- for (i = 0; i < n_capabilities; i++) {
- ASSERT(task->incall->tso == NULL);
- shutdownCapability(&capabilities[i], task, wait_foreign);
- }
- }
-#endif
+ shutdownCapabilities(task, wait_foreign);
boundTaskExiting(task);
}
diff --git a/rts/Stats.c b/rts/Stats.c
index bfb82c4d186b8461d0cdb489ded640517eddedff..6e1eaa4a4390d654c59407770cd6c0a32a612a8d 100644
--- a/rts/Stats.c
+++ b/rts/Stats.c
@@ -580,8 +580,46 @@ stat_exit(int alloc)
}
}
- if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) {
- showStgWord64(GC_tot_alloc*sizeof(W_),
+ gc_cpu = gc_local_cpu + gc_global_cpu;
+ gc_elapsed = gc_local_elapsed + gc_global_elapsed;
+
+ 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;
+
+ if (RtsFlags.ParFlags.nNodes == 1)
+ {
+ // In single-threaded mode, we can separate out the
+ // local GC time from the MUT time, and report the
+ // total GC time separately.
+
+ mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed;
+
+ mut_cpu = start_exit_cpu - end_init_cpu
+ - gc_local_cpu - gc_global_cpu
+ - PROF_VAL(RP_tot_time + HC_tot_time);
+ }
+ else
+ {
+ // In multi-threaded mode, we have to include the
+ // local GC time in the MUT time, because each thread
+ // has its own independent interleaving of MUT and
+ // local GC.
+
+ mut_elapsed = start_exit_elapsed - end_init_elapsed
+ - gc_global_elapsed;
+
+ mut_cpu = start_exit_cpu - end_init_cpu
+ - gc_global_cpu
+ - PROF_VAL(RP_tot_time + HC_tot_time);
+ }
+
+ if (mut_cpu < 0) { mut_cpu = 0; }
+
+ if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) {
+ showStgWord64(GC_tot_alloc*sizeof(W_),
temp, rtsTrue/*commas*/);
statsPrintf("%16s bytes allocated in the heap\n", temp);
@@ -653,7 +691,7 @@ stat_exit(int alloc)
statsPrintf(" MUT time (elapsed) GC time (elapsed)\n");
for (i = 0, task = all_tasks;
task != NULL;
- i++, task = task->all_link) {
+1 i++, task = task->all_link) {
statsPrintf(" Task %2d %-8s : %6.2fs (%6.2fs) %6.2fs (%6.2fs)\n",
i,
(task->worker) ? "(worker)" : "(bound)",
@@ -686,35 +724,13 @@ stat_exit(int alloc)
}
#endif
- gc_elapsed = gc_local_elapsed + gc_global_elapsed;
-
- 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;
-
- gc_cpu = gc_local_cpu + gc_global_cpu;
-
- statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n",
+ statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n",
TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed));
#ifdef THREADED_RTS
if (RtsFlags.ParFlags.nNodes == 1)
#endif
{
- // In single-threaded mode, we can separate out the
- // local GC time from the MUT time, and report the
- // total GC time separately.
-
- mut_elapsed = start_exit_elapsed - end_init_elapsed
- - gc_elapsed;
-
- mut_cpu = start_exit_cpu - end_init_cpu
- - gc_local_cpu - gc_global_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",
@@ -723,19 +739,6 @@ stat_exit(int alloc)
#ifdef THREADED_RTS
else
{
- // In multi-threaded mode, we have to include the
- // local GC time in the MUT time, because each thread
- // has its own independent interleaving of MUT and
- // local GC.
-
- mut_elapsed = start_exit_elapsed - end_init_elapsed
- - gc_global_elapsed;
-
- mut_cpu = start_exit_cpu - end_init_cpu
- - gc_global_cpu
- - PROF_VAL(RP_tot_time + HC_tot_time);
- if (mut_cpu < 0) { mut_cpu = 0; }
-
statsPrintf(" MUT+GC0 time %6.2fs (%6.2fs elapsed) (%.2fs MUT + %.2fs GC0)\n",
TICK_TO_DBL(mut_cpu),
TICK_TO_DBL(mut_elapsed),
@@ -844,12 +847,18 @@ stat_exit(int alloc)
statsClose();
}
- if (GC_coll_cpu)
+ if (GC_coll_cpu) {
stgFree(GC_coll_cpu);
- GC_coll_cpu = NULL;
- if (GC_coll_elapsed)
+ GC_coll_cpu = NULL;
+ }
+ if (GC_coll_elapsed) {
stgFree(GC_coll_elapsed);
- GC_coll_elapsed = NULL;
+ GC_coll_elapsed = NULL;
+ }
+ if (GC_coll_max_pause) {
+ stgFree(GC_coll_max_pause);
+ GC_coll_max_pause = NULL;
+ }
}
/* -----------------------------------------------------------------------------
diff --git a/rts/Trace.c b/rts/Trace.c
index 96997ed52042bbd4adac112807e943792bb69b56..cbb5334ea780268a9978581e368249e46a1bb303 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -15,11 +15,16 @@
#ifdef TRACING
#include "GetTime.h"
+#include "GetEnv.h"
#include "Stats.h"
#include "eventlog/EventLog.h"
#include "Threads.h"
#include "Printer.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
#ifdef DEBUG
// debugging flags, set with +RTS -D<something>
int DEBUG_sched;
@@ -252,6 +257,83 @@ void traceSchedEvent_ (Capability *cap, EventTypeNum tag,
}
}
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other)
+{
+#ifdef DEBUG
+ if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+ ACQUIRE_LOCK(&trace_utx);
+
+ tracePreface();
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ debugBelch("created capset %d of type %d\n", capset, other);
+ break;
+ case EVENT_CAPSET_DELETE: // (capset)
+ debugBelch("deleted capset %d\n", capset);
+ break;
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ debugBelch("assigned cap %d to capset %d\n", other, capset);
+ break;
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ debugBelch("removed cap %d from capset %d\n", other, capset);
+ break;
+ }
+ RELEASE_LOCK(&trace_utx);
+ } else
+#endif
+ {
+ if (eventlog_enabled) {
+ postCapsetModifyEvent(tag, capset, other);
+ }
+ }
+}
+
+void traceOSProcessInfo_(void) {
+ if (eventlog_enabled) {
+ postCapsetModifyEvent(EVENT_OSPROCESS_PID,
+ CAPSET_OSPROCESS_DEFAULT,
+ getpid());
+
+#if !defined(cygwin32_HOST_OS) && !defined (mingw32_HOST_OS)
+/* Windows has no strong concept of process heirarchy, so no getppid().
+ * In any case, this trace event is mainly useful for tracing programs
+ * that use 'forkProcess' which Windows doesn't support anyway.
+ */
+ postCapsetModifyEvent(EVENT_OSPROCESS_PPID,
+ CAPSET_OSPROCESS_DEFAULT,
+ getppid());
+#endif
+ {
+ char buf[256];
+ snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
+ postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
+ CAPSET_OSPROCESS_DEFAULT,
+ buf);
+ }
+ {
+ int argc = 0; char **argv;
+ getFullProgArgv(&argc, &argv);
+ if (argc != 0) {
+ postCapsetVecEvent(EVENT_PROGRAM_ARGS,
+ CAPSET_OSPROCESS_DEFAULT,
+ argc, argv);
+ }
+ }
+ {
+ int envc = 0; char **envv;
+ getProgEnvv(&envc, &envv);
+ if (envc != 0) {
+ postCapsetVecEvent(EVENT_PROGRAM_ENV,
+ CAPSET_OSPROCESS_DEFAULT,
+ envc, envv);
+ }
+ freeProgEnvv(envc, envv);
+ }
+ }
+}
+
void traceEvent_ (Capability *cap, EventTypeNum tag)
{
#ifdef DEBUG
@@ -360,6 +442,12 @@ void traceThreadStatus_ (StgTSO *tso USED_IF_DEBUG)
}
}
+void traceEventStartup_(int nocaps)
+{
+ if (eventlog_enabled) {
+ postEventStartup(nocaps);
+ }
+}
#ifdef DEBUG
void traceBegin (const char *str, ...)
diff --git a/rts/Trace.h b/rts/Trace.h
index 620915665bc3e80a4cac861f7709cf311bf92af9..1544971077c5f86545cfcf8a94b51d01e24f025e 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -31,6 +31,13 @@ void resetTracing (void);
#endif /* TRACING */
+typedef StgWord32 CapsetID;
+typedef StgWord16 CapsetType;
+enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
+ CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
+ CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
+#define CAPSET_OSPROCESS_DEFAULT 0
+
// -----------------------------------------------------------------------------
// Message classes
// -----------------------------------------------------------------------------
@@ -160,6 +167,23 @@ void traceUserMsg(Capability *cap, char *msg);
void traceThreadStatus_ (StgTSO *tso);
+void traceEventStartup_ (int n_caps);
+
+/*
+ * Events for describing capability sets in the eventlog
+ *
+ * Note: unlike other events, these are not conditional on TRACE_sched or
+ * similar because they are not "real" events themselves but provide
+ * information and context for other "real" events. Other events depend on
+ * the capset info events so for simplicity, rather than working out if
+ * they're necessary we always emit them. They should be very low volume.
+ */
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other);
+
+void traceOSProcessInfo_ (void);
+
#else /* !TRACING */
#define traceSchedEvent(cap, tag, tso, other) /* nothing */
@@ -170,6 +194,9 @@ void traceThreadStatus_ (StgTSO *tso);
#define debugTrace(class, str, ...) /* nothing */
#define debugTraceCap(class, cap, str, ...) /* nothing */
#define traceThreadStatus(class, tso) /* nothing */
+#define traceEventStartup_(n_caps) /* nothing */
+#define traceCapsetModify_(tag, capset, other) /* nothing */
+#define traceOSProcessInfo_() /* nothing */
#endif /* TRACING */
@@ -226,6 +253,14 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
HASKELLEVENT_GC_WORK(cap)
#define dtraceGcDone(cap) \
HASKELLEVENT_GC_DONE(cap)
+#define dtraceCapsetCreate(capset, capset_type) \
+ HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
+#define dtraceCapsetDelete(capset) \
+ HASKELLEVENT_CAPSET_DELETE(capset)
+#define dtraceCapsetAssignCap(capset, capno) \
+ HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
+#define dtraceCapsetRemoveCap(capset, capno) \
+ HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
#else /* !defined(DTRACE) */
@@ -248,6 +283,10 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
#define dtraceGcIdle(cap) /* nothing */
#define dtraceGcWork(cap) /* nothing */
#define dtraceGcDone(cap) /* nothing */
+#define dtraceCapsetCreate(capset, capset_type) /* nothing */
+#define dtraceCapsetDelete(capset) /* nothing */
+#define dtraceCapsetAssignCap(capset, capno) /* nothing */
+#define dtraceCapsetRemoveCap(capset, capno) /* nothing */
#endif
@@ -374,17 +413,18 @@ INLINE_HEADER void traceEventCreateSparkThread(Capability *cap STG_UNUSED,
dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid);
}
-// This applies only to dtrace as EVENT_STARTUP in the logging framework is
-// handled specially in 'EventLog.c'.
-//
-INLINE_HEADER void dtraceEventStartup(void)
+INLINE_HEADER void traceEventStartup(void)
{
+ int n_caps;
#ifdef THREADED_RTS
// XXX n_capabilities hasn't been initislised yet
- dtraceStartup(RtsFlags.ParFlags.nNodes);
+ n_caps = RtsFlags.ParFlags.nNodes;
#else
- dtraceStartup(1);
+ n_caps = 1;
#endif
+
+ traceEventStartup_(n_caps);
+ dtraceStartup(n_caps);
}
INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED)
@@ -405,6 +445,40 @@ INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED)
dtraceGcDone((EventCapNo)cap->no);
}
+INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED,
+ CapsetType capset_type STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type);
+ dtraceCapsetCreate(capset, capset_type);
+}
+
+INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0);
+ dtraceCapsetDelete(capset);
+}
+
+INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno);
+ dtraceCapsetAssignCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno);
+ dtraceCapsetRemoveCap(capset, capno);
+}
+
+INLINE_HEADER void traceOSProcessInfo(void)
+{
+ traceOSProcessInfo_();
+ /* Note: no DTrace equivalent because all this OS process info
+ * is available to DTrace directly */
+}
+
#include "EndPrivate.h"
#endif /* TRACE_H */
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index a77c257e1b719a05c63e278f90917c773ecbb883..abfb4eb4d99c15a956f38db69a10ea42000ad9e5 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -75,7 +75,16 @@ char *EventDesc[] = {
[EVENT_GC_IDLE] = "GC idle",
[EVENT_GC_WORK] = "GC working",
[EVENT_GC_DONE] = "GC done",
- [EVENT_BLOCK_MARKER] = "Block marker"
+ [EVENT_BLOCK_MARKER] = "Block marker",
+ [EVENT_CAPSET_CREATE] = "Create capability set",
+ [EVENT_CAPSET_DELETE] = "Delete capability set",
+ [EVENT_CAPSET_ASSIGN_CAP] = "Add capability to capability set",
+ [EVENT_CAPSET_REMOVE_CAP] = "Remove capability from capability set",
+ [EVENT_RTS_IDENTIFIER] = "RTS name and version",
+ [EVENT_PROGRAM_ARGS] = "Program arguments",
+ [EVENT_PROGRAM_ENV] = "Program environment variables",
+ [EVENT_OSPROCESS_PID] = "Process ID",
+ [EVENT_OSPROCESS_PPID] = "Parent process ID"
};
// Event type.
@@ -146,6 +155,12 @@ static inline void postThreadID(EventsBuf *eb, EventThreadID id)
static inline void postCapNo(EventsBuf *eb, EventCapNo no)
{ postWord16(eb,no); }
+static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
+{ postWord32(eb,id); }
+
+static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
+{ postWord16(eb,type); }
+
static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
{ postWord16(eb,size); }
@@ -259,6 +274,27 @@ initEventLogging(void)
eventTypes[t].size = sizeof(EventCapNo);
break;
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapsetType);
+ break;
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ eventTypes[t].size = sizeof(EventCapsetID);
+ break;
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, cap)
+ case EVENT_CAPSET_REMOVE_CAP:
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapNo);
+ break;
+
+ case EVENT_OSPROCESS_PID: // (cap, pid)
+ case EVENT_OSPROCESS_PPID:
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(StgWord32);
+ break;
+
case EVENT_SHUTDOWN: // (cap)
case EVENT_REQUEST_SEQ_GC: // (cap)
case EVENT_REQUEST_PAR_GC: // (cap)
@@ -272,6 +308,9 @@ initEventLogging(void)
case EVENT_LOG_MSG: // (msg)
case EVENT_USER_MSG: // (msg)
+ case EVENT_RTS_IDENTIFIER: // (capset, str)
+ case EVENT_PROGRAM_ARGS: // (capset, strvec)
+ case EVENT_PROGRAM_ENV: // (capset, strvec)
eventTypes[t].size = 0xffff;
break;
@@ -296,10 +335,6 @@ initEventLogging(void)
// Prepare event buffer for events (data).
postInt32(&eventBuf, EVENT_DATA_BEGIN);
-
- // Post a STARTUP event with the number of capabilities
- postEventHeader(&eventBuf, EVENT_STARTUP);
- postCapNo(&eventBuf, n_caps);
// Flush capEventBuf with header.
/*
@@ -443,6 +478,115 @@ postSchedEvent (Capability *cap,
}
}
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForEvent(&eventBuf, tag)) {
+ // Flush event buffer to make room for new event.
+ printAndClearEventBuf(&eventBuf);
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postCapsetID(&eventBuf, capset);
+
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ {
+ postCapsetType(&eventBuf, other /* capset_type */);
+ break;
+ }
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ {
+ break;
+ }
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ {
+ postCapNo(&eventBuf, other /* capno */);
+ break;
+ }
+ case EVENT_OSPROCESS_PID: // (capset, pid)
+ case EVENT_OSPROCESS_PPID: // (capset, parent_pid)
+ {
+ postWord32(&eventBuf, other);
+ break;
+ }
+ default:
+ barf("postCapsetModifyEvent: unknown event tag %d", tag);
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg)
+{
+ int strsize = strlen(msg);
+ int size = strsize + sizeof(EventCapsetID)
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ postBuf(&eventBuf, (StgWord8*) msg, strsize);
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *argv[])
+{
+ int i, size = sizeof(EventCapsetID);
+
+ for (i = 0; i < argc; i++) {
+ // 1 + strlen to account for the trailing \0, used as separator
+ size += 1 + strlen(argv[i]);
+ }
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if(!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ for( i = 0; i < argc; i++ ) {
+ // again, 1 + to account for \0
+ postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
void
postEvent (Capability *cap, EventTypeNum tag)
{
@@ -498,6 +642,22 @@ void postUserMsg(Capability *cap, char *msg, va_list ap)
postLogMsg(&capEventBuf[cap->no], EVENT_USER_MSG, msg, ap);
}
+void postEventStartup(EventCapNo n_caps)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForEvent(&eventBuf, EVENT_STARTUP)) {
+ // Flush event buffer to make room for new event.
+ printAndClearEventBuf(&eventBuf);
+ }
+
+ // Post a STARTUP event with the number of capabilities
+ postEventHeader(&eventBuf, EVENT_STARTUP);
+ postCapNo(&eventBuf, n_caps);
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
void closeBlockMarker (EventsBuf *ebuf)
{
StgInt8* save_pos;
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index 0cfab5c0910f14cd67381994a9a1c0222a59e3a8..602ac2c87b7eb23dfbbbdf9865b641ed1c667542 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -45,6 +45,30 @@ void postUserMsg(Capability *cap, char *msg, va_list ap);
void postCapMsg(Capability *cap, char *msg, va_list ap);
+void postEventStartup(EventCapNo n_caps);
+
+/*
+ * Post a capability set modification event
+ */
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other);
+
+/*
+ * Post a capability set event with a string payload
+ */
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg);
+
+/*
+ * Post a capability set event with several strings payload
+ */
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *msg[]);
+
#else /* !TRACING */
INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED,
diff --git a/rts/ghc.mk b/rts/ghc.mk
index 369b6e1354fd6d667441689e3e642e6a0af8573c..11b7945fae58dbef9c507a2f7573f6765d465a55 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -201,8 +201,8 @@ endif
else
$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS)
"$$(RM)" $$(RM_OPTS) $$@
- echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR)" \
- $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@
+ echo $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) | "$$(XARGS)" $$(XARGS_OPTS) "$$(AR_STAGE1)" \
+ $$(AR_OPTS_STAGE1) $$(EXTRA_AR_ARGS_STAGE1) $$@
endif
endif
@@ -302,6 +302,7 @@ rts/RtsMain_HC_OPTS += -optc-O0
rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
+rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
#
rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
@@ -468,8 +469,7 @@ rts_dist_MKDEPENDC_OPTS += -Irts/dist/build
endif
-$(eval $(call build-dependencies,rts,dist,1))
-$(eval $(call include-dependencies,rts,dist,1))
+$(eval $(call dependencies,rts,dist,1))
$(rts_dist_depfile_c_asm) : libffi/dist-install/build/ffi.h $(DTRACEPROBES_H)
@@ -512,7 +512,7 @@ endif
ifneq "$(BINDIST)" "YES"
rts/dist/build/libHSrtsmain.a : rts/dist/build/Main.o
"$(RM)" $(RM_OPTS) $@
- "$(AR)" $(AR_OPTS) $(EXTRA_AR_ARGS) $@ $<
+ "$(AR_STAGE1)" $(AR_OPTS_STAGE1) $(EXTRA_AR_ARGS_STAGE1) $@ $<
endif
# -----------------------------------------------------------------------------
diff --git a/rts/posix/GetEnv.c b/rts/posix/GetEnv.c
new file mode 100644
index 0000000000000000000000000000000000000000..4d5c7e248e0cf0518ff9611ad8f42ec5e2b90df3
--- /dev/null
+++ b/rts/posix/GetEnv.c
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#if defined(darwin_HOST_OS)
+
+/* While the "extern char** environ" var does exist on OSX, it is not
+ * available to shared libs. See ghc ticket #2458 and
+ * http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+ */
+#include <crt_externs.h>
+
+static char** get_environ(void) { return *(_NSGetEnviron()); }
+
+#else
+
+/* On proper unix systems the environ is just a global var.
+ */
+extern char** environ;
+static char** get_environ(void) { return environ; }
+
+#endif
+
+
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+ int envc;
+ char **environ = get_environ();
+
+ for (envc = 0; environ[envc] != NULL; envc++) {};
+
+ *out_envc = envc;
+ *out_envv = environ;
+}
+
+void freeProgEnvv(int envc STG_UNUSED, char *envv[] STG_UNUSED) {
+ /* nothing */
+}
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index 3375760ae40c2e6ac97430344c92428abfd6080a..9da6aaae26467e31613fe4df4505aecdd8e3d1b9 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -441,16 +441,6 @@ GarbageCollect (nat N, // generation to collect
// NO MORE EVACUATION AFTER THIS POINT!
- // Two-space collector: free the old to-space.
- // g0->old_blocks is the old nursery
- // g0->blocks is to-space from the previous GC
- if (RtsFlags.GcFlags.generations == 1) {
- if (g0->blocks != NULL) {
- freeChain_sync(g0->blocks);
- g0->blocks = NULL;
- }
- }
-
// Finally: compact or sweep the oldest generation.
if (major_gc && oldest_gen->mark) {
if (oldest_gen->compact)
@@ -1466,7 +1456,7 @@ prepare_collected_gen (generation *gen)
// allocate the mark bitmap for any blocks that will be marked, as
// opposed to copied, during this collection.
{
- nat bitmap_size; // in bytes
+ lnat bitmap_size; // in bytes
bdescr *bitmap_bdescr;
StgWord *bitmap;
bdescr *marked_blocks;
diff --git a/rts/win32/GetEnv.c b/rts/win32/GetEnv.c
new file mode 100644
index 0000000000000000000000000000000000000000..b8a43951a90dae4c9128507b3de58c82cc7c2235
--- /dev/null
+++ b/rts/win32/GetEnv.c
@@ -0,0 +1,61 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#include <windows.h>
+
+/* Windows does it differently, though arguably the most sanely.
+ * GetEnvironmentStrings() returns a pointer to a block of
+ * environment vars with a double null terminator:
+ * Var1=Value1\0
+ * Var2=Value2\0
+ * ...
+ * VarN=ValueN\0\0
+ * But because everyone else (ie POSIX) uses a vector of strings, we convert
+ * to that format. Fortunately this is just a matter of making an array of
+ * offsets into the environment block.
+ *
+ * Note that we have to call FreeEnvironmentStrings() at the end.
+ *
+ */
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+ int envc, i;
+ char *env;
+ char *envp;
+ char **envv;
+
+ /* For now, use the 'A'nsi not 'W'ide variant.
+ Note: corresponding Free below must use the same 'A'/'W' variant. */
+ env = GetEnvironmentStringsA();
+
+ envc = 0;
+ for (envp = env; *envp != 0; envp += strlen(envp) + 1) {
+ envc++;
+ }
+
+ envv = stgMallocBytes(sizeof(char*) * (envc+1));
+
+ i = 0;
+ for (envp = env; *envp != NULL; envp += strlen(envp) + 1) {
+ envv[i] = envp;
+ i++;
+ }
+ /* stash whole env in last+1 entry */
+ envv[envc] = env;
+
+ *out_envc = envc;
+ *out_envv = envv;
+}
+
+void freeProgEnvv(int envc, char *envv[]) {
+ /* we stashed the win32 env block in the last+1 entry */
+ FreeEnvironmentStringsA(envv[envc]);
+ stgFree(envv);
+}
diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk
index 86f9323859ae3b5303dd240e621d04380f862309..9a66d1beb1d8efb198bc561ebb33df36a33180c4 100644
--- a/rules/build-package-data.mk
+++ b/rules/build-package-data.mk
@@ -63,6 +63,11 @@ ifeq "$3" "0"
$1_$2_CONFIGURE_OPTS += $$(BOOT_PKG_CONSTRAINTS)
endif
+$1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)"
+
ifneq "$$(BINDIST)" "YES"
ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES"
$1/$2/inplace-pkg-config : $1/$2/package-data.mk
@@ -72,7 +77,7 @@ $1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk
# for our build system, and registers the package for use in-place in
# the build tree.
$1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP)
- "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" --with-gcc="$$(WhatGccIsCalled)" --configure-option=--with-cc="$$(WhatGccIsCalled)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
+ "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
ifeq "$$($1_$2_PROG)" ""
ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO"
"$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config
diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk
index d6c1560e10ee2b9fbebf907f2ee214f61787924d..2497e298c272a94672063704d3c4ac5d65083fb4 100644
--- a/rules/build-package-way.mk
+++ b/rules/build-package-way.mk
@@ -64,17 +64,17 @@ ifeq "$3" "dyn"
# On windows we have to supply the extra libs this one links to when building it.
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_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
-shared -dynamic -dynload deploy \
$$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \
- -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+ -no-auto-link-packages \
-o $$@
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_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
-shared -dynamic -dynload deploy \
-dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \
- -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+ -no-auto-link-packages \
-o $$@
endif
else
@@ -87,10 +87,10 @@ ifeq "$$($1_$2_SplitObjs)" "YES"
else
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
diff --git a/rules/build-package.mk b/rules/build-package.mk
index ac0a8eebce1ba78793be97115f32f1e738625114..c735e5137a60410c1c6377a200e34af08e1b4355 100644
--- a/rules/build-package.mk
+++ b/rules/build-package.mk
@@ -100,21 +100,7 @@ $(call hs-sources,$1,$2)
$(call c-sources,$1,$2)
$(call includes-sources,$1,$2)
-# --- DEPENDENCIES
-# We always have the dependency rules available, as we need to know
-# how to build hsc2hs's dependency file in phase 0
-$(call build-dependencies,$1,$2,$3)
-ifneq "$(phase)" "0"
-# From phase 1 we actually include the dependency files for the
-# bootstrapping stuff
-ifeq "$3" "0"
-$(call include-dependencies,$1,$2,$3)
-else ifeq "$(phase)" "final"
-# In the final phase, we also include the dependency files for
-# everything else
-$(call include-dependencies,$1,$2,$3)
-endif
-endif
+$(call dependencies,$1,$2,$3)
# Now generate all the build rules for each way in this directory:
$$(foreach way,$$($1_$2_WAYS),$$(eval \
diff --git a/rules/build-prog.mk b/rules/build-prog.mk
index 5c352a2f957631b73354251ce0eedad59782d8bf..99093d3feec57c154d10adbf6823666eb608a78f 100644
--- a/rules/build-prog.mk
+++ b/rules/build-prog.mk
@@ -156,7 +156,7 @@ $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2
"$$($1_$2_HC)" -o $$@ $$($1_$2_v_ALL_HC_OPTS) $$(LD_OPTS) $$($1_$2_GHC_LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES))
else
$1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/.
- "$$(CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES))
+ "$$($1_$2_CC)" -o $$@ $$($1_$2_v_ALL_CC_OPTS) $$(LD_OPTS) $$($1_$2_v_HS_OBJS) $$($1_$2_v_C_OBJS) $$($1_$2_v_S_OBJS) $$($1_$2_OTHER_OBJS) $$($1_$2_v_EXTRA_CC_OPTS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES))
endif
# Note [lib-depends] if this program is built with stage1 or greater, we
@@ -188,20 +188,6 @@ INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG)
endif
endif
-# --- DEPENDENCIES
-# We always have the dependency rules available, as we need to know
-# how to build hsc2hs's dependency file in phase 0
-$(call build-dependencies,$1,$2,$3)
-ifneq "$(phase)" "0"
-# From phase 1 we actually include the dependency files for the
-# bootstrapping stuff
-ifeq "$3" "0"
-$(call include-dependencies,$1,$2,$3)
-else ifeq "$(phase)" "final"
-# In the final phase, we also include the dependency files for
-# everything else
-$(call include-dependencies,$1,$2,$3)
-endif
-endif
+$(call dependencies,$1,$2,$3)
endef
diff --git a/rules/c-suffix-rules.mk b/rules/c-suffix-rules.mk
index fa7dd6f8405832dff2968717cc8b949cc49ecf33..a4a0b579db0b24ca98b9f93ae1c41eaf8f4b0a96 100644
--- a/rules/c-suffix-rules.mk
+++ b/rules/c-suffix-rules.mk
@@ -43,19 +43,19 @@ $1/$2/build/%.$$($3_way_)s : $1/%.c $$($1_$2_HC_DEP)
else
$1/$2/build/%.$$($3_osuf) : $1/%.c | $$$$(dir $$$$@)/.
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s
- "$$(AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
+ "$$($1_$2_AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
$1/$2/build/%.$$($3_osuf) : $1/%.S | $$$$(dir $$$$@)/.
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
$1/$2/build/%.$$($3_way_)s : $1/$2/build/%.c
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -S $$< -o $$@
endif
diff --git a/rules/dependencies.mk b/rules/dependencies.mk
new file mode 100644
index 0000000000000000000000000000000000000000..42605a565c45d83b0ecfaf573a3f014858edcc27
--- /dev/null
+++ b/rules/dependencies.mk
@@ -0,0 +1,38 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
+# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+define dependencies
+$(call trace, dependencies($1,$2,$3))
+$(call profStart, dependencies($1,$2,$3))
+# $1 = dir
+# $2 = distdir
+# $3 = GHC stage to use (0 == bootstrapping compiler)
+
+# We always have the dependency rules available, as we need to know
+# how to build hsc2hs's dependency file in phase 0
+$(call build-dependencies,$1,$2,$3)
+
+ifneq "$(phase)" "0"
+# From phase 1 we actually include the dependency files for the
+# bootstrapping stuff
+ifeq "$3" "0"
+$(call include-dependencies,$1,$2,$3)
+else ifeq "$(phase)" "final"
+# In the final phase, we also include the dependency files for
+# everything else
+$(call include-dependencies,$1,$2,$3)
+endif
+endif
+
+$(call profEnd, dependencies($1,$2,$3))
+endef
+
diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk
index bebbc4d04b7740a1a6b29f5d3ccea329d449559d..5c56169dc51e3b55a16e380a1db34685f57e9a7e 100644
--- a/rules/distdir-way-opts.mk
+++ b/rules/distdir-way-opts.mk
@@ -17,9 +17,9 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
# Options for a Haskell compilation:
# - CONF_HC_OPTS source-tree-wide options, selected at
-# configure-time
+# configure-time
# - SRC_HC_OPTS source-tree-wide options from build.mk
-# (optimisation, heap settings)
+# (optimisation, heap settings)
# - libraries/base_HC_OPTS options from Cabal for libraries/base
# for all ways
# - libraries/base_MORE_HC_OPTS options from elsewhere in the build
@@ -27,7 +27,7 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
# - libraries/base_v_HC_OPTS options from libraries/base for way v
# - WAY_v_HC_OPTS options for this way
# - EXTRA_HC_OPTS options from the command-line
-# - -Idir1 -Idir2 ... include-dirs from this package
+# - -Idir1 -Idir2 ... include-dirs from this package
# - -odir/-hidir/-stubdir put the output files under $3/build
# - -osuf/-hisuf/-hcsuf suffixes for the output files in this way
@@ -134,6 +134,8 @@ $1_$2_$3_ALL_HSC2HS_OPTS = \
--cflag=-D__GLASGOW_HASKELL__=$$(ProjectVersionInt) \
$$($1_$2_$3_HSC2HS_CC_OPTS) \
$$($1_$2_$3_HSC2HS_LD_OPTS) \
+ --cflag=-I$1/$2/build/autogen \
+ $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \
$$($$(basename $$<)_HSC2HS_OPTS) \
$$(EXTRA_HSC2HS_OPTS)
diff --git a/rules/hs-suffix-rules-srcdir.mk b/rules/hs-suffix-rules-srcdir.mk
index 7e9c8d377d0e9168ebadfa796b57a20bc99668f8..bdb9d0028250e4fc19d29d5e765e6e614058999a 100644
--- a/rules/hs-suffix-rules-srcdir.mk
+++ b/rules/hs-suffix-rules-srcdir.mk
@@ -52,10 +52,10 @@ endif
# .hs->.o rule, I don't know why --SDM
$1/$2/build/%.$$($3_osuf) : $1/$4/%.hc includes/ghcautoconf.h includes/ghcplatform.h | $$$$(dir $$$$@)/.
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@
$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghcplatform.h
- "$$(CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@
+ "$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -Iincludes -x c -c $$< -o $$@
# $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)hc
# "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@
diff --git a/rules/package-config.mk b/rules/package-config.mk
index 2091779d1e2b436696007660284c0205e8148d02..177ca2517df00ff14bec6a5ad7b11d67bd407a87 100644
--- a/rules/package-config.mk
+++ b/rules/package-config.mk
@@ -16,6 +16,12 @@ $(call trace, package-config($1,$2,$3))
$(call profStart, package-config($1,$2,$3))
$1_$2_HC = $$(GHC_STAGE$3)
+$1_$2_CC = $$(CC_STAGE$3)
+$1_$2_AS = $$(AS_STAGE$3)
+$1_$2_AR = $$(AR_STAGE$3)
+$1_$2_AR_OPTS = $$(AR_OPTS_STAGE$3)
+$1_$2_EXTRA_AR_ARGS = $$(EXTRA_AR_ARGS_STAGE$3)
+$1_$2_ArSupportsAtFile = $$(ArSupportsAtFile_STAGE$3)
# configuration stuff that depends on which GHC we're building with
ifeq "$3" "0"
diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk
index 64339576c6a62917f4209afefcb8be50571b76bd..5cc10dc3470ddbe195600dfea284aa4d351c721f 100644
--- a/rules/shell-wrapper.mk
+++ b/rules/shell-wrapper.mk
@@ -74,7 +74,6 @@ install_$1_$2_wrapper:
echo 'datadir="$$(datadir)"' >> "$$(WRAPPER)"
echo 'bindir="$$(bindir)"' >> "$$(WRAPPER)"
echo 'topdir="$$(topdir)"' >> "$$(WRAPPER)"
- echo 'pgmgcc="$$(WhatGccIsCalled)"' >> "$$(WRAPPER)"
$$($1_$2_SHELL_WRAPPER_EXTRA)
$$($1_$2_INSTALL_SHELL_WRAPPER_EXTRA)
cat $$($1_$2_SHELL_WRAPPER_NAME) >> "$$(WRAPPER)"
diff --git a/settings.in b/settings.in
new file mode 100644
index 0000000000000000000000000000000000000000..5d4e1d3a76fc614ea04be6ff40b2877897f812ec
--- /dev/null
+++ b/settings.in
@@ -0,0 +1,8 @@
+[("GCC extra via C opts", "@GccExtraViaCOpts@"),
+ ("C compiler command", "@WhatGccIsCalled@"),
+ ("C compiler flags", "@CONF_CC_OPTS_STAGE2@"),
+ ("ar command", "@ArCmd@"),
+ ("ar flags", "@ArArgs@"),
+ ("ar supports at file", "@ArSupportsAtFile@"),
+ ("perl command", "@PerlCmd@")]
+
diff --git a/sync-all b/sync-all
index 02ac5214b28cb1e9be6d41581088250e850b44c7..8b41c97711ad3f2ea147af18984e3d65679b0ae2 100755
--- a/sync-all
+++ b/sync-all
@@ -65,13 +65,9 @@ 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.
@@ -195,17 +191,6 @@ sub scm {
}
}
-sub repoexists {
- my ($scm, $localpath) = @_;
-
- if ($scm eq "darcs") {
- -d "$localpath/_darcs";
- }
- else {
- -d "$localpath/.git";
- }
-}
-
sub scmall {
my $command = shift;
@@ -221,8 +206,6 @@ sub scmall {
my $path;
my $wd_before = getcwd;
- my @scm_args;
-
my $pwd;
my @args;
@@ -253,7 +236,7 @@ sub scmall {
} else {
$branch_name = shift;
}
- } elsif ($command eq 'new' || $command eq 'fetch') {
+ } elsif ($command eq 'new') {
if (@_ < 1) {
$branch_name = 'origin';
} else {
@@ -265,137 +248,165 @@ sub scmall {
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"};
- # We can't create directories on GitHub, so we translate
- # "package/foo" into "package-foo".
- if ($is_github_repo) {
- $remotepath =~ s/\//-/;
- }
+ # 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"));
+ # We can't create directories on GitHub, so we translate
+ # "package/foo" into "package-foo".
+ if ($is_github_repo) {
+ $remotepath =~ s/\//-/;
+ }
- # 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";
- }
+ # 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";
+ }
- # Work out the arguments we should give to the SCM
- if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
- @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 =~ /^commit$/) {
- @scm_args = ("commit");
- # git fails if there is nothing to commit, so ignore failures
- $ignore_failure = 1;
+ 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 =~ /^(?:pus|push)$/) {
- @scm_args = "push";
+ if ($tags{$tag} == 0) {
+ next;
}
- elsif ($command =~ /^(?:pul|pull)$/) {
- @scm_args = "pull";
- # Q: should we append the -a argument for darcs repos?
- }
- 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 ($scm eq "darcs" && not defined($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);
- }
- }
- elsif ($command =~ /^(?:s|se|sen|send)$/) {
- @scm_args = (($scm eq "darcs" and "send")
- or ($scm eq "git" and "send-email"));
- $want_remote_repo = 1;
- }
- elsif ($command =~ /^fetch$/) {
- @scm_args = ("fetch", "$branch_name");
- }
- elsif ($command =~ /^new$/) {
- @scm_args = ("log", "$branch_name..");
+ scm (".", $scm, "get", $get_mode, $path, $localpath, @args);
}
- elsif ($command =~ /^remote$/) {
- 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);
- }
+ else {
+ scm (".", $scm, "clone", $path, $localpath, @args);
+ scm ($localpath, $scm, "config", "core.ignorecase", "true");
}
- elsif ($command =~ /^grep$/) {
- @scm_args = ("grep");
- # Hack around 'git grep' failing if there are no matches
- $ignore_failure = 1;
+ next;
+ }
+
+ if (-d "$localpath/_darcs") {
+ if (-d "$localpath/.git") {
+ die "Found both _darcs and .git in $localpath";
}
- elsif ($command =~ /^reset$/) {
- @scm_args = "reset";
+ $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 =~ /^config$/) {
- @scm_args = "config";
+ elsif ($scm eq "git") {
+ $command = "status";
}
else {
- die "Unknown command: $command";
+ die "Unknown scm";
}
-
- # Actually execute the command
- if (repoexists ($scm, $localpath)) {
- if ($want_remote_repo) {
- if ($scm eq "darcs") {
- scm (".", $scm, @scm_args, @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, @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, @args);
- }
- }
- elsif ($local_repo_unnecessary) {
- # Don't bother to change directory in this case
- scm (".", $scm, @scm_args, @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";
+ }
+ scm ($localpath, $scm, $command, @args);
+ }
+ elsif ($command =~ /^fetch$/) {
+ scm ($localpath, $scm, "fetch", @args);
+ }
+ elsif ($command =~ /^new$/) {
+ my @scm_args = ("log", "$branch_name..");
+ scm ($localpath, $scm, @scm_args, @args);
+ }
+ elsif ($command =~ /^log$/) {
+ scm ($localpath, $scm, "log", @args);
+ }
+ 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 ($command =~ /^grep$/) {
+ # Hack around 'git grep' failing if there are no matches
+ $ignore_failure = 1;
+ scm ($localpath, $scm, "grep", @args)
+ unless $scm eq "darcs";
+ }
+ elsif ($command =~ /^clean$/) {
+ scm ($localpath, $scm, "clean", @args)
+ unless $scm eq "darcs";
+ }
+ 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 {
+ die "Unknown command: $command";
+ }
}
}
@@ -421,9 +432,12 @@ Supported commands:
* remote add <branch-name>
* remote rm <branch-name>
* remote set-url [--push] <branch-name>
+ * checkout
* grep
+ * clean
* reset
* config
+ * log
Available package-tags are:
END
@@ -484,9 +498,11 @@ sub main {
}
# --<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 ($arg =~ m/^--no-(.*)$/) {
+ $tags{$1} = 0;
+ }
+ elsif ($arg =~ m/^--(.*)$/) {
+ $tags{$1} = 1;
}
else {
unshift @_, $arg;
diff --git a/utils/Makefile b/utils/Makefile
index 881d7d50b9076e3de9f24b9999d7964ba0ce5186..e522c32ba83fa6ffc103b20d5d6d72ce03dc14e5 100644
--- a/utils/Makefile
+++ b/utils/Makefile
@@ -60,7 +60,7 @@ endif
WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc
-WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock
+WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock
ifneq "$(NO_INSTALL_HSC2HS)" "YES"
WITH_STAGE2 += hsc2hs
endif
diff --git a/utils/compare_sizes/ghc.mk b/utils/compare_sizes/ghc.mk
index 1c9dbee4a9d422c1700500c01e33380406dda769..5e482996468027898cfbd08852cfb1a40aa82b07 100644
--- a/utils/compare_sizes/ghc.mk
+++ b/utils/compare_sizes/ghc.mk
@@ -2,7 +2,7 @@
utils/compare_sizes_USES_CABAL = YES
utils/compare_sizes_PACKAGE = compareSizes
utils/compare_sizes_MODULES = Main
-utils/compare_sizes_dist_PROG = compareSizes$(exeext)
+utils/compare_sizes_dist-install_PROG = compareSizes$(exeext)
-$(eval $(call build-prog,utils/compare_sizes,dist,1))
+$(eval $(call build-prog,utils/compare_sizes,dist-install,1))
diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py
new file mode 100755
index 0000000000000000000000000000000000000000..f04b98ecd4fbbca3af81dafc3af791fcc9879e2d
--- /dev/null
+++ b/utils/fingerprint/fingerprint.py
@@ -0,0 +1,248 @@
+#! /usr/bin/env python
+# Script to create and restore a git fingerprint of the ghc repositories.
+
+from datetime import datetime
+from optparse import OptionParser
+import os
+import os.path
+import re
+import subprocess
+from subprocess import PIPE, Popen
+import sys
+
+def main():
+ opts, args = parseopts(sys.argv[1:])
+ opts.action(opts)
+
+def create_action(opts):
+ """Action called for the create commmand"""
+ if opts.fpfile:
+ fp = FingerPrint.read(opts.source)
+ else:
+ fp = fingerprint(opts.source)
+ if len(fp) == 0:
+ error("Got empty fingerprint from source: "+str(opts.source))
+ if opts.output_file:
+ print "Writing fingerprint to: ", opts.output_file
+ fp.write(opts.output)
+
+def restore_action(opts):
+ """Action called for the restore commmand"""
+ def branch_name(filename):
+ return "fingerprint_" + os.path.basename(filename).replace(".", "_")
+ if opts.fpfile:
+ try:
+ fp = FingerPrint.read(opts.source)
+ bn = branch_name(opts.fpfile)
+ except MalformedFingerPrintError:
+ error("Error parsing fingerprint file: "+opts.fpfile)
+ if len(fp) == 0:
+ error("No fingerprint found in fingerprint file: "+opts.fpfile)
+ elif opts.logfile:
+ fp = fingerprint(opts.source)
+ bn = branch_name(opts.logfile)
+ if len(fp) == 0:
+ error("No fingerprint found in build log file: "+opts.logfile)
+ else:
+ error("Must restore from fingerprint or log file")
+ restore(fp, branch_name=bn if opts.branch else None)
+
+def fingerprint(source=None):
+ """Create a new fingerprint of current repositories.
+
+ The source argument is parsed to look for the expected output
+ from a `sync-all` command. If the source is `None` then the
+ `sync-all` command will be run to get the current fingerprint.
+ """
+ if source is None:
+ sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"]
+ source = Popen(sync_all, stdout=PIPE).stdout
+
+ lib = ""
+ commits = {}
+ for line in source.readlines():
+ if line.startswith("=="):
+ lib = line.split()[1].rstrip(":")
+ lib = "." if lib == "running" else lib # hack for top ghc repo
+ elif re.match("[abcdef0-9]{40}", line):
+ commit = line[:40]
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+def restore(fp, branch_name=None):
+ """Restore the ghc repos to the commits in the fingerprint
+
+ This function performs a checkout of each commit specifed in
+ the fingerprint. If `branch_name` is not None then a new branch
+ will be created for the top ghc repository. We also add an entry
+ to the git config that sets the remote for the new branch as `origin`
+ so that the `sync-all` command can be used from the branch.
+ """
+ checkout = ["git", "checkout"]
+
+ # run checkout in all subdirs
+ for (subdir, commit) in fp:
+ if subdir != ".":
+ cmd = checkout + [commit]
+ print "==", subdir, " ".join(cmd)
+ if os.path.exists(subdir):
+ rc = subprocess.call(cmd, cwd=subdir)
+ if rc != 0:
+ error("Too many errors, aborting")
+ else:
+ sys.stderr.write("WARNING: "+
+ subdir+" is in fingerprint but missing in working directory\n")
+
+ # special handling for top ghc repo
+ # if we are creating a new branch then also add an entry to the
+ # git config so the sync-all command is happy
+ branch_args = ["-b", branch_name] if branch_name else []
+ rc = subprocess.call(checkout + branch_args + [fp["."]])
+ if (rc == 0) and branch_name:
+ branch_config = "branch."+branch_name+".remote"
+ subprocess.call(["git", "config", "--add", branch_config, "origin"])
+
+actions = {"create" : create_action, "restore" : restore_action}
+def parseopts(argv):
+ """Parse and check the validity of the command line arguments"""
+ usage = "fingerprint ("+"|".join(sorted(actions.keys()))+") [options]"
+ parser = OptionParser(usage=usage)
+
+ parser.add_option("-d", "--dir", dest="dir",
+ help="write output to directory DIR", metavar="DIR")
+
+ parser.add_option("-o", "--output", dest="output",
+ help="write output to file FILE", metavar="FILE")
+
+ parser.add_option("-l", "--from-log", dest="logfile",
+ help="reconstruct fingerprint from build log", metavar="FILE")
+
+ parser.add_option("-f", "--from-fp", dest="fpfile",
+ help="reconstruct fingerprint from fingerprint file", metavar="FILE")
+
+ parser.add_option("-n", "--no-branch",
+ action="store_false", dest="branch", default=True,
+ help="do not create a new branch when restoring fingerprint")
+
+ parser.add_option("-g", "--ghc-dir", dest="ghcdir",
+ help="perform actions in GHC dir", metavar="DIR")
+
+ opts,args = parser.parse_args(argv)
+ return (validate(opts, args, parser), args)
+
+def validate(opts, args, parser):
+ """ Validate and prepare the command line options.
+
+ It performs the following actions:
+ * Check that we have a valid action to perform
+ * Check that we have a valid output destination
+ * Opens the output file if needed
+ * Opens the input file if needed
+ """
+ # Determine the action
+ try:
+ opts.action = actions[args[0]]
+ except (IndexError, KeyError):
+ error("Must specify a valid action", parser)
+
+ # Inputs
+ if opts.logfile and opts.fpfile:
+ error("Must specify only one of -l and -f")
+
+ opts.source = None
+ if opts.logfile:
+ opts.source = file(opts.logfile, "r")
+ elif opts.fpfile:
+ opts.source = file(opts.fpfile, "r")
+
+ # Outputs
+ if opts.dir:
+ fname = opts.output
+ if fname is None:
+ fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp"
+ path = os.path.join(opts.dir, fname)
+ opts.output_file = path
+ opts.output = file(path, "w")
+ elif opts.output:
+ opts.output_file = opts.output
+ opts.output = file(opts.output_file, "w")
+ else:
+ opts.output_file = None
+ opts.output = sys.stdout
+
+ # GHC Directory
+ # As a last step change the directory to the GHC directory specified
+ if opts.ghcdir:
+ os.chdir(opts.ghcdir)
+
+ return opts
+
+def error(msg="fatal error", parser=None, exit=1):
+ """Function that prints error message and exits"""
+ print "ERROR:", msg
+ if parser:
+ parser.print_help()
+ sys.exit(exit)
+
+class MalformedFingerPrintError(Exception):
+ """Exception raised when parsing a bad fingerprint file"""
+ pass
+
+class FingerPrint:
+ """Class representing a fingerprint of all ghc git repos.
+
+ A finger print is represented by a dictionary that maps a
+ directory to a commit. The directory "." is used for the top
+ level ghc repository.
+ """
+ def __init__(self, subcommits = {}):
+ self.commits = subcommits
+
+ def __eq__(self, other):
+ if other.__class__ != self.__class__:
+ raise TypeError
+ return self.commits == other.commits
+
+ def __neq__(self, other):
+ not(self == other)
+
+ def __hash__(self):
+ return hash(str(self))
+
+ def __len__(self):
+ return len(self.commits)
+
+ def __repr__(self):
+ return "FingerPrint(" + repr(self.commits) + ")"
+
+ def __str__(self):
+ s = ""
+ for lib in sorted(self.commits.keys()):
+ commit = self.commits[lib]
+ s += "{0}|{1}\n".format(lib, commit)
+ return s
+
+ def __getitem__(self, item):
+ return self.commits[item]
+
+ def __iter__(self):
+ return self.commits.iteritems()
+
+ def write(self, outh):
+ outh.write(str(self))
+ outh.flush()
+
+ @staticmethod
+ def read(inh):
+ """Read a fingerprint from a fingerprint file"""
+ commits = {}
+ for line in inh.readlines():
+ splits = line.strip().split("|", 1)
+ if len(splits) != 2:
+ raise MalformedFingerPrintError(line)
+ lib, commit = splits
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+if __name__ == "__main__":
+ main()
diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index df710d72b3fc3bbecfa65bd6160db6b7e926e97a..6f48c02f8ff493c48330fca9ad4583801834c17b 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -54,6 +54,7 @@ words :-
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
<0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+ <0> [0-9][0-9]* { mkTv (TInteger . read) }
<0> \" [^\"]* \" { mkTv (TString . tail . init) }
<in_braces> [^\{\}]+ { mkTv TNoBraces }
<in_braces> \n { mkTv TNoBraces }
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 5b802bccd744b8fd9f6aa9fdf8f293f599eb4457..14f08346be833127dd764184cc5aa39047e9c15a 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -46,13 +46,13 @@ main = getArgs >>= \args ->
"commutable"
"commutableOp" p_o_specs)
- "--needs-wrapper"
+ "--code-size"
-> putStr (gen_switch_from_attribs
- "needs_wrapper"
- "primOpNeedsWrapper" p_o_specs)
+ "code_size"
+ "primOpCodeSize" p_o_specs)
- "--can-fail"
- -> putStr (gen_switch_from_attribs
+ "--can-fail"
+ -> putStr (gen_switch_from_attribs
"can_fail"
"primOpCanFail" p_o_specs)
@@ -91,7 +91,7 @@ known_args
"--has-side-effects",
"--out-of-line",
"--commutable",
- "--needs-wrapper",
+ "--code-size",
"--can-fail",
"--strictness",
"--primop-primop-info",
@@ -141,6 +141,7 @@ gen_hs_source (Info defaults entries) =
where opt (OptionFalse n) = n ++ " = False"
opt (OptionTrue n) = n ++ " = True"
opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+ opt (OptionInteger n v) = n ++ " = " ++ show v
hdr s@(Section {}) = sec s
hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
@@ -409,7 +410,8 @@ gen_latex_doc (Info defaults entries)
Just (OptionTrue _) -> if_true
Just (OptionFalse _) -> if_false
Just (OptionString _ _) -> error "String value for boolean option"
- Nothing -> ""
+ Just (OptionInteger _ _) -> error "Integer value for boolean option"
+ Nothing -> ""
mk_strictness o =
case lookup_attrib "strictness" o of
@@ -550,6 +552,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
+ getAltRhs (OptionInteger _ i) = show i
getAltRhs (OptionString _ s) = s
mkAlt po
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index b20414d7d2c86b411306aaf480588678a81ebc4d..5773abb4fe2d95822001eb945b52f1046c105bf0 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -48,6 +48,7 @@ import Syntax
lowerName { TLowerName $$ }
upperName { TUpperName $$ }
string { TString $$ }
+ integer { TInteger $$ }
noBraces { TNoBraces $$ }
%%
@@ -66,6 +67,7 @@ pOption :: { Option }
pOption : lowerName '=' false { OptionFalse $1 }
| lowerName '=' true { OptionTrue $1 }
| lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+ | lowerName '=' integer { OptionInteger $1 $3 }
pEntries :: { [Entry] }
pEntries : pEntry pEntries { $1 : $2 }
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index edc300d6ccba5f0f5be41dd73756abfa76306c71..a2b39d7a21e912f70c280975e53a0eeb2cb56221 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -81,6 +81,7 @@ data Token = TEOF
| TUpperName String
| TString String
| TNoBraces String
+ | TInteger Int
deriving Show
-- Actions
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
index 809467020fa331698cff436c1aed82c3a97a0bdc..5fe4e0b23e42f2c94425f697deb9350f83bdd17c 100644
--- a/utils/genprimopcode/Syntax.hs
+++ b/utils/genprimopcode/Syntax.hs
@@ -40,6 +40,7 @@ data Option
= OptionFalse String -- name = False
| OptionTrue String -- name = True
| OptionString String String -- name = { ... unparsed stuff ... }
+ | OptionInteger String Int -- name = <int>
deriving Show
-- categorises primops
@@ -120,6 +121,7 @@ get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm) = nm
get_attrib_name (OptionString nm _) = nm
+get_attrib_name (OptionInteger nm _) = nm
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs
index 72a5010f805f6eac9fc5dd2b7cc7b46072c959fb..75d1faf9bff13df872361f9f7fed2ba742d6b855 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -28,7 +28,8 @@ import System.Exit
import System.FilePath
main :: IO ()
-main = do args <- getArgs
+main = do hSetBuffering stdout LineBuffering
+ args <- getArgs
case args of
"hscolour" : distDir : dir : args' ->
runHsColour distDir dir args'
@@ -295,7 +296,7 @@ generate config_args distdir directory
pd lib lbi clbi
final_ipi = installedPkgInfo {
Installed.installedPackageId = ipid,
- Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
+ Installed.haddockHTMLs = []
}
content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 1cec56a9985bbd15c7fd0cb22f7504d496f39f9d..4e6b53193a54f9da7fd4db1f03eb611fb3c8aa9e 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -19,7 +19,8 @@ import Distribution.ParseUtils
import Distribution.Package hiding (depends)
import Distribution.Text
import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import System.Cmd ( rawSystem )
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
@@ -34,7 +35,8 @@ import Data.Maybe
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
- doesFileExist, renameFile, removeFile )
+ doesFileExist, renameFile, removeFile,
+ getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
@@ -101,6 +103,9 @@ data Flag
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagExpandEnvVars
+ | FlagExpandPkgroot
+ | FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
@@ -126,6 +131,12 @@ flags = [
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+ "expand environment variables (${name}-style) in input package descriptions",
+ Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+ "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+ Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+ "preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
@@ -274,6 +285,12 @@ runit verbosity cli nonopts = do
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ expand_env_vars= FlagExpandEnvVars `elem` cli
+ mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+ where accumExpandPkgroot _ FlagExpandPkgroot = Just True
+ accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+ accumExpandPkgroot x _ = x
+
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
@@ -313,9 +330,11 @@ runit verbosity cli nonopts = do
["init", filename] ->
initPackageDB filename verbosity cli
["register", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs False force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars False force
["update", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs True force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid verbosity cli force
@@ -340,23 +359,24 @@ runit verbosity cli nonopts = do
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage verbosity cli pkgid
- ["describe", pkgid_str] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describePackage verbosity cli (Id pkgid)
- Just m -> describePackage verbosity cli (Substring pkgid_str m)
- ["field", pkgid_str, fields] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describeField verbosity cli (Id pkgid)
- (splitFields fields)
- Just m -> describeField verbosity cli (Substring pkgid_str m)
- (splitFields fields)
+ ["describe", pkgid_str] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+
+ ["field", pkgid_str, fields] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describeField verbosity cli pkgarg
+ (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
["check"] -> do
checkConsistency verbosity cli
["dump"] -> do
- dumpPackages verbosity cli
+ dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
["recache"] -> do
recache verbosity cli
@@ -402,8 +422,16 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
-- list, describe, field
data PackageDB
- = PackageDB { location :: FilePath,
- packages :: [InstalledPackageInfo] }
+ = PackageDB {
+ location, locationAbsolute :: !FilePath,
+ -- We need both possibly-relative and definately-absolute package
+ -- db locations. This is because the relative location is used as
+ -- an identifier for the db, so it is important we do not modify it.
+ -- On the other hand we need the absolute path in a few places
+ -- particularly in relation to the ${pkgroot} stuff.
+
+ packages :: [InstalledPackageInfo]
+ }
type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
@@ -415,6 +443,7 @@ allPackagesInStack = concatMap packages
getPkgDatabases :: Verbosity
-> Bool -- we are modifying, not reading
-> Bool -- read caches, if available
+ -> Bool -- expand vars, like ${pkgroot} and $topdir
-> [Flag]
-> IO (PackageDBStack,
-- the real package DB stack: [global,user] ++
@@ -427,7 +456,7 @@ getPkgDatabases :: Verbosity
-- is used as the list of package DBs for
-- commands that just read the DB, such as 'list'.
-getPkgDatabases verbosity modify use_cache my_flags = do
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-config flag by the
@@ -445,6 +474,12 @@ getPkgDatabases verbosity modify use_cache my_flags = do
Just path -> return path
fs -> return (last fs)
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ top_dir <- absolutePath (takeDirectory global_conf)
+
let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
@@ -513,7 +548,11 @@ getPkgDatabases verbosity modify use_cache my_flags = do
| null db_flags = Just virt_global_conf
| otherwise = Just (last db_flags)
- db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+ db_stack <- sequence
+ [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
+ | db_path <- final_stack ]
let flag_db_stack = [ db | db_name <- flag_db_names,
db <- db_stack, location db == db_name ]
@@ -539,13 +578,13 @@ readParseDatabase :: Verbosity
readParseDatabase verbosity mb_user_conf use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, path == user_conf
- = return PackageDB { location = path, packages = [] }
+ = mkPackageDB []
| otherwise
= do e <- tryIO $ getDirectoryContents path
case e of
Left _ -> do
pkgs <- parseMultiPackageConf verbosity path
- return PackageDB{ location = path, packages = pkgs }
+ mkPackageDB pkgs
Right fs
| not use_cache -> ignore_cache
| otherwise -> do
@@ -563,7 +602,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
putStrLn ("using cache: " ++ cache)
pkgs <- myReadBinPackageDB cache
let pkgs' = map convertPackageInfoIn pkgs
- return PackageDB { location = path, packages = pkgs' }
+ mkPackageDB pkgs'
| otherwise -> do
when (verbosity >= Normal) $ do
warn ("WARNING: cache is out of date: " ++ cache)
@@ -574,7 +613,15 @@ readParseDatabase verbosity mb_user_conf use_cache path
let confs = filter (".conf" `isSuffixOf`) fs
pkgs <- mapM (parseSingletonPackageConf verbosity) $
map (path </>) confs
- return PackageDB { location = path, packages = pkgs }
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ packages = pkgs
+ }
-- read the package.cache file strictly, to work around a problem with
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
@@ -600,11 +647,69 @@ parseMultiPackageConf verbosity file = do
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
- readUTF8File file >>= parsePackageInfo
+ readUTF8File file >>= fmap fst . parsePackageInfo
cachefilename :: FilePath
cachefilename = "package.cache"
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
+ -- It so happens that for both styles of package db ("package.conf"
+ -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+ -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+
+mungePackagePaths :: FilePath -> FilePath
+ -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+ | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+ stripVarPrefix var (root:path')
+ | Just [sep] <- stripPrefix var root
+ , isPathSeparator sep
+ = Just (joinPath path')
+
+ stripVarPrefix _ _ = Nothing
+
+
-- -----------------------------------------------------------------------------
-- Creating a new package DB
@@ -615,7 +720,11 @@ initPackageDB filename verbosity _flags = do
when b1 eexist
b2 <- doesDirectoryExist filename
when b2 eexist
- changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }
-- -----------------------------------------------------------------------------
-- Registering
@@ -624,17 +733,21 @@ registerPackage :: FilePath
-> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True True my_flags
+ getPkgDatabases verbosity True True False{-expand vars-} my_flags
let
db_to_operate_on = my_head "register" $
filter ((== to_modify).location) db_stack
--
+ when (auto_ghci_libs && verbosity >= Silent) $
+ warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+ --
s <-
case input of
"-" -> do
@@ -648,16 +761,26 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
putStr ("Reading package info from " ++ show f ++ " ... ")
readUTF8File f
- expanded <- expandEnvVars s force
+ expanded <- if expand_env_vars then expandEnvVars s force
+ else return s
- pkg <- parsePackageInfo expanded
+ (pkg, ws) <- parsePackageInfo expanded
when (verbosity >= Normal) $
putStrLn "done."
+ -- report any warnings from the parse phase
+ _ <- reportValidateErrors [] ws
+ (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+ -- validate the expanded pkg, but register the unexpanded
+ pkgroot <- absolutePath (takeDirectory to_modify)
+ let top_dir = takeDirectory (location (last db_stack))
+ pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
let truncated_stack = dropWhile ((/= to_modify).location) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
- validatePackageConfig pkg truncated_stack auto_ghci_libs update force
+ validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
let
removes = [ RemovePackage p
| p <- packages db_to_operate_on,
@@ -667,10 +790,13 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
parsePackageInfo
:: String
- -> IO InstalledPackageInfo
+ -> IO (InstalledPackageInfo, [ValidateWarning])
parsePackageInfo str =
case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
+ ParseOk warnings ok -> return (ok, ws)
+ where
+ ws = [ msg | PWarning msg <- warnings
+ , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
ParseFailed err -> case locatedErrorMsg err of
(Nothing, s) -> die s
(Just l, s) -> die (show l ++ ": " ++ s)
@@ -750,7 +876,7 @@ modifyPackage
-> IO ()
modifyPackage fn pkgid verbosity my_flags force = do
(db_stack, Just _to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
(db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
let
@@ -778,7 +904,7 @@ modifyPackage fn pkgid verbosity my_flags force = do
recache :: Verbosity -> [Flag] -> IO ()
recache verbosity my_flags = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
let
db_to_operate_on = my_head "recache" $
filter ((== to_modify).location) db_stack
@@ -794,7 +920,7 @@ listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
listPackages verbosity my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
(db_stack, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
@@ -887,7 +1013,7 @@ simplePackageList my_flags pkgs = do
showPackageDot :: Verbosity -> [Flag] -> IO ()
showPackageDot verbosity myflags = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} myflags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
let all_pkgs = allPackagesInStack flag_db_stack
ipix = PackageIndex.fromList all_pkgs
@@ -909,7 +1035,7 @@ showPackageDot verbosity myflags = do
latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
latestPackage verbosity my_flags pkgid = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
ps <- findPackages flag_db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
@@ -920,24 +1046,33 @@ latestPackage verbosity my_flags pkgid = do
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- ps <- findPackages flag_db_stack pkgarg
- doDump ps
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ dbs <- findPackagesByDB flag_db_stack pkgarg
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | (db, pkgs) <- dbs, pkg <- pkgs ]
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- doDump (allPackagesInStack flag_db_stack)
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | db <- flag_db_stack, pkg <- packages db ]
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
-- fix the encoding to UTF-8, since this is an interchange format
hSetEncoding stdout utf8
- mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+ putStrLn $
+ intercalate "---\n"
+ [ if expand_pkgroot
+ then showInstalledPackageInfo pkg
+ else showInstalledPackageInfo pkg ++ pkgrootField
+ | (pkg, pkgloc) <- pkgs
+ , let pkgroot = takeDirectory pkgloc
+ pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
@@ -976,14 +1111,13 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-- -----------------------------------------------------------------------------
-- Field
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
fns <- toFields fields
ps <- findPackages flag_db_stack pkgarg
- let top_dir = takeDirectory (location (last flag_db_stack))
- mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ mapM_ (selectFields fns) ps
where toFields [] = return []
toFields (f:fs) = case toField f of
Nothing -> die ("unknown field: " ++ f)
@@ -991,35 +1125,6 @@ describeField verbosity my_flags pkgarg fields = do
return (fn:fns)
selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ importDirs = munge_paths (importDirs p),
- includeDirs = munge_paths (includeDirs p),
- libraryDirs = munge_paths (libraryDirs p),
- frameworkDirs = munge_paths (frameworkDirs p),
- haddockInterfaces = munge_paths (haddockInterfaces p),
- haddockHTMLs = munge_paths (haddockHTMLs p)
- }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch [] rest = Just rest
-maybePrefixMatch (_:_) [] = Nothing
-maybePrefixMatch (p:pat) (r:rest)
- | p == r = maybePrefixMatch pat rest
- | otherwise = Nothing
-
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "import_dirs" = Just $ strList . importDirs
@@ -1045,7 +1150,8 @@ strList = show
checkConsistency :: Verbosity -> [Flag] -> IO ()
checkConsistency verbosity my_flags = do
- (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
+ (db_stack, _, _) <-
+ getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
@@ -1218,6 +1324,9 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do
mapM_ (checkDir False "import-dirs") (importDirs pkg)
mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
mapM_ (checkDir True "include-dirs") (includeDirs pkg)
+ mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
+ mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
+ mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkModules pkg
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
@@ -1269,19 +1378,34 @@ checkDuplicates db_stack pkg update = do
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://" `isPrefixOf` d
+ || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+ -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+ -- variables having been expanded already, see mungePackagePaths.
-checkDir :: Bool -> String -> String -> Validate ()
-checkDir warn_only thisfield d
- | "$topdir" `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
- -- can't check these, because we don't know what $(http)topdir is
| isRelative d = verror ForceFiles $
- thisfield ++ ": " ++ d ++ " is a relative path"
+ thisfield ++ ": " ++ d ++ " is a relative path which "
+ ++ "makes no sense (as there is nothing for it to be "
+ ++ "relative to). You can make paths relative to the "
+ ++ "package database itself by using ${pkgroot}."
-- relative paths don't make any sense; #4134
| otherwise = do
- there <- liftIO $ doesDirectoryExist d
+ there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
when (not there) $
- let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
+ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+ ++ if is_dir then "directory" else "file"
in
if warn_only
then vwarn msg
@@ -1320,10 +1444,7 @@ doesFileExistOnPath file path = go path
if b then return (Just p) else go ps
doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
checkModules :: InstalledPackageInfo -> Validate ()
checkModules pkg = do
@@ -1416,6 +1537,8 @@ expandEnvVars str0 force = go str0 ""
= go str (c:acc)
lookupEnvVar :: String -> IO String
+ lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
+ lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
lookupEnvVar nm =
catchIO (System.Environment.getEnv nm)
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
@@ -1487,16 +1610,17 @@ getExecDir cmd =
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getLibDir :: IO (Maybe String)
getLibDir = return Nothing
@@ -1628,3 +1752,6 @@ removeFileSafe :: FilePath -> IO ()
removeFileSafe fn =
removeFile fn `catchIO` \ e ->
when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
diff --git a/utils/ghc-pwd/ghc.mk b/utils/ghc-pwd/ghc.mk
index 29f74e86b6109f90183021c31d5be74fc9f89818..5efe3b8fdf86974fe720fa588c7b97d00b40eae1 100644
--- a/utils/ghc-pwd/ghc.mk
+++ b/utils/ghc-pwd/ghc.mk
@@ -1,7 +1,7 @@
utils/ghc-pwd_USES_CABAL = YES
utils/ghc-pwd_PACKAGE = ghc-pwd
-utils/ghc-pwd_dist_PROG = ghc-pwd$(exeext)
+utils/ghc-pwd_dist-install_PROG = ghc-pwd$(exeext)
-$(eval $(call build-prog,utils/ghc-pwd,dist,1))
+$(eval $(call build-prog,utils/ghc-pwd,dist-install,1))
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index a25537ee990bbbea39e815fc0315b7df87ad7ce3..c86a92a226154ba5628e631e4ce2aebc1824057f 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -10,6 +10,7 @@ import DriverPhases ( isHaskellSrcFilename )
import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
+import Panic ( panic )
import DynFlags ( defaultDynFlags )
import Bag
import Exception
@@ -100,7 +101,7 @@ main = do
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
- GHC.defaultErrorHandler defaultDynFlags $
+ GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
@@ -292,7 +293,6 @@ boundThings modname lbinding =
LitPat _ -> tl
NPat _ _ _ -> tl -- form of literal pattern?
NPlusKPat id _ _ _ -> thing id : tl
- TypePat _ -> tl -- XXX need help here
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
_ -> error "boundThings"
diff --git a/utils/ghctags/ghc.mk b/utils/ghctags/ghc.mk
index 7bf8a7390c83934e0124ee6aae160f0f81d76448..73a520157c7d7dec1d962fd8f16eb791e5cde7ac 100644
--- a/utils/ghctags/ghc.mk
+++ b/utils/ghctags/ghc.mk
@@ -10,8 +10,8 @@
#
# -----------------------------------------------------------------------------
-utils/ghctags_dist_MODULES = Main
-utils/ghctags_dist_HC_OPTS = -package ghc
-utils/ghctags_dist_INSTALL = NO
-utils/ghctags_dist_PROG = ghctags$(exeext)
-$(eval $(call build-prog,utils/ghctags,dist,2))
+utils/ghctags_dist-install_MODULES = Main
+utils/ghctags_dist-install_HC_OPTS = -package ghc
+utils/ghctags_dist-install_INSTALL = NO
+utils/ghctags_dist-install_PROG = ghctags$(exeext)
+$(eval $(call build-prog,utils/ghctags,dist-install,2))
diff --git a/utils/hpc/ghc.mk b/utils/hpc/ghc.mk
index 164dacffb81932d6da142cbfe47b937dc6d08533..9a8f8ad54ed8f26f418c476d4ffc791fec462378 100644
--- a/utils/hpc/ghc.mk
+++ b/utils/hpc/ghc.mk
@@ -10,10 +10,10 @@
#
# -----------------------------------------------------------------------------
-utils/hpc_dist_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer \
+utils/hpc_dist-install_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer \
HpcMarkup HpcOverlay HpcParser HpcReport \
HpcShowTix HpcUtils
-utils/hpc_dist_HC_OPTS = -cpp -package hpc
-utils/hpc_dist_INSTALL = YES
-utils/hpc_dist_PROG = hpc$(exeext)
-$(eval $(call build-prog,utils/hpc,dist,1))
+utils/hpc_dist-install_HC_OPTS = -cpp -package hpc
+utils/hpc_dist-install_INSTALL = YES
+utils/hpc_dist-install_PROG = hpc$(exeext)
+$(eval $(call build-prog,utils/hpc,dist-install,1))
diff --git a/utils/runghc/ghc.mk b/utils/runghc/ghc.mk
index 26c3b312280a9b9504ec0f34fbca16ec12fc10ad..7c6a34a19018e948a0f482dbf7e17ea124cb3f4d 100644
--- a/utils/runghc/ghc.mk
+++ b/utils/runghc/ghc.mk
@@ -11,19 +11,19 @@
# -----------------------------------------------------------------------------
utils/runghc_PACKAGE = runghc
-utils/runghc_dist_USES_CABAL = YES
-utils/runghc_dist_PROG = runghc$(exeext)
-utils/runghc_dist_SHELL_WRAPPER = YES
-utils/runghc_dist_INSTALL_SHELL_WRAPPER = YES
-utils/runghc_dist_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\""
+utils/runghc_dist-install_USES_CABAL = YES
+utils/runghc_dist-install_PROG = runghc$(exeext)
+utils/runghc_dist-install_SHELL_WRAPPER = YES
+utils/runghc_dist-install_INSTALL_SHELL_WRAPPER = YES
+utils/runghc_dist-install_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\""
ifneq "$(BINDIST)" "YES"
# hack: the build system has trouble with Main modules not called Main.hs
-utils/runghc/dist/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/.
+utils/runghc/dist-install/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/.
"$(CP)" $< $@
endif
-$(eval $(call build-prog,utils/runghc,dist,1))
+$(eval $(call build-prog,utils/runghc,dist-install,1))
install: install_runhaskell
diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index ab495132cd85fe27096f92112f839b5180385444..4424c96096332d4c594d73c008f19ffe842d1ef3 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -149,15 +149,17 @@ dieProg msg = do
getExecPath :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecPath = return Nothing
#endif
diff --git a/validate b/validate
index 8d6e2c3043a9aac3233cc0ab4604c59ba493065e..3ca888fba149584b339f8d1618456a01a91e5c8a 100755
--- a/validate
+++ b/validate
@@ -73,7 +73,7 @@ if [ $no_clean -eq 0 ]; then
INSTDIR=`cygpath -m "$INSTDIR"`
fi
- /usr/bin/perl -w boot --required-tag=dph
+ /usr/bin/perl -w boot --validate --required-tag=dph
./configure --prefix="$INSTDIR" $config_args
fi
@@ -86,6 +86,21 @@ $make -j$threads ValidateHpc=$hpc ValidateSlow=$slow
$make binary-dist-prep
$make test_bindist TEST_PREP=YES
+#
+# Install the mtl package into the bindist, because it is used by some
+# tests. It isn't essential that we do this (the failing tests will
+# be treated as expected failures), but we get a bit more test
+# coverage, and also verify that we can install a package into the
+# bindist with Cabal.
+#
+bindistdir="bindisttest/install dir"
+cd libraries/mtl
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir"
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean --builddir=dist-bindist
+cd $thisdir
+
fi # testsuite-only
if [ "$hpc" = YES ]