merge GHC HEAD
authorAdam Megacz <adam@megacz.com>
Tue, 31 May 2011 02:34:22 +0000 (19:34 -0700)
committerAdam Megacz <adam@megacz.com>
Tue, 31 May 2011 02:34:22 +0000 (19:34 -0700)
292 files changed:
MAKEHELP
Makefile
aclocal.m4
boot
boot-pkgs [deleted file]
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/Id.lhs
compiler/basicTypes/IdInfo.lhs
compiler/basicTypes/IdInfo.lhs-boot
compiler/basicTypes/MkId.lhs
compiler/basicTypes/Module.lhs
compiler/basicTypes/NameSet.lhs
compiler/basicTypes/OccName.lhs
compiler/basicTypes/Var.lhs
compiler/basicTypes/VarEnv.lhs
compiler/basicTypes/VarSet.lhs
compiler/cmm/CLabel.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmNode.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmStackLayout.hs
compiler/cmm/OldCmm.hs
compiler/cmm/PprC.hs
compiler/cmm/cmm-notes
compiler/codeGen/CgPrimOp.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CorePrep.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreTidy.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/ExternalCore.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/coreSyn/PprExternalCore.lhs
compiler/deSugar/Check.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsGRHSs.lhs
compiler/deSugar/DsListComp.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/deSugar/MatchLit.lhs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeFFI.lhs [deleted file]
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/ByteCodeInstr.lhs
compiler/ghci/ObjLink.lhs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsLit.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/llvmGen/LlvmCodeGen/Ppr.hs
compiler/llvmGen/LlvmMangler.hs
compiler/main/CmdLineParser.hs
compiler/main/CodeOutput.lhs
compiler/main/DriverMkDepend.hs
compiler/main/DriverPhases.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/ErrUtils.lhs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/GhcMonad.hs
compiler/main/HscMain.lhs
compiler/main/HscStats.lhs
compiler/main/HscTypes.lhs
compiler/main/Packages.lhs
compiler/main/PprTyThing.hs
compiler/main/StaticFlags.hs
compiler/main/SysTools.lhs
compiler/main/TidyPgm.lhs
compiler/nativeGen/Alpha/CodeGen.hs [deleted file]
compiler/nativeGen/Alpha/Instr.hs [deleted file]
compiler/nativeGen/Alpha/Ppr.hs-old [deleted file]
compiler/nativeGen/Alpha/RegInfo.hs [deleted file]
compiler/nativeGen/Alpha/Regs.hs [deleted file]
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/PPC/RegInfo.hs
compiler/nativeGen/PPC/Regs.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/SPARC/Instr.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/SPARC/ShortcutJump.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/nativeGen/X86/Regs.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/ForeignCall.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/PrimOp.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/prelude/primops.txt.pp
compiler/rename/RnBinds.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/simplCore/CSE.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/FloatOut.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SAT.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Rules.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stgSyn/CoreToStg.lhs
compiler/stgSyn/StgSyn.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WorkWrap.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcUnify.lhs-boot
compiler/types/Class.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/FunDeps.lhs
compiler/types/Generics.lhs
compiler/types/InstEnv.lhs
compiler/types/Kind.lhs [new file with mode: 0644]
compiler/types/OptCoercion.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/types/TypeRep.lhs-boot
compiler/types/Unify.lhs
compiler/utils/Outputable.lhs
compiler/utils/Pair.lhs [new file with mode: 0644]
compiler/utils/Platform.hs [moved from compiler/nativeGen/Platform.hs with 95% similarity]
compiler/utils/Pretty.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Builtins/Modules.hs
compiler/vectorise/Vectorise/Builtins/Prelude.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/PData.hs
compiler/vectorise/Vectorise/Type/PRepr.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Type/Type.hs
compiler/vectorise/Vectorise/Utils.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/Closure.hs
compiler/vectorise/Vectorise/Utils/Hoisting.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
compiler/vectorise/Vectorise/Utils/Poly.hs
compiler/vectorise/Vectorise/Var.hs
configure.ac
docs/users_guide/debugging.xml
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml
docs/users_guide/shared_libs.xml
docs/users_guide/using.xml
docs/users_guide/win32-dlls.xml
ghc.spec.in
ghc/GhciTags.hs
ghc/InteractiveUI.hs
ghc/ghc.wrapper
includes/Cmm.h
includes/Rts.h
includes/rts/EventLogFormat.h
includes/rts/Flags.h
includes/rts/storage/GC.h
includes/stg/MachRegs.h
includes/stg/SMP.h
mk/build.mk.sample
mk/config.mk.in
mk/validate-settings.mk
rts/Capability.c
rts/Capability.h
rts/GetEnv.h [new file with mode: 0644]
rts/Linker.c
rts/PrimOps.cmm
rts/ProfHeap.c
rts/RetainerSet.c
rts/RetainerSet.h
rts/RtsFlags.c
rts/RtsFlags.h
rts/RtsProbes.d
rts/RtsStartup.c
rts/Schedule.c
rts/Stats.c
rts/Trace.c
rts/Trace.h
rts/eventlog/EventLog.c
rts/eventlog/EventLog.h
rts/ghc.mk
rts/posix/GetEnv.c [new file with mode: 0644]
rts/sm/GC.c
rts/win32/GetEnv.c [new file with mode: 0644]
rules/build-package-data.mk
rules/build-package-way.mk
rules/c-suffix-rules.mk
rules/distdir-way-opts.mk
rules/package-config.mk
rules/shell-wrapper.mk
settings.in
sync-all
utils/Makefile
utils/fingerprint/fingerprint.py [new file with mode: 0755]
utils/genprimopcode/Lexer.x
utils/genprimopcode/Main.hs
utils/genprimopcode/Parser.y
utils/genprimopcode/ParserM.hs
utils/genprimopcode/Syntax.hs
utils/ghc-cabal/Main.hs
utils/ghc-pkg/Main.hs
utils/ghctags/Main.hs
utils/runghc/runghc.hs
validate

index 85497e9..c14767f 100644 (file)
--- 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)
index 1a23e2e..0929f28 100644 (file)
--- 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:
index 4b750ef..c7aba3e 100644 (file)
@@ -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.
@@ -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,7 +655,7 @@ 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
@@ -1016,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
diff --git a/boot b/boot
index 66bff3e..0b67b17 100755 (executable)
--- a/boot
+++ b/boot
@@ -3,13 +3,19 @@
 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;
 
@@ -24,7 +30,7 @@ while ($#ARGV ne -1) {
     }
 }
 
-{
+sub sanity_check_line_endings {
     local $/ = undef;
     open FILE, "packages" or die "Couldn't open file: $!";
     binmode FILE;
@@ -42,59 +48,168 @@ EOF
     }
 }
 
-# Create libraries/*/{ghc.mk,GNUmakefile}
-system("/usr/bin/perl", "-w", "boot-pkgs") == 0
-    or die "Running boot-pkgs failed: $?";
+sub sanity_check_tree {
+    my $tag;
+    my $dir;
 
-my $tag;
-my $dir;
-my $curdir;
+    # 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;
+}
 
-$curdir = &cwd()
-    or die "Can't find current directory: $!";
+# Create libraries/*/{ghc.mk,GNUmakefile}
+sub boot_pkgs {
+    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";
+        }
 
-# Check that we have all boot packages.
-open PACKAGES, "< packages";
-while (<PACKAGES>) {
-    if (/^#/) {
-        # Comment; do nothing
+        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: $!";
+        }
     }
 }
 
-if ($validate eq 0 && ! -f "mk/build.mk") {
-    print <<EOF;
+sub checkBuildMk {
+    if ($validate eq 0 && ! -f "mk/build.mk") {
+        print <<EOF;
 
 WARNING: You don't have a mk/build.mk file.
 
@@ -107,5 +222,12 @@ 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 (file)
index de3008c..0000000
--- 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: $!";
-        }
-    }
-}
-
index f077882..7ea66e1 100644 (file)
@@ -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}
index 5a62326..312ae94 100644 (file)
@@ -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}
index fd65fe4..5ac2612 100644 (file)
@@ -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.
@@ -448,6 +447,26 @@ isTickBoxOp_maybe id =
 
 %************************************************************************
 %*                                                                     *
+              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}
 %*                                                                     *
 %************************************************************************
index ec1f122..c106f53 100644 (file)
@@ -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
 
index 4195156..257e1c6 100644 (file)
@@ -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
index 5aebd37..c691f62 100644 (file)
@@ -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}
 
 
index 03f541e..89b3edd 100644 (file)
@@ -73,7 +73,6 @@ module Module
 
 import Config
 import Outputable
-import qualified Pretty
 import Unique
 import UniqFM
 import FastString
@@ -253,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
index a20d8ab..bef9e92 100644 (file)
@@ -181,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
@@ -189,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)
index bae5419..5b5f620 100644 (file)
@@ -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,
@@ -555,9 +556,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,
@@ -569,6 +571,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
@@ -587,10 +590,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
index bca185f..3c3ff7f 100644 (file)
@@ -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
@@ -188,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
@@ -269,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
@@ -295,36 +282,6 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details }
 
 %************************************************************************
 %*                                                                     *
-\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}
 %*                                                                     *
 %************************************************************************
@@ -348,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 
@@ -393,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
index f275714..fca6256 100644 (file)
@@ -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
index 6f03aad..e0ff52d 100644 (file)
@@ -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
index a7dabc6..1ba1126 100644 (file)
@@ -101,7 +101,7 @@ module CLabel (
         hasCAF,
        infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
        needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
-        isMathFun, isCas,
+        isMathFun,
        isCFunctionLabel, isGcPtrLabel, labelDynamic,
 
        pprCLabel
@@ -594,14 +594,6 @@ maybeAsmTemp (AsmTempLabel uq)             = Just uq
 maybeAsmTemp _                                 = Nothing
 
 
--- | Check whether a label corresponds to our cas function.
---      We #include the prototype for this, so we need to avoid
---      generating out own C prototypes.
-isCas :: CLabel -> Bool
-isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas"
-isCas _                     = False
-
-
 -- | 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 avoid generating our
@@ -862,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
@@ -871,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
index 54b4b11..a6b215b 100644 (file)
@@ -11,7 +11,7 @@
 module Cmm
   ( CmmGraph, GenCmmGraph(..), CmmBlock
   , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
-  , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+  , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
 
   , modifyGraph
   , lastNode, replaceLastNode, insertBetween
@@ -46,7 +46,8 @@ 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
 
index b9f6db3..35eabb3 100644 (file)
@@ -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.
index 55a5b73..869bc1b 100644 (file)
@@ -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
index c14ad65..32fead3 100644 (file)
@@ -153,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))
 
index e67321c..7d50d9a 100644 (file)
@@ -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 :(
index c71f188..a2eecd5 100644 (file)
@@ -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
index 8c2498e..0ee429d 100644 (file)
@@ -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
 
index d0d54d9..fbe979b 100644 (file)
@@ -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
index 17364ad..2dcfb02 100644 (file)
@@ -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
index 01543c4..c0fb6af 100644 (file)
@@ -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]
index 57d458c..f5c0817 100644 (file)
@@ -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
 
index d363cef..aa7d914 100644 (file)
@@ -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
@@ -248,7 +244,7 @@ pprStmt stmt = case stmt of
                 | CmmNeverReturns <- ret ->
                     let myCall = pprCall (pprCLabel lbl) cconv results args safety
                     in (real_fun_proto lbl, myCall)
-                | not (isMathFun lbl || isCas lbl) ->
+                | not (isMathFun lbl) ->
                     let myCall = braces (
                                      pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
                                   $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
@@ -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
index 0852711..c0ccadf 100644 (file)
@@ -1,3 +1,7 @@
+More notes (May 11)\r
+~~~~~~~~~~~~~~~~~~~\r
+In CmmNode, consider spliting CmmCall into two: call and jump\r
+\r
 Notes on new codegen (Aug 10)\r
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r
 \r
@@ -15,14 +19,11 @@ Things to do:
        This will fix the spill before stack check problem but only really as a side\r
        effect. A 'real fix' probably requires making the spiller know about sp checks.\r
 \r
- - There is some silly stuff happening with the Sp. We end up with code like:\r
-   Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8\r
-       Seems to be perhaps caused by the issue above but also maybe a optimisation\r
-       pass needed?\r
+   EZY: I don't understand this comment. David Terei, can you clarify?\r
 \r
- - Proc pass all arguments on the stack, adding more code and slowing down things\r
-   a lot. We either need to fix this or even better would be to get rid of\r
-       proc points.\r
+ - Proc points pass all arguments on the stack, adding more code and\r
+   slowing down things a lot. We either need to fix this or even better\r
+   would be to get rid of proc points.\r
 \r
  - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to\r
    Old.Cmm. We should abstract it to work on both representations, it needs only to\r
@@ -32,7 +33,7 @@ Things to do:
    we could convert codeGen/StgCmm* clients to the Hoopl's semantics?\r
    It's all deeply unsatisfactory.\r
 \r
- - Improve preformance of Hoopl.\r
+ - Improve performance of Hoopl.\r
 \r
    A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters\r
    (using the same ghc-cmm branch +libraries compiled by the old codegenerator)\r
@@ -50,6 +51,9 @@ Things to do:
 \r
    So we generate a bit better code, but it takes us longer!\r
 \r
+   EZY: Also importantly, Hoopl uses dramatically more memory than the\r
+   old code generator.\r
+\r
  - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could\r
    splice blocks instead?\r
 \r
@@ -57,7 +61,7 @@ Things to do:
    a block catenation function would be probably nicer than blockToNodeList\r
    / blockOfNodeList combo.\r
 \r
- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
    delete splitEntrySeq from HooplUtils.\r
 \r
  - manifestSP seems to touch a lot of the graph representation. It is\r
@@ -76,6 +80,9 @@ Things to do:
    calling convention, and the code for calling foreign calls is generated\r
 \r
  - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline\r
+   EZY (2011-04-16): The mini-inliner has been generalized and ported,\r
+   but the constant folding and other optimizations need to still be\r
+   ported.\r
 \r
  - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);\r
    we ultimately want to share this with the Cmm branch eliminator.\r
@@ -113,7 +120,7 @@ Things to do:
  - See "CAFs" below; we want to totally refactor the way SRTs are calculated\r
 \r
  - Pull out Areas into its own module\r
-   Parameterise AreaMap\r
+   Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)\r
    Add ByteWidth = Int\r
    type SubArea    = (Area, ByteOff, ByteWidth) \r
    ByteOff should not be defined in SMRep -- that is too high up the hierarchy\r
@@ -293,8 +300,8 @@ cpsTop:
        insert spills/reloads across \r
           LastCalls, and \r
           Branches to proc-points\r
-     Now sink those reloads:\r
-     - CmmSpillReload.insertLateReloads\r
+     Now sink those reloads (and other instructions):\r
+     - CmmSpillReload.rewriteAssignments\r
      - CmmSpillReload.removeDeadAssignmentsAndReloads\r
 \r
   * CmmStackLayout.stubSlotsOnDeath\r
@@ -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.)\r
 \r
 Furthermore, there is *no way* to pass q to J in a register (other\r
-than a paramter register).\r
+than a parameter register).\r
 \r
 What we want is to do register allocation across the whole caboodle.\r
 Then we could drop all the code that deals with the above awkward\r
index fd440e9..c5a6644 100644 (file)
@@ -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
@@ -205,6 +209,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
@@ -618,3 +635,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))
index 922d330..63d99a6 100644 (file)
@@ -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,18 @@ assignTemp e
                            ; stmtC (CmmAssign (CmmLocal reg) e)
                            ; return (CmmReg (CmmLocal reg)) }
 
+-- | If the expression is trivial and doesn't refer to a global
+-- register, return it.  Otherwise, assign the expression to a
+-- temporary register and return an expression referring to this
+-- register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e
+    | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
+    | otherwise = 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) }
 
index 48416e3..d917811 100644 (file)
@@ -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
index 678c961..0fa1c38 100644 (file)
@@ -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
index af414f7..88509f9 100644 (file)
@@ -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}
 
index 5cc82a2..869f276 100644 (file)
@@ -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))]
+
index 42379b4..0405716 100644 (file)
@@ -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)
   
 
index a229b8c..047e6c3 100644 (file)
@@ -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
 
+
index 603b745..e754c6d 100644 (file)
@@ -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)
index 582f873..377bfd8 100644 (file)
@@ -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])
index d1b9fa0..051e767 100644 (file)
@@ -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 
-