From: Adam Megacz <adam@megacz.com>
Date: Tue, 31 May 2011 02:34:22 +0000 (-0700)
Subject: merge GHC HEAD
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b2524b3960999fffdb3767900f58825903f6560f;hp=841e81e28f8cc711f624fdca122219a5bbde2fae

merge GHC HEAD
---

diff --git a/MAKEHELP b/MAKEHELP
index 85497e9..c14767f 100644
--- a/MAKEHELP
+++ b/MAKEHELP
@@ -25,12 +25,6 @@ Common commands:
 
      Shows the targets available in <dir>
 
-  make html
-  make pdf
-  make ps
-
-     Make documentation
-
   make install
 
      Installs GHC, libraries and tools under $(prefix)
diff --git a/Makefile b/Makefile
index 1a23e2e..0929f28 100644
--- a/Makefile
+++ b/Makefile
@@ -45,7 +45,7 @@ endif
 include mk/custom-settings.mk
 
 # No need to update makefiles for these targets:
-REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS))
+REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS))
 
 # configure touches certain files even if they haven't changed.  This
 # can mean a lot of unnecessary recompilation after a re-configure, so
@@ -102,12 +102,6 @@ framework-pkg:
 	$(MAKE) -C distrib/MacOS $@
 endif
 
-# install-docs is a historical target that isn't supported in GHC 6.12. See #3662.
-install-docs:
-	@echo "The install-docs target is not supported in GHC 6.12.1 and later."
-	@echo "'make install' now installs everything, including documentation."
-	@exit 1
-
 # If the user says 'make A B', then we don't want to invoke two
 # instances of the rule above in parallel:
 .NOTPARALLEL:
diff --git a/aclocal.m4 b/aclocal.m4
index 4b750ef..c7aba3e 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -105,6 +105,21 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
         $4="$$4 -arch x86_64"
         $5="$$5 -m64"
         ;;
+    alpha-*)
+        # For now, to suppress the gcc warning "call-clobbered
+        # register used for global register variable", we simply
+        # disable all warnings altogether using the -w flag. Oh well.
+        $2="$$2 -w -mieee -D_REENTRANT"
+        $3="$$3 -w -mieee -D_REENTRANT"
+        $5="$$5 -w -mieee -D_REENTRANT"
+        ;;
+    hppa*)
+        # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
+        # (very nice, but too bad the HP /usr/include files don't agree.)
+        $2="$$2 -D_HPUX_SOURCE"
+        $3="$$3 -D_HPUX_SOURCE"
+        $5="$$5 -D_HPUX_SOURCE"
+        ;;
     esac
 
     # If gcc knows about the stack protector, turn it off.
@@ -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
--- 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
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: $!";
-        }
-    }
-}
-
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index f077882..7ea66e1 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -72,13 +72,16 @@ module BasicTypes(
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
-	SuccessFlag(..), succeeded, failed, successIf
+	SuccessFlag(..), succeeded, failed, successIf,
+	
+	FractionalLit(..), negateFractionalLit, integralFractionalLit
    ) where
 
 import FastString
 import Outputable
 
 import Data.Data hiding (Fixity)
+import Data.Function (on)
 \end{code}
 
 %************************************************************************
@@ -862,3 +865,36 @@ isEarlyActive (ActiveBefore {}) = True
 isEarlyActive _		        = False
 \end{code}
 
+
+
+\begin{code}
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+  = FL { fl_text :: String         -- How the value was written in the source
+       , fl_value :: Rational      -- Numeric value of the literal
+       }
+  deriving (Data, Typeable, Show)
+  -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
+
+negateFractionalLit :: FractionalLit -> FractionalLit
+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+
+integralFractionalLit :: Integer -> FractionalLit
+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+  (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+  compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+  ppr = text . fl_text
+\end{code}
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 5a62326..312ae94 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -18,7 +18,7 @@ module DataCon (
 	dataConName, dataConIdentity, dataConTag, dataConTyCon, 
         dataConOrigTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, 
-	dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+	dataConEqSpec, eqSpecPreds, dataConTheta,
 	dataConStupidTheta,  
 	dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
@@ -31,7 +31,7 @@ module DataCon (
 	
 	-- ** Predicates on DataCons
 	isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
-	isVanillaDataCon, classDataCon, 
+	isVanillaDataCon, classDataCon, dataConCannotMatch,
 
         -- * Splitting product types
 	splitProductType_maybe, splitProductType, deepSplitProductType,
@@ -41,6 +41,7 @@ module DataCon (
 #include "HsVersions.h"
 
 import Type
+import Unify
 import Coercion
 import TyCon
 import Class
@@ -57,7 +58,6 @@ import Module
 import qualified Data.Data as Data
 import Data.Char
 import Data.Word
-import Data.List ( partition )
 \end{code}
 
 
@@ -256,8 +256,7 @@ data DataCon
 	--	dcUnivTyVars  = [a]
 	--	dcExTyVars    = [x,y]
 	--	dcEqSpec      = [a~(x,y)]
-	--	dcEqTheta     = [x~y]	
-	--	dcDictTheta   = [Ord x]
+	--	dcOtherTheta  = [x~y, Ord x]	
 	--	dcOrigArgTys  = [a,List b]
 	--	dcRepTyCon       = T
 
@@ -265,7 +264,7 @@ data DataCon
 				--	    Its type is of form
 				--	        forall a1..an . t1 -> ... tm -> T a1..an
 				-- 	    No existentials, no coercions, nothing.
-				-- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
+				-- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
 		-- NB 1: newtypes always have a vanilla data con
 		-- NB 2: a vanilla constructor can still be declared in GADT-style 
 		--	 syntax, provided its type looks like the above.
@@ -300,8 +299,8 @@ data DataCon
 		-- In GADT form, this is *exactly* what the programmer writes, even if
 		-- the context constrains only universally quantified variables
 		--	MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
-	dcEqTheta   :: ThetaType,  -- The *equational* constraints
-	dcDictTheta :: ThetaType,  -- The *type-class and implicit-param* constraints
+	dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type
+		                    -- other than those in the dcEqSpec
 
 	dcStupidTheta :: ThetaType,	-- The context of the data type declaration 
 					--	data Eq a => T a = ...
@@ -338,9 +337,9 @@ data DataCon
 		-- length = 0 (if not a record) or dataConSourceArity.
 
 	-- Constructor representation
-	dcRepArgTys :: [Type],		-- Final, representation argument types, 
-					-- after unboxing and flattening,
-					-- and *including* existential dictionaries
+	dcRepArgTys :: [Type],	-- Final, representation argument types, 
+				-- after unboxing and flattening,
+				-- and *including* all existential evidence args
 
 	dcRepStrictness :: [StrictnessMark],
                 -- One for each *representation* *value* argument
@@ -519,8 +518,8 @@ mkDataCon name declared_infix
 		  dcVanilla = is_vanilla, dcInfix = declared_infix,
 	  	  dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
 		  dcEqSpec = eq_spec, 
+		  dcOtherTheta = theta,
 		  dcStupidTheta = stupid_theta, 
-		  dcEqTheta = eq_theta, dcDictTheta = dict_theta,
 		  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
 		  dcRepTyCon = rep_tycon, 
 		  dcRepArgTys = rep_arg_tys,
@@ -536,10 +535,9 @@ mkDataCon name declared_infix
 	-- The 'arg_stricts' passed to mkDataCon are simply those for the
 	-- source-language arguments.  We add extra ones for the
 	-- dictionary arguments right here.
-    (eq_theta,dict_theta)  = partition isEqPred theta
-    dict_tys     	   = mkPredTys dict_theta
-    real_arg_tys 	   = dict_tys ++ orig_arg_tys
-    real_stricts 	   = map mk_dict_strict_mark dict_theta ++ arg_stricts
+    full_theta   = eqSpecPreds eq_spec ++ theta
+    real_arg_tys = mkPredTys full_theta               ++ orig_arg_tys
+    real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
 
 	-- Representation arguments and demands
 	-- To do: eliminate duplication with MkId
@@ -547,11 +545,6 @@ mkDataCon name declared_infix
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
-	  mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
-	  mkFunTys (mkPredTys eq_theta) $
-		-- NB:	the dict args are already in rep_arg_tys
-		--	because they might be flattened..
-		--	but the equality predicates are not
 	  mkFunTys rep_arg_tys $
 	  mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
@@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
 dataConEqSpec :: DataCon -> [(TyVar,Type)]
 dataConEqSpec = dcEqSpec
 
--- | The equational constraints on the data constructor type
-dataConEqTheta :: DataCon -> ThetaType
-dataConEqTheta = dcEqTheta
-
--- | The type class and implicit parameter contsraints on the data constructor type
-dataConDictTheta :: DataCon -> ThetaType
-dataConDictTheta = dcDictTheta
+-- | The *full* constraints on the constructor type
+dataConTheta :: DataCon -> ThetaType
+dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) 
+  = eqSpecPreds eq_spec ++ theta
 
 -- | Get the Id of the 'DataCon' worker: a function that is the "actual"
 -- constructor and has no top level binding in the program. The type may
@@ -666,10 +656,10 @@ dataConFieldType con label
 dataConStrictMarks :: DataCon -> [HsBang]
 dataConStrictMarks = dcStrictMarks
 
--- | Strictness of /existential/ arguments only
+-- | Strictness of evidence arguments to the wrapper function
 dataConExStricts :: DataCon -> [HsBang]
 -- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
+dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc)
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
@@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc
 --
 -- 4) The /original/ result type of the 'DataCon'
 dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
-dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-		    dcEqTheta  = eq_theta, dcDictTheta = dict_theta, 
+dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
+		    dcEqSpec = eq_spec, dcOtherTheta  = theta, 
 		    dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
+  = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
 
 -- | The \"full signature\" of the 'DataCon' returns, in order:
 --
@@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_
 --
 -- 6) The original result type of the 'DataCon'
 dataConFullSig :: DataCon 
-	       -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-			dcEqTheta = eq_theta, dcDictTheta = dict_theta, 
+	       -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
+			dcEqSpec = eq_spec, dcOtherTheta = theta,
 			dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
+  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
 
 dataConOrigResTy :: DataCon -> Type
 dataConOrigResTy dc = dcOrigResTy dc
@@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type
 -- mentions the family tycon, not the internal one.
 dataConUserType  (MkData { dcUnivTyVars = univ_tvs, 
 			   dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-			   dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
+			   dcOtherTheta = theta, dcOrigArgTys = arg_tys,
 			   dcOrigResTy = res_ty })
   = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
-    mkFunTys (mkPredTys eq_theta) $
-    mkFunTys (mkPredTys dict_theta) $
+    mkFunTys (mkPredTys theta) $
     mkFunTys arg_tys $
     res_ty
 
@@ -841,6 +830,25 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
 		      [] -> panic "classDataCon"
 \end{code}
 
+\begin{code}
+dataConCannotMatch :: [Type] -> DataCon -> Bool
+-- Returns True iff the data con *definitely cannot* match a 
+--		    scrutinee of type (T tys)
+--		    where T is the type constructor for the data con
+-- NB: look at *all* equality constraints, not only those
+--     in dataConEqSpec; see Trac #5168
+dataConCannotMatch tys con
+  | null theta        = False	-- Common
+  | all isTyVarTy tys = False	-- Also common
+  | otherwise
+  = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
+                   | EqPred ty1 ty2 <- theta ]
+  where
+    dc_tvs  = dataConUnivTyVars con
+    theta   = dataConTheta con
+    subst   = zipTopTvSubst dc_tvs tys
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Splitting products}
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index fd65fe4..5ac2612 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -23,7 +23,7 @@
 -- * 'Var.Var': see "Var#name_types"
 module Id (
         -- * The main types
-	Id, DictId,
+	Var, Id, isId,
 
 	-- ** Simple construction
 	mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
@@ -34,8 +34,7 @@ module Id (
 
 	-- ** Taking an Id apart
 	idName, idType, idUnique, idInfo, idDetails,
-	isId, idPrimRep,
-	recordSelectorFieldLabel,
+	idPrimRep, recordSelectorFieldLabel,
 
 	-- ** Modifying an Id
 	setIdName, setIdUnique, Id.setIdType, 
@@ -46,7 +45,8 @@ module Id (
 	
 
 	-- ** Predicates on Ids
-	isImplicitId, isDeadBinder, isDictId, isStrictId,
+	isImplicitId, isDeadBinder, 
+        isStrictId,
 	isExportedId, isLocalId, isGlobalId,
 	isRecordSelector, isNaughtyRecordSelector,
         isClassOpId_maybe, isDFunId, dfunNSilent,
@@ -57,6 +57,9 @@ module Id (
         isTickBoxOp, isTickBoxOp_maybe,
 	hasNoBinding, 
 
+	-- ** Evidence variables
+	DictId, isDictId, isEvVar, evVarPred,
+
 	-- ** Inline pragma stuff
 	idInlinePragma, setInlinePragma, modifyInlinePragma,
         idInlineActivation, setInlineActivation, idRuleMatchInfo,
@@ -95,8 +98,8 @@ import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 
-import Var( Var, Id, DictId,
-            idInfo, idDetails, globaliseId,
+import Var( Var, Id, DictId, EvVar,
+            idInfo, idDetails, globaliseId, varType,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
 
@@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon
 -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
 idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
 
-
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
-
 hasNoBinding :: Id -> Bool
 -- ^ Returns @True@ of an 'Id' which may not have a
 -- binding, even though it is defined in this module.
@@ -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}
 %*									*
 %************************************************************************
diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index ec1f122..c106f53 100644
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
 \begin{code}
 module IdInfo (
         -- * The IdDetails type
-	IdDetails(..), pprIdDetails,
+	IdDetails(..), pprIdDetails, coVarDetails,
 
         -- * The IdInfo type
 	IdInfo,		-- Abstract
@@ -141,6 +141,9 @@ data IdDetails
        --                  implemented with a newtype, so it might be bad
        --                  to be strict on this dictionary
 
+coVarDetails :: IdDetails
+coVarDetails = VanillaId
+
 instance Outputable IdDetails where
     ppr = pprIdDetails
 
diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot
index 4195156..257e1c6 100644
--- a/compiler/basicTypes/IdInfo.lhs-boot
+++ b/compiler/basicTypes/IdInfo.lhs-boot
@@ -4,5 +4,7 @@ import Outputable
 data IdInfo
 data IdDetails
 
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
 pprIdDetails :: IdDetails -> SDoc
 \end{code}
\ No newline at end of file
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 5aebd37..c691f62 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -13,7 +13,7 @@ have a standard form, namely:
 
 \begin{code}
 module MkId (
-        mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+        mkDictFunId, mkDictFunTy, mkDictSelId,
 
         mkDataConIds,
         mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
@@ -25,13 +25,18 @@ module MkId (
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
-        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
+        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
+        coercionTokenId,
+
+	-- Re-export error Ids
+	module PrelRules
     ) where
 
 #include "HsVersions.h"
 
 import Rules
 import TysPrim
+import TysWiredIn	( unitTy )
 import PrelRules
 import Type
 import Coercion
@@ -48,7 +53,7 @@ import PrimOp
 import ForeignCall
 import DataCon
 import Id
-import Var              ( Var, TyVar, mkCoVar, mkExportedLocalVar )
+import Var              ( mkExportedLocalVar )
 import IdInfo
 import Demand
 import CoreSyn
@@ -56,6 +61,7 @@ import Unique
 import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
+import Pair
 import Outputable
 import FastString
 import ListSetOps
@@ -224,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con
   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 
-     eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
+     other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
     tycon = dataConTyCon data_con       -- The representation TyCon (not family)
 
         ----------- Worker (algebraic data types only) --------------
@@ -287,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con
         -- extra constraints where necessary.
     wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
-    eq_tys   = mkPredTys eq_theta
-    dict_tys = mkPredTys dict_theta
-    wrap_ty  = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
-               mkFunTys orig_arg_tys $ res_ty
-        -- NB: watch out here if you allow user-written equality 
-        --     constraints in data constructor signatures
+    ev_tys      = mkPredTys other_theta
+    wrap_ty     = mkForAllTys wrap_tvs $ 
+                  mkFunTys ev_tys $
+                  mkFunTys orig_arg_tys $ res_ty
 
         ----------- Wrappers for algebraic data types -------------- 
     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
@@ -305,8 +309,9 @@ mkDataConIds wrap_name wkr_name data_con
                     `setStrictnessInfo` Just wrap_sig
 
     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
-    wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
-    arg_dmds = map mk_dmd all_strict_marks
+    wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
+    wrap_stricts = dropList eq_spec all_strict_marks
+    wrap_arg_dmds = map mk_dmd wrap_stricts
     mk_dmd str | isBanged str = evalDmd
                | otherwise    = lazyDmd
         -- The Cpr info can be important inside INLINE rhss, where the
@@ -318,32 +323,26 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
+    wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
     wrap_rhs = mkLams wrap_tvs $ 
-               mkLams eq_args $
-               mkLams dict_args $ mkLams id_args $
+               mkLams ev_args $
+               mkLams id_args $
                foldr mk_case con_app 
-                     (zip (dict_args ++ id_args) all_strict_marks)
+                     (zip (ev_args ++ id_args) wrap_stricts)
                      i3 []
+	     -- The ev_args is the evidence arguments *other than* the eq_spec
+	     -- Because we are going to apply the eq_spec args manually in the
+	     -- wrapper
 
     con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
                           Var wrk_id `mkTyApps`  res_ty_args
                                      `mkVarApps` ex_tvs                 
-                                     -- Equality evidence:
-                                     `mkTyApps`  map snd eq_spec
-                                     `mkVarApps` eq_args
+                                     `mkCoApps`  map (mkReflCo . snd) eq_spec
                                      `mkVarApps` reverse rep_ids
 
-    (dict_args,i2) = mkLocals 1  dict_tys
-    (id_args,i3)   = mkLocals i2 orig_arg_tys
-    wrap_arity     = i3-1
-    (eq_args,_)    = mkCoVarLocals i3 eq_tys
-
-    mkCoVarLocals i []     = ([],i)
-    mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) 
-                                                  (fsLit "dc_co")) x
-                             in (y:ys,j)
+    (ev_args,i2) = mkLocals 1  ev_tys
+    (id_args,i3) = mkLocals i2 orig_arg_tys
+    wrap_arity   = i3-1
 
     mk_case 
            :: (Id, HsBang)      -- Arg, strictness
@@ -458,7 +457,7 @@ mkDictSelId no_unf name clas
     	   	       	 	     occNameFS (getOccName name)
                        , ru_fn    = name
     	               , ru_nargs = n_ty_args + 1
-                       , ru_try   = dictSelRule val_index n_ty_args n_eq_args }
+                       , ru_try   = dictSelRule val_index n_ty_args }
 
         -- The strictness signature is of the form U(AAAVAAAA) -> T
         -- where the V depends on which item we are selecting
@@ -474,8 +473,6 @@ mkDictSelId no_unf name clas
     [data_con] 	   = tyConDataCons tycon
     tyvars     	   = dataConUnivTyVars data_con
     arg_tys    	   = dataConRepArgTys data_con	-- Includes the dictionary superclasses
-    eq_theta   	   = dataConEqTheta data_con
-    n_eq_args      = length eq_theta
 
     -- 'index' is a 0-index into the *value* arguments of the dictionary
     val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
@@ -485,25 +482,23 @@ mkDictSelId no_unf name clas
     pred       	   = mkClassPred clas (mkTyVarTys tyvars)
     dict_id    	   = mkTemplateLocal 1 $ mkPredTy pred
     arg_ids    	   = mkTemplateLocalsNum 2 arg_tys
-    eq_ids     	   = map mkWildEvBinder eq_theta
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
-                                [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+                                [(DataAlt data_con, arg_ids, Var the_arg_id)]
 
-dictSelRule :: Int -> Arity -> Arity 
+dictSelRule :: Int -> Arity 
             -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Tries to persuade the argument to look like a constructor
 -- application, using exprIsConApp_maybe, and then selects
 -- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
-dictSelRule val_index n_ty_args n_eq_args id_unf args
+dictSelRule val_index n_ty_args id_unf args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
-  , let val_args = drop n_eq_args con_args
-  = Just (val_args !! val_index)
+  = Just (con_args !! val_index)
   | otherwise
   = Nothing
 \end{code}
@@ -607,7 +602,7 @@ mkProductBox arg_ids ty
 mkReboxingAlt
   :: [Unique] -- Uniques for the new Ids
   -> DataCon
-  -> [Var]    -- Source-level args, including existential dicts
+  -> [Var]    -- Source-level args, *including* all evidence vars 
   -> CoreExpr -- RHS
   -> CoreAlt
 
@@ -628,15 +623,14 @@ mkReboxingAlt us con args rhs
 
     -- Type variable case
     go (arg:args) stricts us 
-      | isTyCoVar arg
+      | isTyVar arg
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
 
         -- Term variable case
     go (arg:args) (str:stricts) us
       | isMarkedUnboxed str
-      = 
-        let (binds, unpacked_args')        = go args stricts us'
+      = let (binds, unpacked_args')        = go args stricts us'
             (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
         in
             (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
@@ -674,13 +668,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- coercion constructor of the newtype or applied by itself).
 
 wrapNewTypeBody tycon args result_expr
-  = wrapFamInstBody tycon args inner
+  = ASSERT( isNewTyCon tycon )
+    wrapFamInstBody tycon args $
+    mkCoerce (mkSymCo co) result_expr
   where
-    inner
-      | Just co_con <- newTyConCo_maybe tycon
-      = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
-      | otherwise
-      = result_expr
+    co = mkAxInstCo (newTyConCo tycon) args
 
 -- When unwrapping, we do *not* apply any family coercion, because this will
 -- be done via a CoPat by the type checker.  We have to do it this way as
@@ -689,10 +681,8 @@ wrapNewTypeBody tycon args result_expr
 
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
-  | Just co_con <- newTyConCo_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) result_expr
-  | otherwise
-  = result_expr
+  = ASSERT( isNewTyCon tycon )
+    mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -702,14 +692,14 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
+  = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
   | otherwise
   = body
 
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) scrut
+  = mkCoerce (mkAxInstCo co_con args) scrut
   | otherwise
   = scrut
 \end{code}
@@ -826,11 +816,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
 that they aren't discarded by the occurrence analyser.
 
 \begin{code}
-mkDefaultMethodId :: Id		-- Selector Id
-		  -> Name	-- Default method name
-		  -> Id		-- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
 mkDictFunId :: Name      -- Name to use for the dict fun;
             -> [TyVar]
             -> ThetaType
@@ -858,7 +843,7 @@ mkDictFunTy tvs theta clas tys
                               (classSCTheta clas)
                    -- See Note [Silent Superclass Arguments]
     discard pred = isEmptyVarSet (tyVarsOfPred pred)
-                 || any (`tcEqPred` pred) theta
+                 || any (`eqPred` pred) theta
                  -- See the DFun Superclass Invariant in TcInstDcls
 \end{code}
 
@@ -885,12 +870,13 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 
 \begin{code}
-lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
-nullAddrName     = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
-seqName          = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
-realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
-lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
+unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
+nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
+seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
+realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
+lazyIdName        = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
+coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
 \end{code}
 
 \begin{code}
@@ -908,7 +894,7 @@ unsafeCoerceId
                       (mkFunTy argAlphaTy openBetaTy)
     [x] = mkTemplateLocals [argAlphaTy]
     rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $
-          Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy)
+          Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy)
 
 ------------------------------------------------
 nullAddrId :: Id
@@ -944,7 +930,7 @@ seqId = pcMiscPrelId seqName ty info
 match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
     -- See Note [Built-in RULES for seq]
 match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
-  = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
+  = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
                               scrut, expr])
 match_seq_of_cast _ _ = Nothing
 
@@ -1054,6 +1040,12 @@ realWorldPrimId -- :: State# RealWorld
 voidArgId :: Id
 voidArgId       -- :: State# RealWorld
   = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
+
+coercionTokenId :: Id 	      -- :: () ~ ()
+coercionTokenId -- Used to replace Coercion terms when we go to STG
+  = pcMiscPrelId coercionTokenName 
+                 (mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
+                 noCafIdInfo
 \end{code}
 
 
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 03f541e..89b3edd 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -73,7 +73,6 @@ module Module
 
 import Config
 import Outputable
-import qualified Pretty
 import Unique
 import UniqFM
 import FastString
@@ -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
diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index a20d8ab..bef9e92 100644
--- a/compiler/basicTypes/NameSet.lhs
+++ b/compiler/basicTypes/NameSet.lhs
@@ -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)
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index bae5419..5b5f620 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -48,11 +48,12 @@ module OccName (
 
 	-- ** Derived 'OccName's
         isDerivedOccName,
-	mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
+	mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
 	mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
   	mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
  	mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ 	mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
 	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 	mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc,
@@ -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
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index bca185f..3c3ff7f 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -32,7 +32,7 @@
 
 module Var (
         -- * The main data type and synonyms
-	Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
+        Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
 
 	-- ** Taking 'Var's apart
 	varName, varUnique, varType, 
@@ -41,34 +41,25 @@ module Var (
 	setVarName, setVarUnique, setVarType,
 
 	-- ** Constructing, taking apart, modifying 'Id's
-	mkGlobalVar, mkLocalVar, mkExportedLocalVar, 
+	mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
 	idInfo, idDetails,
 	lazySetIdInfo, setIdDetails, globaliseId,
 	setIdExported, setIdNotExported,
 
         -- ** Predicates
-        isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
+        isId, isTyVar, isTcTyVar,
         isLocalVar, isLocalId,
 	isGlobalId, isExportedId,
 	mustHaveLocalBinding,
 
 	-- ** Constructing 'TyVar's
-	mkTyVar, mkTcTyVar, mkWildCoVar,
+	mkTyVar, mkTcTyVar, 
 
 	-- ** Taking 'TyVar's apart
         tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
 
 	-- ** Modifying 'TyVar's
-	setTyVarName, setTyVarUnique, setTyVarKind,
-
-        -- ** Constructing 'CoVar's
-        mkCoVar,
-
-        -- ** Taking 'CoVar's apart
-        coVarName,
-
-        -- ** Modifying 'CoVar's
-        setCoVarUnique, setCoVarName
+	setTyVarName, setTyVarUnique, setTyVarKind
 
     ) where
 
@@ -77,8 +68,7 @@ module Var (
 
 import {-# SOURCE #-}	TypeRep( Type, Kind )
 import {-# SOURCE #-}	TcType( TcTyVarDetails, pprTcTyVarDetails )
-import {-# SOURCE #-}	IdInfo( IdDetails, IdInfo, pprIdDetails )
-import {-# SOURCE #-}	TypeRep( isCoercionKind )
+import {-# SOURCE #-}	IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
 
 import Name hiding (varName)
 import Unique
@@ -100,7 +90,7 @@ import Data.Data
 -- large number of SOURCE imports of Id.hs :-(
 
 \begin{code}
-type EvVar = Var	-- An evidence variable: dictionary or equality constraint
+type EvVar = Var        -- An evidence variable: dictionary or equality constraint
      	       		-- Could be an DictId or a CoVar
 
 type Id     = Var       -- A term-level identifier
@@ -110,9 +100,10 @@ type DictId = EvId	-- A dictionary variable
 type IpId   = EvId      -- A term-level implicit parameter
 
 type TyVar = Var
-type CoVar = TyVar	-- A coercion variable is simply a type 
+type CoVar = Id		-- A coercion variable is simply an Id
 			-- variable of kind @ty1 ~ ty2@. Hence its
 			-- 'varType' is always @PredTy (EqPred t1 t2)@
+type TyCoVar = TyVar    -- Something that is a type OR coercion variable.
 \end{code}
 
 %************************************************************************
@@ -136,8 +127,7 @@ data Var
 	realUnique :: FastInt,		-- Key for fast comparison
 					-- Identical to the Unique in the name,
 					-- cached here for speed
-	varType       :: Kind,          -- ^ The type or kind of the 'Var' in question
-        isCoercionVar :: Bool
+	varType       :: Kind           -- ^ The type or kind of the 'Var' in question
  }
 
   | TcTyVar { 				-- Used only during type inference
@@ -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
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index f275714..fca6256 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module VarEnv (
         -- * Var, Id and TyVar environments (maps)
-	VarEnv, IdEnv, TyVarEnv,
+	VarEnv, IdEnv, TyVarEnv, CoVarEnv,
 	
 	-- ** Manipulating these environments
 	emptyVarEnv, unitVarEnv, mkVarEnv,
@@ -29,7 +29,7 @@ module VarEnv (
 	emptyInScopeSet, mkInScopeSet, delInScopeSet,
 	extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
 	getInScopeVars, lookupInScope, lookupInScope_Directly, 
-        unionInScope, elemInScopeSet, uniqAway, 
+        unionInScope, elemInScopeSet, uniqAway,
 
 	-- * The RnEnv2 type
 	RnEnv2, 
@@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
 type VarEnv elt   = UniqFM elt
 type IdEnv elt    = VarEnv elt
 type TyVarEnv elt = VarEnv elt
+type CoVarEnv elt = VarEnv elt
 
 emptyVarEnv	  :: VarEnv a
 mkVarEnv	  :: [(Var, a)] -> VarEnv a
diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs
index 6f03aad..e0ff52d 100644
--- a/compiler/basicTypes/VarSet.lhs
+++ b/compiler/basicTypes/VarSet.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module VarSet (
         -- * Var, Id and TyVar set types
-	VarSet, IdSet, TyVarSet,
+	VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
 	
 	-- ** Manipulating these sets
 	emptyVarSet, unitVarSet, mkVarSet,
@@ -22,7 +22,7 @@ module VarSet (
 
 #include "HsVersions.h"
 
-import Var      ( Var, TyVar, Id )
+import Var      ( Var, TyVar, CoVar, TyCoVar, Id )
 import Unique
 import UniqSet
 \end{code}
@@ -37,6 +37,8 @@ import UniqSet
 type VarSet       = UniqSet Var
 type IdSet 	  = UniqSet Id
 type TyVarSet	  = UniqSet TyVar
+type TyCoVarSet   = UniqSet TyCoVar
+type CoVarSet     = UniqSet CoVar
 
 emptyVarSet	:: VarSet
 intersectVarSet	:: VarSet -> VarSet -> VarSet
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index a7dabc6..1ba1126 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -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
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 54b4b11..a6b215b 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -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
 
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index b9f6db3..35eabb3 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmCPS (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -66,68 +67,67 @@ mutable reference cells in an 'HscEnv' and are
 global to one compiler session.
 -}
 
+-- EZY: It might be helpful to have an easy way of dumping the "pre"
+-- input for any given phase, besides just turning it all on with
+-- -ddump-cmmz
+
 cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
     do
-       -- Why bother doing it this early?
-       -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
-       --                       (dualLivenessWithInsertion callPPs) g
-       -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-       -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
-       --                   (removeDeadAssignmentsAndReloads callPPs) g
-       dump Opt_D_dump_cmmz "Pre common block elimination" g
-       g <- return $ elimCommonBlocks g
-       dump Opt_D_dump_cmmz "Post common block elimination" g
+       -- Why bother doing these early: dualLivenessWithInsertion,
+       -- insertLateReloads, rewriteAssignments?
 
+       ----------- Eliminate common blocks -------------------
+       g <- return $ elimCommonBlocks g
+       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
        -- Any work storing block Labels must be performed _after_ elimCommonBlocks
 
        ----------- Proc points -------------------
        let callPPs = callProcPoints g
        procPoints <- run $ minimalProcPointSet callPPs g
        g <- run $ addProcPointProtocols callPPs procPoints g
-       dump Opt_D_dump_cmmz "Post Proc Points Added" g
+       dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
 
        ----------- Spills and reloads -------------------
-       g     <- 
-              -- pprTrace "pre Spills" (ppr g) $
-                dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
-                             (dualLivenessWithInsertion procPoints) g
-                    -- Insert spills at defns; reloads at return points
-       g     <-
-              -- pprTrace "pre insertLateReloads" (ppr g) $
-                runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
-       dump Opt_D_dump_cmmz "Post late reloads" g
-       g     <-
-               -- pprTrace "post insertLateReloads" (ppr g) $
-                dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
-                                        (removeDeadAssignmentsAndReloads procPoints) g
-                    -- Remove redundant reloads (and any other redundant asst)
-
-       ----------- Debug only: add code to put zero in dead stack slots----
-       -- Debugging: stubbing slots on death can cause crashes early
-       g <- -- trace "post dead-assign elim" $
-            if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+       g <- run $ dualLivenessWithInsertion procPoints g
+       dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
 
+       ----------- Sink and inline assignments -------------------
+       g <- runOptimization $ rewriteAssignments g
+       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+
+       ----------- Eliminate dead assignments -------------------
+       -- Remove redundant reloads (and any other redundant asst)
+       g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
+       dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
+
+       ----------- Zero dead stack slots (Debug only) ---------------
+       -- Debugging: stubbing slots on death can cause crashes early
+       g <- if opt_StubDeadValues
+                then run $ stubSlotsOnDeath g
+                else return g
+       dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
 
        --------------- Stack layout ----------------
        slotEnv <- run $ liveSlotAnal g
+       let spEntryMap = getSpEntryMap entry_off g
        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints slotEnv entry_off g
+       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 
        ------------  Manifest the stack pointer --------
-       g  <- run $ manifestSP areaMap entry_off g
-       dump Opt_D_dump_cmmz "after manifestSP" g
+       g  <- run $ manifestSP spEntryMap areaMap entry_off g
+       dump Opt_D_dump_cmmz_sp "Post manifestSP" g
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
 
        ------------- Split into separate procedures ------------
        procPointMap  <- run $ procPointAnalysis procPoints g
-       dump Opt_D_dump_cmmz "procpoint map" procPointMap
+       dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
        gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
                                        (CmmProc h l g)
-       mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+       mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
 
        ------------- More CAFs and foreign calls ------------
        cafEnv <- run $ cafAnal g
@@ -135,30 +135,29 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
 
        gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+       mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
 
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
-       let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
-       let gs'' = map (bundleCAFs cafEnv) gs'
-       mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
-       return (localCAFs, gs'')
+       gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
+       mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+       gs <- return $ map (bundleCAFs cafEnv) gs
+       mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+       return (localCAFs, gs)
   where dflags = hsc_dflags hsc_env
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
-        dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+        dump f txt g = do
+            -- ToDo: No easy way of say "dump all the cmmz, *and* split
+            -- them into files."  Also, -ddump-cmmz doesn't play nicely
+            -- with -ddump-to-file, since the headers get omitted.
+            dumpIfSet_dyn dflags f txt (ppr g)
+            when (not (dopt f dflags)) $
+                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
         -- Runs a required transformation/analysis
         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
         -- Runs an optional transformation/analysis (and should
         -- thus be subject to optimization fuel)
         runOptimization = runFuelIO (hsc_OptFuel hsc_env)
 
-        -- pass 'run' or 'runOptimization' for 'r'
-        dual_rewrite r flag txt pass g =
-          do dump flag ("Pre " ++ txt)  g
-             g <- r $ pass g
-             dump flag ("Post " ++ txt) $ g
-             return g
-
 -- This probably belongs in CmmBuildInfoTables?
 -- We're just finishing the job here: once we know what CAFs are defined
 -- in non-static closures, we can build the SRTs.
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 55a5b73..869bc1b 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -4,7 +4,7 @@ module CmmExpr
     , CmmReg(..), cmmRegType
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
-    , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
+    , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
     , VGcPtr(..), vgcFlag 	-- Temporary!
     , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
     , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
@@ -425,7 +425,8 @@ instance Ord GlobalReg where
    compare _ EagerBlackholeInfo = GT
 
 -- convenient aliases
-spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg = CmmGlobal BaseReg
 spReg = CmmGlobal Sp
 hpReg = CmmGlobal Hp
 spLimReg = CmmGlobal SpLim
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index c14ad65..32fead3 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -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))
 
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index e67321c..7d50d9a 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -10,7 +10,7 @@
 module CmmNode
   ( CmmNode(..)
   , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
-  , mapExp, mapExpDeep, foldExp, foldExpDeep
+  , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
   )
 where
 
@@ -30,31 +30,54 @@ import Prelude hiding (succ)
 
 data CmmNode e x where
   CmmEntry :: Label -> CmmNode C O
+
   CmmComment :: FastString -> CmmNode O O
+
   CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O  -- Assign to register
+
   CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O  -- Assign to memory location.  Size is
                                                  -- given by cmmExprType of the rhs.
+
   CmmUnsafeForeignCall ::         -- An unsafe foreign call; see Note [Foreign calls]
+  		       		  -- Like a "fat machine instruction"; can occur
+				  -- in the middle of a block
       ForeignTarget ->            -- call target
       CmmFormals ->               -- zero or more results
       CmmActuals ->               -- zero or more arguments
       CmmNode O O
+      -- Semantics: kills only result regs; all other regs (both GlobalReg
+      --            and LocalReg) are preserved.  But there is a current
+      --            bug for what can be put in arguments, see
+      --            Note [Register Parameter Passing]
+
   CmmBranch :: Label -> CmmNode O C  -- Goto another block in the same procedure
+
   CmmCondBranch :: {                 -- conditional branch
       cml_pred :: CmmExpr,
       cml_true, cml_false :: Label
   } -> CmmNode O C
+
   CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
       -- The scrutinee is zero-based;
       --      zero -> first block
       --      one  -> second block etc
       -- Undefined outside range, and when there's a Nothing
-  CmmCall :: {                -- A call (native or safe foreign)
+
+  CmmCall :: {                -- A native call or tail call
       cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
 
       cml_cont :: Maybe Label,
           -- Label of continuation (Nothing for return or tail call)
 
+-- ToDO: add this:
+--       cml_args_regs :: [GlobalReg],
+-- It says which GlobalRegs are live for the parameters at the
+-- moment of the call.  Later stages can use this to give liveness
+-- everywhere, which in turn guides register allocation.
+-- It is the companion of cml_args; cml_args says which stack words
+-- hold parameters, while cml_arg_regs says which global regs hold parameters.
+-- But do note [Register parameter passing]
+
       cml_args :: ByteOff,
           -- Byte offset, from the *old* end of the Area associated with
           -- the Label (if cml_cont = Nothing, then Old area), of
@@ -78,10 +101,12 @@ data CmmNode e x where
         -- cml_ret_off are treated as live, even if the sequel of
         -- the call goes into a loop.
   } -> CmmNode O C
+
   CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
+  		    		-- Always the last node of a block
       tgt   :: ForeignTarget,   -- call target and convention
       res   :: CmmFormals,      -- zero or more results
-      args  :: CmmActuals,      -- zero or more arguments
+      args  :: CmmActuals,      -- zero or more arguments; see Note [Register parameter passing]
       succ  :: Label,           -- Label of continuation
       updfr :: UpdFrameOffset,  -- where the update frame is (for building infotable)
       intrbl:: Bool             -- whether or not the call is interruptible
@@ -89,11 +114,13 @@ data CmmNode e x where
 
 {- Note [Foreign calls]
 ~~~~~~~~~~~~~~~~~~~~~~~
-A MidForeign call is used for *unsafe* foreign calls;
-a LastForeign call is used for *safe* foreign calls.
-Unsafe ones are easy: think of them as a "fat machine instruction".
-In particular, they do *not* kill all live registers (there was a bit
-of code in GHC that conservatively assumed otherwise.)
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction".  In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.)  However, see [Register parameter passing].
 
 Safe ones are trickier.  A safe foreign call 
      r = f(x)
@@ -116,6 +143,21 @@ constructors do *not* (currently) know the foreign call conventions.
 Note that a safe foreign call needs an info table.
 -}
 
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention.  For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing.  These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call.  This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments.  This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently.  We should fix this!
+-}
+
 ---------------------------------------------
 -- Eq instance of CmmNode
 -- It is a shame GHC cannot infer it by itself :(
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index c71f188..a2eecd5 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -14,6 +14,7 @@
 -----------------------------------------------------------------------------
 
 module CmmOpt (
+	cmmEliminateDeadBlocks,
 	cmmMiniInline,
 	cmmMachOpFold,
 	cmmLoopifyForC,
@@ -30,10 +31,69 @@ import UniqFM
 import Unique
 import FastTypes
 import Outputable
+import BlockId
 
 import Data.Bits
 import Data.Word
 import Data.Int
+import Data.Maybe
+import Data.List
+
+import Compiler.Hoopl hiding (Unique)
+
+-- -----------------------------------------------------------------------------
+-- Eliminates dead blocks
+
+{-
+We repeatedly expand the set of reachable blocks until we hit a
+fixpoint, and then prune any blocks that were not in this set.  This is
+actually a required optimization, as dead blocks can cause problems
+for invariants in the linear register allocator (and possibly other
+places.)
+-}
+
+-- Deep fold over statements could probably be abstracted out, but it
+-- might not be worth the effort since OldCmm is moribund
+cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmEliminateDeadBlocks [] = []
+cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
+    let -- Calculate what's reachable from what block
+        reachableMap = foldl' f emptyUFM blocks -- lazy in values
+            where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+        reachableFrom stmts = foldl stmt [] stmts
+            where
+                stmt m CmmNop = m
+                stmt m (CmmComment _) = m
+                stmt m (CmmAssign _ e) = expr m e
+                stmt m (CmmStore e1 e2) = expr (expr m e1) e2
+                stmt m (CmmCall c _ as _ _) = f (actuals m as) c
+                    where f m (CmmCallee e _) = expr m e
+                          f m (CmmPrim _) = m
+                stmt m (CmmBranch b) = b:m
+                stmt m (CmmCondBranch e b) = b:(expr m e)
+                stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
+                stmt m (CmmJump e as) = expr (actuals m as) e
+                stmt m (CmmReturn as) = actuals m as
+                actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+                -- We have to do a deep fold into CmmExpr because
+                -- there may be a BlockId in the CmmBlock literal.
+                expr m (CmmLit l) = lit m l
+                expr m (CmmLoad e _) = expr m e
+                expr m (CmmReg _) = m
+                expr m (CmmMachOp _ es) = foldl' expr m es
+                expr m (CmmStackSlot _ _) = m
+                expr m (CmmRegOff _ _) = m
+                lit m (CmmBlock b) = b:m
+                lit m _ = m
+        -- go todo done
+        reachable = go [base_id] (setEmpty :: BlockSet)
+          where go []     m = m
+                go (x:xs) m
+                    | setMember x m = go xs m
+                    | otherwise     = go (add ++ xs) (setInsert x m)
+                        where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+                                              (lookupUFM reachableMap x)
+    in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
 
 -- -----------------------------------------------------------------------------
 -- The mini-inliner
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 8c2498e..0ee429d 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -396,13 +396,15 @@ stmt	:: { ExtCode }
 	| NAME '(' exprs0 ')' ';'
 		{% stmtMacro $1 $3  }
 	| 'switch' maybe_range expr '{' arms default '}'
-		{ doSwitch $2 $3 $5 $6 }
+		{ do as <- sequence $5; doSwitch $2 $3 as $6 }
 	| 'goto' NAME ';'
 		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 	| 'jump' expr maybe_actuals ';'
 		{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
         | 'return' maybe_actuals ';'
 		{ do e <- sequence $2; stmtEC (CmmReturn e) }
+	| 'if' bool_expr 'goto' NAME
+		{ do l <- lookupLabel $4; cmmRawIf $2 l }
 	| 'if' bool_expr '{' body '}' else 	
 		{ cmmIfThenElse $2 $4 $6 }
 
@@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) }
 	: '[' INT '..' INT ']'	{ Just (fromIntegral $2, fromIntegral $4) }
 	| {- empty -}		{ Nothing }
 
-arms	:: { [([Int],ExtCode)] }
+arms	:: { [ExtFCode ([Int],Either BlockId ExtCode)] }
 	: {- empty -}			{ [] }
 	| arm arms			{ $1 : $2 }
 
-arm	:: { ([Int],ExtCode) }
-	: 'case' ints ':' '{' body '}'	{ ($2, $5) }
+arm	:: { ExtFCode ([Int],Either BlockId ExtCode) }
+	: 'case' ints ':' arm_body	{ do b <- $4; return ($2, b) }
+
+arm_body :: { ExtFCode (Either BlockId ExtCode) }
+	: '{' body '}'			{ return (Right $2) }
+	| 'goto' NAME ';'		{ do l <- lookupLabel $2; return (Left l) }
 
 ints	:: { [Int] }
 	: INT				{ [ fromIntegral $1 ] }
@@ -458,6 +464,8 @@ default :: { Maybe ExtCode }
 	-- 'default' branches
 	| {- empty -}			{ Nothing }
 
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
 else 	:: { ExtCode }
 	: {- empty -}			{ nopEC }
 	| 'else' '{' body '}'		{ $3 }
@@ -681,15 +689,7 @@ machOps = listToUFM $
 	( "gtu",	MO_U_Gt ),
 	( "ltu",	MO_U_Lt ),
 
-	( "flt",	MO_S_Lt ),
-	( "fle",	MO_S_Le ),
-	( "feq",	MO_Eq ),
-	( "fne",	MO_Ne ),
-	( "fgt",	MO_S_Gt ),
-	( "fge",	MO_S_Ge ),
-	( "fneg",	MO_S_Neg ),
-
-	( "and",	MO_And ),
+        ( "and",        MO_And ),
 	( "or",		MO_Or ),
 	( "xor",	MO_Xor ),
 	( "com",	MO_Not ),
@@ -697,7 +697,20 @@ machOps = listToUFM $
 	( "shrl",	MO_U_Shr ),
 	( "shra",	MO_S_Shr ),
 
-	( "lobits8",  flip MO_UU_Conv W8  ),
+        ( "fadd",       MO_F_Add ),
+        ( "fsub",       MO_F_Sub ),
+        ( "fneg",       MO_F_Neg ),
+        ( "fmul",       MO_F_Mul ),
+        ( "fquot",      MO_F_Quot ),
+
+        ( "feq",        MO_F_Eq ),
+        ( "fne",        MO_F_Ne ),
+        ( "fge",        MO_F_Ge ),
+        ( "fle",        MO_F_Le ),
+        ( "fgt",        MO_F_Gt ),
+        ( "flt",        MO_F_Lt ),
+
+        ( "lobits8",  flip MO_UU_Conv W8  ),
 	( "lobits16", flip MO_UU_Conv W16 ),
 	( "lobits32", flip MO_UU_Conv W32 ),
 	( "lobits64", flip MO_UU_Conv W64 ),
@@ -952,6 +965,10 @@ cmmIfThenElse cond then_part else_part = do
      -- fall through to join
      code (labelC join_id)
 
+cmmRawIf cond then_id = do
+    c <- cond
+    emitCond c then_id
+
 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 -- branching to true_id if so, and falling through otherwise.
 emitCond (BoolTest e) then_id = do
@@ -991,7 +1008,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do
 -- optional range on the switch (eg. switch [0..7] {...}), or by
 -- the minimum/maximum values from the branches.
 
-doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
          -> Maybe ExtCode -> ExtCode
 doSwitch mb_range scrut arms deflt
    = do 
@@ -1018,12 +1035,12 @@ doSwitch mb_range scrut arms deflt
 	-- ToDo: check for out of range and jump to default if necessary
         stmtEC (CmmSwitch expr entries)
    where
-	emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
-	emitArm (ints,code) = do
+	emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
+	emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+	emitArm (ints,Right code) = do
 	   blockid <- forkLabelledCodeEC code
 	   return [ (i,blockid) | i <- ints ]
 
-
 -- -----------------------------------------------------------------------------
 -- Putting it all together
 
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index d0d54d9..fbe979b 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -378,6 +378,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
 -- 4. build info tables for the procedures -- and update the info table for
 --    the SRTs in the entry procedure as well.
 -- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      CmmTop -> FuelUniqSM [CmmTop]
 splitAtProcPoints entry_label callPPs procPoints procMap
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 17364ad..2dcfb02 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE GADTs,NoMonoLocalBinds #-}
+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
 
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 #if __GLASGOW_HASKELL__ >= 701
 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
@@ -14,9 +15,7 @@ module CmmSpillReload
   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   , dualLivenessWithInsertion
 
-  , availRegsLattice
-  , cmmAvailableReloads
-  , insertLateReloads
+  , rewriteAssignments
   , removeDeadAssignmentsAndReloads
   )
 where
@@ -26,13 +25,16 @@ import Cmm
 import CmmExpr
 import CmmLive
 import OptimizationFuel
+import StgCmmUtils
 
 import Control.Monad
 import Outputable hiding (empty)
 import qualified Outputable as PP
 import UniqSet
+import UniqFM
+import Unique
 
-import Compiler.Hoopl
+import Compiler.Hoopl hiding (Unique)
 import Data.Maybe
 import Prelude hiding (succ, zip)
 
@@ -172,11 +174,6 @@ insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
                                                text "after"{-, ppr m-}]) $
                    Just $ mkMiddles $ [m, spill reg]
               else Nothing
-          middle m@(CmmUnsafeForeignCall _ fs _) live = return $
-            case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
-                 map reload (uniqSetToList (kill fs (in_regs live))) of
-              []      -> Nothing
-              reloads -> Just $ mkMiddles (m : reloads)
           middle _ _ = return Nothing
 
           nothing _ _ = return Nothing
@@ -188,91 +185,6 @@ spill, reload :: LocalReg -> CmmNode O O
 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction.  Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use.  Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
-               | AvailRegs     RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add
-    where empty = UniverseMinus emptyRegSet
-          -- | compute in the Tx monad to track whether anything has changed
-          add _ (OldFact old) (NewFact new) =
-            if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
-            where join = interAvail new old
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
-interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
-smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
-smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
-extendAvail :: AvailRegs -> LocalReg -> AvailRegs
-extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
-extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
-
-delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs     s) r = elemRegSet r s
-
-cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
-cmmAvailableReloads g =
-  liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
-                              analFwd availRegsLattice availReloadsTransfer
-
-availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
-availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-
-middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
-middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
-               | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (CmmAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
-               | l `isStackSlotOf` r = avail
-middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (CmmStore {})            avail = avail
-middleAvail (CmmUnsafeForeignCall {}) _    = AvailRegs emptyRegSet
-middleAvail (CmmComment {})          avail = avail
-
-lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
-lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail (CmmForeignCall {succ=k})  _ = [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = map (\id -> (id, avail)) $ successors l
-
-insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
-insertLateReloads g =
-  liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
-                              analRewFwd availRegsLattice availReloadsTransfer rewrites
-  where rewrites = mkFRewrite3 first middle last
-        first _ _ = return Nothing
-        middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
-        last   l avail = return $ maybe_reload_before avail l (mkLast l)
-        maybe_reload_before avail node tail =
-            let used = filterRegsUsed (elemAvail avail) node
-            in  if isEmptyUniqSet used then Nothing
-                                       else Just $ reloadTail used tail
-        reloadTail regset t = foldl rel t $ uniqSetToList regset
-          where rel t r = mkMiddle (reload r) <*> t
-
 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 removeDeadAssignmentsAndReloads procPoints g =
    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
@@ -283,10 +195,464 @@ removeDeadAssignmentsAndReloads procPoints g =
          -- but GHC panics while compiling, see bug #4045.
          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+         -- XXX maybe this should be somewhere else...
+         middle (CmmAssign lhs (CmmReg rhs))   _ | lhs == rhs = return $ Just emptyGraph
+         middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
          middle _ _ = return Nothing
 
          nothing _ _ = return Nothing
 
+----------------------------------------------------------------
+--- Usage information
+
+-- We decorate all register assignments with usage information,
+-- that is, the maximum number of times the register is referenced
+-- while it is live along all outgoing control paths.  There are a few
+-- subtleties here:
+--
+--  - If a register goes dead, and then becomes live again, the usages
+--    of the disjoint live range don't count towards the original range.
+--
+--          a = 1; // used once
+--          b = a;
+--          a = 2; // used once
+--          c = a;
+--
+--  - A register may be used multiple times, but these all reside in
+--    different control paths, such that any given execution only uses
+--    it once. In that case, the usage count may still be 1.
+--
+--          a = 1; // used once
+--          if (b) {
+--              c = a + 3;
+--          } else {
+--              c = a + 1;
+--          }
+--
+--    This policy corresponds to an inlining strategy that does not
+--    duplicate computation but may increase binary size.
+--
+--  - If we naively implement a usage count, we have a counting to
+--    infinity problem across joins.  Furthermore, knowing that
+--    something is used 2 or more times in one runtime execution isn't
+--    particularly useful for optimizations (inlining may be beneficial,
+--    but there's no way of knowing that without register pressure
+--    information.)
+--
+--          while (...) {
+--              // first iteration, b used once
+--              // second iteration, b used twice
+--              // third iteration ...
+--              a = b;
+--          }
+--          // b used zero times
+--
+--    There is an orthogonal question, which is that for every runtime
+--    execution, the register may be used only once, but if we inline it
+--    in every conditional path, the binary size might increase a lot.
+--    But tracking this information would be tricky, because it violates
+--    the finite lattice restriction Hoopl requires for termination;
+--    we'd thus need to supply an alternate proof, which is probably
+--    something we should defer until we actually have an optimization
+--    that would take advantage of this.  (This might also interact
+--    strangely with liveness information.)
+--
+--          a = ...;
+--          // a is used one time, but in X different paths
+--          case (b) of
+--              1 -> ... a ...
+--              2 -> ... a ...
+--              3 -> ... a ...
+--              ...
+--
+--  This analysis is very similar to liveness analysis; we just keep a
+--  little extra info. (Maybe we should move it to CmmLive, and subsume
+--  the old liveness analysis.)
+
+data RegUsage = SingleUse | ManyUse
+    deriving (Ord, Eq, Show)
+-- Absence in map = ZeroUse
+
+{-
+-- minBound is bottom, maxBound is top, least-upper-bound is max
+-- ToDo: Put this in Hoopl.  Note that this isn't as useful as I
+-- originally hoped, because you usually want to leave out the bottom
+-- element when you have things like this put in maps.  Maybe f is
+-- useful on its own as a combining function.
+boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
+boundedOrdLattice n = DataflowLattice n minBound f
+    where f _ (OldFact x) (NewFact y)
+            | x >= y    = (NoChange,   x)
+            | otherwise = (SomeChange, y)
+-}
+
+-- Custom node type we'll rewrite to.  CmmAssign nodes to local
+-- registers are replaced with AssignLocal nodes.
+data WithRegUsage n e x where
+    Plain       :: n e x -> WithRegUsage n e x
+    AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
+
+instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
+    foldRegsUsed f z (Plain n) = foldRegsUsed f z n
+    foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
+    foldRegsDefd f z (Plain n) = foldRegsDefd f z n
+    foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
+
+instance NonLocal n => NonLocal (WithRegUsage n) where
+    entryLabel (Plain n) = entryLabel n
+    successors (Plain n) = successors n
+
+liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
+liftRegUsage = mapGraph Plain
+
+eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
+eraseRegUsage = mapGraph f
+    where f :: WithRegUsage CmmNode e x -> CmmNode e x
+          f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
+          f (Plain n) = n
+
+type UsageMap = UniqFM RegUsage
+
+usageLattice :: DataflowLattice UsageMap
+usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
+    where f _ (OldFact x) (NewFact y)
+            | x >= y    = (NoChange,   x)
+            | otherwise = (SomeChange, y)
+
+-- We reuse the names 'gen' and 'kill', although we're doing something
+-- slightly different from the Dragon Book
+usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
+usageTransfer = mkBTransfer3 first middle last
+    where first _ f = f
+          middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
+          middle n f = gen_kill n f
+          last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
+          -- Checking for CmmCall/CmmForeignCall is unnecessary, because
+          -- spills/reloads have already occurred by the time we do this
+          -- analysis.
+          -- XXX Deprecated warning is puzzling: what label are we
+          -- supposed to use?
+          -- ToDo: With a bit more cleverness here, we can avoid
+          -- disappointment and heartbreak associated with the inability
+          -- to inline into CmmCall and CmmForeignCall by
+          -- over-estimating the usage to be ManyUse.
+          last n f = gen_kill n (joinOutFacts usageLattice n f)
+          gen_kill a = gen a . kill a
+          gen  a f = foldRegsUsed increaseUsage f a
+          kill a f = foldRegsDefd delFromUFM f a
+          increaseUsage f r = addToUFM_C combine f r SingleUse
+            where combine _ _ = ManyUse
+
+usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
+usageRewrite = mkBRewrite3 first middle last
+    where first  _ _ = return Nothing
+          middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
+          middle (Plain (CmmAssign (CmmLocal l) e)) f
+                     = return . Just
+                     $ case lookupUFM f l of
+                            Nothing    -> emptyGraph
+                            Just usage -> mkMiddle (AssignLocal l e usage)
+          middle _ _ = return Nothing
+          last   _ _ = return Nothing
+
+type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
+annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
+annotateUsage vanilla_g =
+    let g = modifyGraph liftRegUsage vanilla_g
+    in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
+                                   analRewBwd usageLattice usageTransfer usageRewrite
+
+----------------------------------------------------------------
+--- Assignment tracking
+
+-- The idea is to maintain a map of local registers do expressions,
+-- such that the value of that register is the same as the value of that
+-- expression at any given time.  We can then do several things,
+-- as described by Assignment.
+
+-- Assignment describes the various optimizations that are valid
+-- at a given point in the program.
+data Assignment =
+-- This assignment can always be inlined.  It is cheap or single-use.
+                  AlwaysInline CmmExpr
+-- This assignment should be sunk down to its first use.  (This will
+-- increase code size if the register is used in multiple control flow
+-- paths, but won't increase execution time, and the reduction of
+-- register pressure is worth it.)
+                | AlwaysSink CmmExpr
+-- We cannot safely optimize occurrences of this local register. (This
+-- corresponds to top in the lattice structure.)
+                | NeverOptimize
+
+-- Extract the expression that is being assigned to
+xassign :: Assignment -> Maybe CmmExpr
+xassign (AlwaysInline e) = Just e
+xassign (AlwaysSink e)   = Just e
+xassign NeverOptimize    = Nothing
+
+-- Extracts the expression, but only if they're the same constructor
+xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
+xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
+xassign2 (AlwaysSink e, AlwaysSink e')     = Just (e, e')
+xassign2 _ = Nothing
+
+-- Note: We'd like to make decisions about "not optimizing" as soon as
+-- possible, because this will make running the transfer function more
+-- efficient.
+type AssignmentMap = UniqFM Assignment
+
+assignmentLattice :: DataflowLattice AssignmentMap
+assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
+    where add _ (OldFact old) (NewFact new)
+            = case (old, new) of
+                (NeverOptimize, _) -> (NoChange,   NeverOptimize)
+                (_, NeverOptimize) -> (SomeChange, NeverOptimize)
+                (xassign2 -> Just (e, e'))
+                    | e == e'   -> (NoChange, old)
+                    | otherwise -> (SomeChange, NeverOptimize)
+                _ -> (SomeChange, NeverOptimize)
+
+-- Deletes sinks from assignment map, because /this/ is the place
+-- where it will be sunk to.
+deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
+deleteSinks n m = foldRegsUsed (adjustUFM f) m n
+  where f (AlwaysSink _) = NeverOptimize
+        f old = old
+
+-- Invalidates any expressions that use a register.
+invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
+-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
+    where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
+          f _ _ m = m
+{- This requires the entire spine of the map to be continually rebuilt,
+ - which causes crazy memory usage!
+invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
+  where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
+        invalidateUsers' _ old = old
+-}
+
+-- Note [foldUFM performance]
+-- These calls to fold UFM no longer leak memory, but they do cause
+-- pretty killer amounts of allocation.  So they'll be something to
+-- optimize; we need an algorithmic change to prevent us from having to
+-- traverse the /entire/ map continually.
+
+middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
+
+-- Algorithm for annotated assignments:
+--  1. Delete any sinking assignments that were used by this instruction
+--  2. Add the assignment to our list of valid local assignments with
+--     the correct optimization policy.
+--  3. Look for all assignments that reference that register and
+--     invalidate them.
+middleAssignment n@(AssignLocal r e usage) assign
+    = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
+      where add m = addToUFM m r
+                  $ case usage of
+                        SingleUse -> AlwaysInline e
+                        ManyUse   -> decide e
+            decide CmmLit{}       = AlwaysInline e
+            decide CmmReg{}       = AlwaysInline e
+            decide CmmLoad{}      = AlwaysSink e
+            decide CmmStackSlot{} = AlwaysSink e
+            decide CmmMachOp{}    = AlwaysSink e
+            -- We'll always inline simple operations on the global
+            -- registers, to reduce register pressure: Sp - 4 or Hp - 8
+            -- EZY: Justify this optimization more carefully.
+            decide CmmRegOff{}    = AlwaysInline e
+
+-- Algorithm for unannotated assignments of global registers:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that reference this register and
+--    invalidate them.
+middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+    = invalidateUsersOf reg . deleteSinks n $ assign
+
+-- Algorithm for unannotated assignments of *local* registers: do
+-- nothing (it's a reload, so no state should have changed)
+middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
+
+-- Algorithm for stores:
+--  1. Delete any sinking assignments that were used by this instruction
+--  2. Look for all assignments that load from memory locations that
+--     were clobbered by this store and invalidate them.
+middleAssignment (Plain n@(CmmStore lhs rhs)) assign
+    = let m = deleteSinks n assign
+      in foldUFM_Directly f m m -- [foldUFM performance]
+      where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
+            f _ _ m = m
+{- Also leaky
+    = mapUFM_Directly p . deleteSinks n $ assign
+      -- ToDo: There's a missed opportunity here: even if a memory
+      -- access we're attempting to sink gets clobbered at some
+      -- location, it's still /better/ to sink it to right before the
+      -- point where it gets clobbered.  How might we do this?
+      -- Unfortunately, it's too late to change the assignment...
+      where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
+            p _ old = old
+-}
+
+-- Assumption: Unsafe foreign calls don't clobber memory
+-- Since foreign calls clobber caller saved registers, we need
+-- invalidate any assignments that reference those global registers.
+-- This is kind of expensive. (One way to optimize this might be to
+-- store extra information about expressions that allow this and other
+-- checks to be done cheaply.)
+middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
+    = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+    where deleteCallerSaves m = foldUFM_Directly f m m
+          f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
+          f _ _ m = m
+          g (CmmReg (CmmGlobal r)) _      | callerSaves r = True
+          g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+          g _ b = b
+
+middleAssignment (Plain (CmmComment {})) assign
+    = assign
+
+-- Assumptions:
+--  * Writes using Hp do not overlap with any other memory locations
+--    (An important invariant being relied on here is that we only ever
+--    use Hp to allocate values on the heap, which appears to be the
+--    case given hpReg usage, and that our heap writing code doesn't
+--    do anything stupid like overlapping writes.)
+--  * Stack slots do not overlap with any other memory locations
+--  * Stack slots for different areas do not overlap
+--  * Stack slots within the same area and different offsets may
+--    overlap; we need to do a size check (see 'overlaps').
+--  * Register slots only overlap with themselves.  (But this shouldn't
+--    happen in practice, because we'll fail to inline a reload across
+--    the next spill.)
+--  * Non stack-slot stores always conflict with each other.  (This is
+--    not always the case; we could probably do something special for Hp)
+clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+         -> (Unique,  CmmExpr) -- (register, expression) that may be clobbered
+         -> Bool
+clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+-- ToDo: Also catch MachOp case
+clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
+    | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
+clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
+    where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
+            = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
+          f (CmmLoad e _)    = containsStackSlot e
+          f (CmmMachOp _ es) = or (map f es)
+          f _                = False
+          -- Maybe there's an invariant broken if this actually ever
+          -- returns True
+          containsStackSlot (CmmLoad{})      = True -- load of a load, all bets off
+          containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
+          containsStackSlot (CmmStackSlot{}) = True
+          containsStackSlot _ = False
+clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
+    where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
+          f _ = False
+clobbers _ (_, e) = f e
+    where f (CmmLoad (CmmStackSlot _ _) _) = False
+          f (CmmLoad{}) = True -- conservative
+          f (CmmMachOp _ es) = or (map f es)
+          f _ = False
+
+-- Check for memory overlapping.
+-- Diagram:
+--      4      8     12
+--      s -w-  o
+--      [ I32  ]
+--      [    F64     ]
+--      s'   -w'-    o'
+type CallSubArea = (AreaId, Int, Int) -- area, offset, width
+overlaps :: CallSubArea -> CallSubArea -> Bool
+overlaps (a, _, _) (a', _, _) | a /= a' = False
+overlaps (_, o, w) (_, o', w') =
+    let s  = o  - w
+        s' = o' - w'
+    in (s' < o) && (s < o) -- Not LTE, because [ I32  ][ I32  ] is OK
+
+lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
+-- Variables are dead across calls, so invalidating all mappings is justified
+lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment (Plain (CmmForeignCall {succ=k}))  assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
+
+assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
+assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
+
+assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
+assignmentRewrite = mkFRewrite3 first middle last
+    where
+        first _ _ = return Nothing
+        middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
+        middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
+        middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
+        last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
+        -- Tuple is (inline?, reloads)
+        precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
+            where f (i, l) r = case lookupUFM assign r of
+                                Just (AlwaysSink e)   -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
+                                Just (AlwaysInline _) -> (True, l)
+                                Just NeverOptimize    -> (i, l)
+                                -- This case can show up when we have
+                                -- limited optimization fuel.
+                                Nothing -> (i, l)
+        rewrite _ (False, []) _ _ = Nothing
+        -- Note [CmmCall Inline Hack]
+        -- Conservative hack: don't do any inlining on what will
+        -- be translated into an OldCmm CmmCalls, since the code
+        -- produced here tends to be unproblematic and I need to write
+        -- lint passes to ensure that we don't put anything in the
+        -- arguments that could be construed as a global register by
+        -- some later translation pass.  (For example, slots will turn
+        -- into dereferences of Sp).  See [Register parameter passing].
+        -- ToDo: Fix this up to only bug out if all inlines were for
+        -- CmmExprs with global registers (we can't use the
+        -- straightforward mapExpDeep call, in this case.) ToDo: We miss
+        -- an opportunity here, where all possible inlinings should
+        -- instead be sunk.
+        rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
+        rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
+
+        rewriteLocal _ (False, []) _ _ _ _ = Nothing
+        rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
+            where n' = AssignLocal l e' u
+                  e' = if i then wrapRecExp (inlineExp assign) e else e
+            -- inlinable check omitted, since we can always inline into
+            -- assignments.
+
+        inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
+        inline False _ n = n
+        inline True  _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
+        inline True assign n = mapExpDeep (inlineExp assign) n
+
+        inlineExp assign old@(CmmReg (CmmLocal r))
+          = case lookupUFM assign r of
+              Just (AlwaysInline x) -> x
+              _ -> old
+        inlineExp assign old@(CmmRegOff (CmmLocal r) i)
+          = case lookupUFM assign r of
+              Just (AlwaysInline x) ->
+                case x of
+                    (CmmRegOff r' i') -> CmmRegOff r' (i + i')
+                    _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+                          where rep = typeWidth (localRegType r)
+              _ -> old
+        inlineExp _ old = old
+
+        inlinable :: CmmNode e x -> Bool
+        inlinable (CmmCall{}) = False
+        inlinable (CmmForeignCall{}) = False
+        inlinable (CmmUnsafeForeignCall{}) = False
+        inlinable _ = True
+
+rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
+rewriteAssignments g = do
+  g'  <- annotateUsage g
+  g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
+                                     analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
+  return (modifyGraph eraseRegUsage g'')
 
 ---------------------
 -- prettyprinting
@@ -305,11 +671,7 @@ instance Outputable DualLive where
                          if isEmptyUniqSet stack then PP.empty
                          else (ppr_regs "live on stack =" stack)]
 
-instance Outputable AvailRegs where
-  ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
-                          else ppr_regs "available = all but" s
-  ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
-                          else ppr_regs "available = " s
+-- ToDo: Outputable instance for UsageMap and AssignmentMap
 
 my_trace :: String -> SDoc -> a -> a
 my_trace = if False then pprTrace else \_ _ a -> a
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 01543c4..c0fb6af 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -13,7 +13,7 @@
 
 module CmmStackLayout
     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
-    , layout, manifestSP, igraph, areaBuilder
+    , getSpEntryMap, layout, manifestSP, igraph, areaBuilder
     , stubSlotsOnDeath ) -- to help crash early during debugging
 where
 
@@ -195,7 +195,7 @@ liveLastOut env l =
 type Set x = Map x ()
 data IGraphBuilder n =
   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
-          , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
+          , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int]
           }
 
 areaBuilder :: IGraphBuilder Area
@@ -242,10 +242,13 @@ igraph builder env g = foldr interfere Map.empty (postorderDfs g)
 -- what's the highest offset (in bytes) used in each Area?
 -- We'll need to allocate that much space for each Area.
 
+-- Mapping of areas to area sizes (not offsets!)
+type AreaSizeMap = AreaMap
+
 -- JD: WHY CAN'T THIS COME FROM THE slot-liveness info?
-getAreaSize :: ByteOff -> CmmGraph -> AreaMap
+getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap
   -- The domain of the returned mapping consists only of Areas
-  -- used for (a) variable spill slots, and (b) parameter passing ares for calls
+  -- used for (a) variable spill slots, and (b) parameter passing areas for calls
 getAreaSize entry_off g =
   foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last))
               (Map.singleton (CallArea Old) entry_off) g
@@ -266,10 +269,11 @@ getAreaSize entry_off g =
 	-- The 'max' is important.  Two calls, to f and g, might share a common
 	-- continuation (and hence a common CallArea), but their number of overflow
 	-- parameters might differ.
+        -- EZY: Ought to use insert with combining function...
 
 
 -- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
+conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int
 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
   foldNodes subarea foldNode Map.empty
   where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
@@ -278,10 +282,10 @@ conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
         setAdd w s = Map.insert w () s
 
--- Find any open space on the stack, starting from the offset.
--- If the area is a CallArea or a spill slot for a pointer, then it must
--- be word-aligned.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
+-- Find any open space for 'area' on the stack, starting from the
+-- 'offset'.  If the area is a CallArea or a spill slot for a pointer,
+-- then it must be word-aligned.
+freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int
 freeSlotFrom ig areaSize offset areaMap area =
   let size = Map.lookup area areaSize `orElse` 0
       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
@@ -299,11 +303,24 @@ freeSlotFrom ig areaSize offset areaMap area =
   in findSpace (align (offset + size)) size
 
 -- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
+allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap
 allocSlotFrom ig areaSize from areaMap area =
   if Map.member area areaMap then areaMap
   else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
 
+-- Figure out all of the offsets from the slot location; this will be
+-- non-zero for procpoints.
+type SpEntryMap = BlockEnv Int
+getSpEntryMap :: Int -> CmmGraph -> SpEntryMap
+getSpEntryMap entry_off g@(CmmGraph {g_entry = entry})
+    = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
+  where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
+        add_sp_off b env =
+          case lastNode b of
+            CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
+            CmmForeignCall {succ=succ}                     -> mapInsert succ wORD_SIZE env
+            _                                              -> env
+
 -- | Greedy stack layout.
 -- Compute liveness, build the interference graph, and allocate slots for the areas.
 -- We visit each basic block in a (generally) forward order.
@@ -326,12 +343,16 @@ allocSlotFrom ig areaSize from areaMap area =
 -- Note: The stack pointer only has to be younger than the youngest live stack slot
 -- at proc points. Otherwise, the stack pointer can point anywhere.
 
-layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
+layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
 -- The domain of the returned map includes an Area for EVERY block
 -- including each block that is not the successor of a call (ie is not a proc-point)
--- That's how we return the info of what the SP should be at the entry of every block
+-- That's how we return the info of what the SP should be at the entry of every non
+-- procpoint block.  However, note that procpoint blocks have their
+-- /slot/ stored, which is not necessarily the value of the SP on entry
+-- to the block (in fact, it probably isn't, due to argument passing).
+-- See [Procpoint Sp offset]
 
-layout procPoints env entry_off g =
+layout procPoints spEntryMap env entry_off g =
   let ig = (igraph areaBuilder env g, areaBuilder)
       env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
       areaSize = getAreaSize entry_off g
@@ -370,21 +391,87 @@ layout procPoints env entry_off g =
       allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m
       allocLast bid l areaMap =
         foldr (setSuccSPs inSp) areaMap' (successors l)
-        where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap
+        where inSp = slot + spOffset -- [Procpoint Sp offset]
+              -- If it's not in the map, we should use our previous
+              -- calculation unchanged.
+              spOffset = mapLookup bid spEntryMap `orElse` 0
+              slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap
               areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l
       alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
       alloc' areaMap _ = areaMap
 
-      initMap = Map.insert (CallArea (Young (g_entry g))) 0 $
-                  Map.insert (CallArea Old) 0 Map.empty
-                        
+      initMap = Map.insert (CallArea (Young (g_entry g))) 0
+              . Map.insert (CallArea Old)                 0
+              $ Map.empty
+
       areaMap = foldl layoutAreas initMap (postorderDfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
-        -- pprTrace "Area SizeMap" (ppr areaSize) $
-         -- pprTrace "Entry SP" (ppr entrySp) $
-           -- pprTrace "Area Map" (ppr areaMap) $
+     -- pprTrace "Area SizeMap" (ppr areaSize) $
+     -- pprTrace "Entry offset" (ppr entry_off) $
+     -- pprTrace "Area Map" (ppr areaMap) $
      areaMap
 
+{- Note [Procpoint Sp offset]
+
+The calculation of inSp is a little tricky.  (Un)fortunately, if you get
+it wrong, you will get inefficient but correct code.  You know you've
+got it wrong if the generated stack pointer bounces up and down for no
+good reason.
+
+Why can't we just set inSp to the location of the slot?  (This is what
+the code used to do.)  The trouble is when we actually hit the proc
+point the start of the slot will not be the same as the actual Sp due
+to argument passing:
+
+  a:
+      I32[(young<b> + 4)] = cde;
+      // Stack pointer is moved to young end (bottom) of young<b> for call
+      // +-------+
+      // | arg 1 |
+      // +-------+ <- Sp
+      call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4;
+  b:
+      // After call, stack pointer is above the old end (top) of
+      // young<b> (the difference is spOffset)
+      // +-------+ <- Sp
+      // | arg 1 |
+      // +-------+
+
+If we blithely set the Sp to be the same as the slot (the young end of
+young<b>), an adjustment will be necessary when we go to the next block.
+This is wasteful.  So, instead, for the next block after a procpoint,
+the actual Sp should be set to the same as the true Sp when we just
+entered the procpoint.  Then manifestSP will automatically do the right
+thing.
+
+Questions you may ask:
+
+1. Why don't we need to change the mapping for the procpoint itself?
+   Because manifestSP does its own calculation of the true stack value,
+   manifestSP will notice the discrepancy between the actual stack
+   pointer and the slot start, and adjust all of its memory accesses
+   accordingly.  So the only problem is when we adjust the Sp in
+   preparation for the successor block; that's why this code is here and
+   not in setSuccSPs.
+
+2. Why don't we make the procpoint call area and the true offset match
+   up?  If we did that, we would never use memory above the true value
+   of the stack pointer, thus wasting all of the stack we used to store
+   arguments.  You might think that some clever changes to the slot
+   offsets, using negative offsets, might fix it, but this does not make
+   semantic sense.
+
+3. If manifestSP is already calculating the true stack value, why we can't
+   do this trick inside manifestSP itself?  The reason is that if two
+   branches join with inconsistent SPs, one of them has to be fixed: we
+   can't know what the fix should be without already knowing what the
+   chosen location of SP is on the next successor.  (This is
+   the "succ already knows incoming SP" case), This calculation cannot
+   be easily done in manifestSP, since it processes the nodes
+   /backwards/.  So we need to have figured this out before we hit
+   manifestSP.
+-}
+
 -- After determining the stack layout, we can:
 -- 1. Replace references to stack Areas with addresses relative to the stack
 --    pointer.
@@ -394,8 +481,8 @@ layout procPoints env entry_off g =
 --    stack pointer to be younger than the live values on the stack at proc points.
 -- 3. Compute the maximum stack offset used in the procedure and replace
 --    the stack high-water mark with that offset.
-manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
-manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
+manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
+manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) =
   ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g)
   where slot a = -- pprTrace "slot" (ppr a) $
                    Map.lookup a areaMap `orElse` panic "unallocated Area"
@@ -404,13 +491,6 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
         sp_high = maxSlot slot g
         proc_entry_sp = slot (CallArea Old) + entry_off
 
-        add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
-        add_sp_off b env =
-          case lastNode b of
-            CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
-            CmmForeignCall {succ=succ}                     -> mapInsert succ wORD_SIZE env
-            _                                              -> env
-        spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
         spOffset id = mapLookup id spEntryMap `orElse` 0
 
         sp_on_entry id | id == entry = proc_entry_sp
@@ -427,10 +507,26 @@ manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
           where spIn = sp_on_entry (entryLabel block)
 
                 middle spOff m = mapExpDeep (replSlot spOff) m
+                -- XXX there shouldn't be any global registers in the
+                -- CmmCall, so there shouldn't be any slots in
+                -- CmmCall... check that...
                 last   spOff l = mapExpDeep (replSlot spOff) l
                 replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
                 replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
                   CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+                -- Invariant: Sp is always greater than SpLim.  Thus, if
+                -- the high water mark is zero, we can optimize away the
+                -- conditional branch.  Relies on dead code elimination
+                -- to get rid of the dead GC blocks.
+                -- EZY: Maybe turn this into a guard that checks if a
+                -- statement is stack-check ish?  Maybe we should make
+                -- an actual mach-op for it, so there's no chance of
+                -- mixing this up with something else...
+                replSlot _ (CmmMachOp (MO_U_Lt _)
+                              [CmmMachOp (MO_Sub _)
+                                         [ CmmReg (CmmGlobal Sp)
+                                         , CmmLit (CmmInt 0 _)],
+                               CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
                 replSlot _ e = e
 
                 replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 57d458c..f5c0817 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -144,12 +144,14 @@ data CmmStmt	-- Old-style
   | CmmStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
                                  -- given by cmmExprType of the rhs.
 
-  | CmmCall	 		 -- A call (forign, native or primitive), with 
+  | CmmCall	 		 -- A call (foreign, native or primitive), with 
      CmmCallTarget
      HintedCmmFormals		 -- zero or more results
      HintedCmmActuals		 -- zero or more arguments
      CmmSafety			 -- whether to build a continuation
      CmmReturnInfo
+  -- Some care is necessary when handling the arguments of these, see
+  -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
 
   | CmmBranch BlockId             -- branch to another BB in this fn
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index d363cef..aa7d914 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -64,10 +64,6 @@ import Data.Word
 import Data.Array.ST
 import Control.Monad.ST
 
-#if x86_64_TARGET_ARCH
-import StaticFlags	( opt_Unregisterised )
-#endif
-
 #if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
 #define BEWARE_LOAD_STORE_ALIGNMENT
 #endif
@@ -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
diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes
index 0852711..c0ccadf 100644
--- a/compiler/cmm/cmm-notes
+++ b/compiler/cmm/cmm-notes
@@ -1,3 +1,7 @@
+More notes (May 11)
+~~~~~~~~~~~~~~~~~~~
+In CmmNode, consider spliting CmmCall into two: call and jump
+
 Notes on new codegen (Aug 10)
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -15,14 +19,11 @@ Things to do:
 	This will fix the spill before stack check problem but only really as a side
 	effect. A 'real fix' probably requires making the spiller know about sp checks.
 
- - There is some silly stuff happening with the Sp. We end up with code like:
-   Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8
-	Seems to be perhaps caused by the issue above but also maybe a optimisation
-	pass needed?
+   EZY: I don't understand this comment. David Terei, can you clarify?
 
- - Proc pass all arguments on the stack, adding more code and slowing down things
-   a lot. We either need to fix this or even better would be to get rid of
-	proc points.
+ - Proc points pass all arguments on the stack, adding more code and
+   slowing down things a lot. We either need to fix this or even better
+   would be to get rid of proc points.
 
  - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to
    Old.Cmm. We should abstract it to work on both representations, it needs only to
@@ -32,7 +33,7 @@ Things to do:
    we could convert codeGen/StgCmm* clients to the Hoopl's semantics?
    It's all deeply unsatisfactory.
 
- - Improve preformance of Hoopl.
+ - Improve performance of Hoopl.
 
    A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters
    (using the same ghc-cmm branch +libraries compiled by the old codegenerator)
@@ -50,6 +51,9 @@ Things to do:
 
    So we generate a bit better code, but it takes us longer!
 
+   EZY: Also importantly, Hoopl uses dramatically more memory than the
+   old code generator.
+
  - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could
    splice blocks instead?
 
@@ -57,7 +61,7 @@ Things to do:
    a block catenation function would be probably nicer than blockToNodeList
    / blockOfNodeList combo.
 
- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that
+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that
    delete splitEntrySeq from HooplUtils.
 
  - manifestSP seems to touch a lot of the graph representation. It is
@@ -76,6 +80,9 @@ Things to do:
    calling convention, and the code for calling foreign calls is generated
 
  - AsmCodeGen has a generic Cmm optimiser; move this into new pipeline
+   EZY (2011-04-16): The mini-inliner has been generalized and ported,
+   but the constant folding and other optimizations need to still be
+   ported.
 
  - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);
    we ultimately want to share this with the Cmm branch eliminator.
@@ -113,7 +120,7 @@ Things to do:
  - See "CAFs" below; we want to totally refactor the way SRTs are calculated
 
  - Pull out Areas into its own module
-   Parameterise AreaMap
+   Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)
    Add ByteWidth = Int
    type SubArea    = (Area, ByteOff, ByteWidth) 
    ByteOff should not be defined in SMRep -- that is too high up the hierarchy
@@ -293,8 +300,8 @@ cpsTop:
        insert spills/reloads across 
 	   LastCalls, and 
 	   Branches to proc-points
-     Now sink those reloads:
-     - CmmSpillReload.insertLateReloads
+     Now sink those reloads (and other instructions):
+     - CmmSpillReload.rewriteAssignments
      - CmmSpillReload.removeDeadAssignmentsAndReloads
 
   * CmmStackLayout.stubSlotsOnDeath
@@ -344,7 +351,7 @@ to J that way. This is an awkward choice.  (We think that we currently
 never pass variables to join points via arguments.)
 
 Furthermore, there is *no way* to pass q to J in a register (other
-than a paramter register).
+than a parameter register).
 
 What we want is to do register allocation across the whole caboodle.
 Then we could drop all the code that deals with the above awkward
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index fd440e9..c5a6644 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -10,13 +10,17 @@ module CgPrimOp (
    cgPrimOp
  ) where
 
+import BasicTypes
 import ForeignCall
 import ClosureInfo
 import StgSyn
 import CgForeignCall
 import CgBindery
 import CgMonad
+import CgHeapery
 import CgInfoTbls
+import CgTicky
+import CgProf
 import CgUtils
 import OldCmm
 import CLabel
@@ -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))
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 922d330..63d99a6 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -20,7 +20,7 @@ module CgUtils (
         emitRODataLits, mkRODataLits,
         emitIf, emitIfThenElse,
 	emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
-	assignTemp, newTemp,
+	assignTemp, assignTemp_, newTemp,
 	emitSimultaneously,
 	emitSwitch, emitLitSwitch,
 	tagToClosure,
@@ -29,7 +29,7 @@ module CgUtils (
 	activeStgRegs, fixStgRegisters,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
-        cmmUGtWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
 	cmmOffsetExprW, cmmOffsetExprB,
 	cmmRegOffW, cmmRegOffB,
 	cmmLabelOffW, cmmLabelOffB,
@@ -180,8 +180,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
+cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
@@ -587,6 +589,9 @@ mkByteStringCLit bytes
 --
 -------------------------------------------------------------------------
 
+-- | If the expression is trivial, return it.  Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
 assignTemp :: CmmExpr -> FCode CmmExpr
 -- For a non-trivial expression, e, create a local
 -- variable and assign the expression to it
@@ -596,6 +601,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) }
 
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 48416e3..d917811 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -340,6 +340,23 @@ emitRtsCall' res pkg fun args _vols safe
 --  * Regs.h claims that BaseReg should be saved last and loaded first
 --    * This might not have been tickled before since BaseReg is callee save
 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers.  We can't (nor want) to do that
+-- here, as we don't have liveness information.  And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
 callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
 callerSaveVolatileRegs = (caller_save, caller_load)
   where
@@ -396,6 +413,51 @@ callerSaves :: GlobalReg -> Bool
 #ifdef CALLER_SAVES_Base
 callerSaves BaseReg		= True
 #endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1 _)	= True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2 _)	= True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3 _)	= True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4 _)	= True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5 _)	= True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6 _)	= True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7 _)	= True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8 _)	= True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1)	= True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2)	= True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3)	= True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4)	= True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1)	= True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2)	= True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1)		= True
+#endif
 #ifdef CALLER_SAVES_Sp
 callerSaves Sp			= True
 #endif
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 678c961..0fa1c38 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -29,6 +29,7 @@ import BasicTypes
 import Unique
 import Outputable
 import FastString
+import Pair
 \end{code}
 
 %************************************************************************
@@ -79,11 +80,13 @@ exprArity e = go e
     go (Lam x e) | isId x    	   = go e + 1
     		 | otherwise 	   = go e
     go (Note n e) | notSccNote n   = go e
-    go (Cast e co)                 = go e `min` length (typeArity (snd (coercionKind co)))
-       	       			     	-- Note [exprArity invariant]
+    go (Cast e co)                 = go e `min` length (typeArity (pSnd (coercionKind co)))
+                                        -- Note [exprArity invariant]
     go (App e (Type _))            = go e
     go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
         -- See Note [exprArity for applications]
+	-- NB: coercions count as a value argument
+
     go _		       	   = 0
 
 
@@ -549,7 +552,7 @@ arityType cheap_fn (Lam x e)
   | isId x    = arityLam x (arityType cheap_fn e)
   | otherwise = arityType cheap_fn e
 
-	-- Applications; decrease arity
+	-- Applications; decrease arity, except for types
 arityType cheap_fn (App fun (Type _))
    = arityType cheap_fn fun
 arityType cheap_fn (App fun arg )
@@ -663,14 +666,14 @@ etaExpand n orig_expr
       -- Strip off existing lambdas and casts
       -- Note [Eta expansion and SCCs]
     go 0 expr = expr
-    go n (Lam v body) | isTyCoVar v = Lam v (go n     body)
-       	              | otherwise   = Lam v (go (n-1) body)
+    go n (Lam v body) | isTyVar v = Lam v (go n     body)
+       	              | otherwise = Lam v (go (n-1) body)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
        	 		  etaInfoAbs etas (etaInfoApp subst' expr etas)
     	  		where
 			    in_scope = mkInScopeSet (exprFreeVars expr)
-			    (in_scope', etas) = mkEtaWW n in_scope (exprType expr)
+			    (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
 			    subst' = mkEmptySubst in_scope'
 
       	      	       	        -- Wrapper    Unwrapper
@@ -685,10 +688,10 @@ instance Outputable EtaInfo where
 
 pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
 pushCoercion co1 (EtaCo co2 : eis)
-  | isIdentityCoercion co = eis
-  | otherwise	       	  = EtaCo co : eis
+  | isReflCo co = eis
+  | otherwise	= EtaCo co : eis
   where
-    co = co1 `mkTransCoercion` co2
+    co = co1 `mkTransCo` co2
 
 pushCoercion co eis = EtaCo co : eis
 
@@ -696,7 +699,7 @@ pushCoercion co eis = EtaCo co : eis
 etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
 etaInfoAbs []               expr = expr
 etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
-etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co)
+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
 
 --------------
 etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
@@ -704,15 +707,12 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
 -- 	       ((substExpr s e) `appliedto` eis)
 
 etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) 
-  = etaInfoApp subst' e eis
-  where
-    subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
-    	   | otherwise  = CoreSubst.extendIdSubst subst v1 (Var v2)
+  = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
 
 etaInfoApp subst (Cast e co1) eis
   = etaInfoApp subst e (pushCoercion co' eis)
   where
-    co' = CoreSubst.substTy subst co1
+    co' = CoreSubst.substCo subst co1
 
 etaInfoApp subst (Case e b _ alts) eis 
   = Case (subst_expr subst e) b1 (coreAltsType alts') alts'
@@ -739,24 +739,24 @@ etaInfoApp subst e eis
     go e (EtaCo co    : eis) = go (Cast e co) eis
 
 --------------
-mkEtaWW :: Arity -> InScopeSet -> Type
+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
 	-> (InScopeSet, [EtaInfo])
 	-- EtaInfo contains fresh variables,
 	--   not free in the incoming CoreExpr
 	-- Outgoing InScopeSet includes the EtaInfo vars
 	--   and the original free vars
 
-mkEtaWW orig_n in_scope orig_ty
+mkEtaWW orig_n orig_expr in_scope orig_ty
   = go orig_n empty_subst orig_ty []
   where
-    empty_subst = mkTvSubst in_scope emptyTvSubstEnv
+    empty_subst = TvSubst in_scope emptyTvSubstEnv
 
     go n subst ty eis	    -- See Note [exprArity invariant]
        | n == 0
        = (getTvInScope subst, reverse eis)
 
        | Just (tv,ty') <- splitForAllTy_maybe ty
-       , let (subst', tv') = substTyVarBndr subst tv
+       , let (subst', tv') = Type.substTyVarBndr subst tv
            -- Avoid free vars of the original expression
        = go n subst' ty' (EtaVar tv' : eis)
 
@@ -772,11 +772,11 @@ mkEtaWW orig_n in_scope orig_ty
        		--  	eta_expand 1 e T
        		-- We want to get
        		--	coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
-         go n subst ty' (EtaCo (Type.substTy subst co) : eis)
+         go n subst ty' (EtaCo co : eis)
 
        | otherwise	 -- We have an expression of arity > 0, 
        	 		 -- but its type isn't a function. 		   
-       = WARN( True, ppr orig_n <+> ppr orig_ty )
+       = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
          (getTvInScope subst, reverse eis)
     	-- This *can* legitmately happen:
     	-- e.g.  coerce Int (\x. x) Essentially the programmer is
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index af414f7..88509f9 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -49,6 +49,7 @@ import Name
 import VarSet
 import Var
 import TcType
+import Coercion
 import Util
 import BasicTypes( Activation )
 import Outputable
@@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs
 expr_fvs :: CoreExpr -> FV
 
 expr_fvs (Type ty) 	 = someVars (tyVarsOfType ty)
+expr_fvs (Coercion co)   = someVars (tyCoVarsOfCo co)
 expr_fvs (Var var) 	 = oneVar var
 expr_fvs (Lit _)         = noVars
 expr_fvs (Note _ expr)   = expr_fvs expr
 expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-expr_fvs (Cast expr co)  = expr_fvs expr `union` someVars (tyVarsOfType co)
+expr_fvs (Cast expr co)  = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
 
 expr_fvs (Case scrut bndr ty alts)
   = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
@@ -248,10 +250,11 @@ exprOrphNames e
       where n = idName v
     go (Lit _) 	   	    = emptyNameSet
     go (Type ty)   	    = orphNamesOfType ty	-- Don't need free tyvars
+    go (Coercion co)        = orphNamesOfCo co
     go (App e1 e2) 	    = go e1 `unionNameSets` go e2
     go (Lam v e)   	    = go e `delFromNameSet` idName v
     go (Note _ e)           = go e
-    go (Cast e co)          = go e `unionNameSets` orphNamesOfType co
+    go (Cast e co)          = go e `unionNameSets` orphNamesOfCo co
     go (Let (NonRec _ r) e) = go e `unionNameSets` go r
     go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSets` go e
     go (Case e _ ty as)     = go e `unionNameSets` orphNamesOfType ty
@@ -392,15 +395,15 @@ varTypeTyVars :: Var -> TyVarSet
 -- Find the type variables free in the type of the variable
 -- Remember, coercion variables can mention type variables...
 varTypeTyVars var
-  | isLocalId var || isCoVar var = tyVarsOfType (idType var)
-  | otherwise = emptyVarSet	-- Global Ids and non-coercion TyVars
+  | isLocalId var = tyVarsOfType (idType var)
+  | otherwise     = emptyVarSet	-- Global Ids and non-coercion TyVars
 
 varTypeTcTyVars :: Var -> TyVarSet
 -- Find the type variables free in the type of the variable
 -- Remember, coercion variables can mention type variables...
 varTypeTcTyVars var
-  | isLocalId var || isCoVar var = tcTyVarsOfType (idType var)
-  | otherwise = emptyVarSet	-- Global Ids and non-coercion TyVars
+  | isLocalId var = tcTyVarsOfType (idType var)
+  | otherwise     = emptyVarSet	-- Global Ids and non-coercion TyVars
 
 idFreeVars :: Id -> VarSet
 -- Type variables, rule variables, and inline variables
@@ -411,7 +414,7 @@ idFreeVars id = ASSERT( isId id)
 bndrRuleAndUnfoldingVars ::Var -> VarSet
 -- A 'let' can bind a type variable, and idRuleVars assumes 
 -- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
 	                   | otherwise = idRuleAndUnfoldingVars v
 
 idRuleAndUnfoldingVars :: Id -> VarSet
@@ -510,12 +513,11 @@ freeVars (Let (Rec binds) body)
     body2     = freeVars body
     body_fvs  = freeVarsOf body2
 
-
 freeVars (Cast expr co)
-  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
+  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
   where
     expr2 = freeVars expr
-    cfvs  = tyVarsOfType co
+    cfvs  = tyCoVarsOfCo co
 
 freeVars (Note other_note expr)
   = (freeVarsOf expr2, AnnNote other_note expr2)
@@ -523,5 +525,7 @@ freeVars (Note other_note expr)
     expr2 = freeVars expr
 
 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
 \end{code}
 
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 5cc82a2..869f276 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -15,6 +15,7 @@ import Demand
 import CoreSyn
 import CoreFVs
 import CoreUtils
+import Pair
 import Bag
 import Literal
 import DataCon
@@ -27,6 +28,7 @@ import Id
 import PprCore
 import ErrUtils
 import SrcLoc
+import Kind
 import Type
 import TypeRep
 import Coercion
@@ -41,6 +43,7 @@ import FastString
 import Util
 import Control.Monad
 import Data.Maybe
+import Data.Traversable (traverse)
 \end{code}
 
 %************************************************************************
@@ -166,7 +169,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
          -- Check the rhs 
     do { ty <- lintCoreExpr rhs	
        ; lintBinder binder -- Check match to RHS type
-       ; binder_ty <- applySubst binder_ty
+       ; binder_ty <- applySubstTy binder_ty
        ; checkTys binder_ty ty (mkRhsMsg binder ty)
         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
        ; checkL (not (isUnLiftedType binder_ty)
@@ -207,14 +210,15 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 %************************************************************************
 
 \begin{code}
-type InType  = Type	-- Substitution not yet applied
-type InVar   = Var
-type InTyVar = TyVar
+type InType      = Type	-- Substitution not yet applied
+type InCoercion  = Coercion
+type InVar       = Var
+type InTyVar     = TyVar
 
-type OutType  = Type	-- Substitution has been applied to this
-type OutVar   = Var
-type OutTyVar = TyVar
-type OutCoVar = CoVar
+type OutType     = Type	-- Substitution has been applied to this
+type OutCoercion = Coercion
+type OutVar      = Var
+type OutTyVar    = TyVar
 
 lintCoreExpr :: CoreExpr -> LintM OutType
 -- The returned type has the substitution from the monad 
@@ -227,6 +231,9 @@ lintCoreExpr (Var var)
   = do	{ checkL (not (var == oneTupleDataConId))
 		 (ptext (sLit "Illegal one-tuple"))
 
+        ; checkL (isId var && not (isCoVar var))
+                 (ptext (sLit "Non term variable") <+> ppr var)
+
         ; checkDeadIdOcc var
 	; var' <- lookupIdInScope var
         ; return (idType var') }
@@ -236,7 +243,7 @@ lintCoreExpr (Lit lit)
 
 lintCoreExpr (Cast expr co)
   = do { expr_ty <- lintCoreExpr expr
-       ; co' <- applySubst co
+       ; co' <- applySubstCo co
        ; (from_ty, to_ty) <- lintCoercion co'
        ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
        ; return to_ty }
@@ -251,29 +258,20 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
         ; lintTyBndr tv              $ \ tv' -> 
           addLoc (BodyOfLetRec [tv]) $ 
           extendSubstL tv' ty'       $ do
-        { checkKinds tv' ty'              
+        { checkTyKind tv' ty'
 		-- Now extend the substitution so we 
 		-- take advantage of it in the body
         ; lintCoreExpr body } }
 
-  | isCoVar tv
-  = do { co <- applySubst ty
-       ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
-       ; lintTyBndr tv  $ \ tv' -> 
-         addLoc (BodyOfLetRec [tv]) $ do
-       { let (t1,t2) = coVarKind tv'
-       ; checkTys s1 t1 (mkTyVarLetErr tv ty)
-       ; checkTys s2 t2 (mkTyVarLetErr tv ty)
-       ; lintCoreExpr body } }
-
-  | otherwise
-  = failWithL (mkTyVarLetErr tv ty)	-- Not quite accurate
-
 lintCoreExpr (Let (NonRec bndr rhs) body)
+  | isId bndr
   = do	{ lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
-	; addLoc (BodyOfLetRec [bndr])
+	; addLoc (BodyOfLetRec [bndr]) 
 		 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
 
+  | otherwise
+  = failWithL (mkLetErr bndr rhs)	-- Not quite accurate
+
 lintCoreExpr (Let (Rec pairs) body) 
   = lintAndScopeIds bndrs	$ \_ ->
     do	{ checkL (null dups) (dupVars dups)
@@ -298,7 +296,7 @@ lintCoreExpr (Lam var expr)
 	 else
 	     return (mkForAllTy var' body_ty)
        }
-	-- The applySubst is needed to apply the subst to var
+	-- The applySubstTy is needed to apply the subst to var
 
 lintCoreExpr e@(Case scrut var alt_ty alts) =
        -- Check the scrutinee
@@ -338,6 +336,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
 lintCoreExpr (Type ty)
   = do { ty' <- lintInTy ty
        ; return (typeKind ty') }
+
+lintCoreExpr (Coercion co)
+  = do { co' <- lintInCo co
+       ; let Pair ty1 ty2 = coercionKind co'
+       ; return (mkPredTy $ EqPred ty1 ty2) }
 \end{code}
 
 %************************************************************************
@@ -352,12 +355,12 @@ subtype of the required type, as one would expect.
 \begin{code}
 lintCoreArg  :: OutType -> CoreArg -> LintM OutType
 lintCoreArg fun_ty (Type arg_ty)
-  = do	{ arg_ty' <- applySubst arg_ty
-        ; lintTyApp fun_ty arg_ty' }
+  = do { arg_ty' <- applySubstTy arg_ty
+       ; lintTyApp fun_ty arg_ty' }
 
 lintCoreArg fun_ty arg
- = do { arg_ty <- lintCoreExpr arg
-      ; lintValApp arg fun_ty arg_ty }
+  = do { arg_ty <- lintCoreExpr arg
+       ; lintValApp arg fun_ty arg_ty }
 
 -----------------
 lintAltBinders :: OutType     -- Scrutinee type
@@ -367,7 +370,7 @@ lintAltBinders :: OutType     -- Scrutinee type
 lintAltBinders scrut_ty con_ty [] 
   = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) 
 lintAltBinders scrut_ty con_ty (bndr:bndrs)
-  | isTyCoVar bndr
+  | isTyVar bndr
   = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
        ; lintAltBinders scrut_ty con_ty' bndrs }
   | otherwise
@@ -378,11 +381,10 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs)
 lintTyApp :: OutType -> OutType -> LintM OutType
 lintTyApp fun_ty arg_ty
   | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
-  = do	{ checkKinds tyvar arg_ty
-	; if isCoVar tyvar then 
-             return body_ty   -- Co-vars don't appear in body_ty!
-          else 
-             return (substTyWith [tyvar] [arg_ty] body_ty) }
+  , isTyVar tyvar
+  = do	{ checkTyKind tyvar arg_ty
+        ; return (substTyWith [tyvar] [arg_ty] body_ty) }
+
   | otherwise
   = failWithL (mkTyAppMsg fun_ty arg_ty)
    
@@ -400,22 +402,34 @@ lintValApp arg fun_ty arg_ty
 \end{code}
 
 \begin{code}
-checkKinds :: OutVar -> OutType -> LintM ()
+checkTyKind :: OutTyVar -> OutType -> LintM ()
 -- Both args have had substitution applied
-checkKinds tyvar arg_ty
+checkTyKind tyvar arg_ty
 	-- Arg type might be boxed for a function with an uncommitted
 	-- tyvar; notably this is used so that we can give
 	-- 	error :: forall a:*. String -> a
 	-- and then apply it to both boxed and unboxed types.
-  | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty
-                       ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2)
-                                (addErrL (mkCoAppErrMsg tyvar arg_ty)) }
-  | otherwise     = do { arg_kind <- lintType arg_ty
-                       ; unless (arg_kind `isSubKind` tyvar_kind)
-                                (addErrL (mkKindErrMsg tyvar arg_ty)) }
+  = do { arg_kind <- lintType arg_ty
+       ; unless (arg_kind `isSubKind` tyvar_kind)
+                (addErrL (mkKindErrMsg tyvar arg_ty)) }
   where
     tyvar_kind = tyVarKind tyvar
-    (s1,t1)    = coVarKind tyvar
+
+-- Check that the kinds of a type variable and a coercion match, that
+-- is, if tv :: k  then co :: t1 ~ t2  where t1 :: k and t2 :: k.
+checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
+checkTyCoKind tv co
+  = do { (t1,t2) <- lintCoercion co
+       ; k1      <- lintType t1
+       ; k2      <- lintType t2
+       ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+                (addErrL (mkTyCoAppErrMsg tv co))
+       ; return (t1,t2) }
+  where 
+    tyvar_kind = tyVarKind tv
+
+checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
+checkTyCoKinds = zipWithM checkTyCoKind
 
 checkDeadIdOcc :: Id -> LintM ()
 -- Occurrences of an Id should never be dead....
@@ -536,7 +550,7 @@ lintBinder var linterF
 lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
 lintTyBndr tv thing_inside
   = do { subst <- getTvSubst
-       ; let (subst', tv') = substTyVarBndr subst tv
+       ; let (subst', tv') = Type.substTyVarBndr subst tv
        ; lintTyBndrKind tv'
        ; updateTvSubst subst' (thing_inside tv') }
 
@@ -581,10 +595,19 @@ lintInTy :: InType -> LintM OutType
 -- ToDo: check the kind structure of the type
 lintInTy ty 
   = addLoc (InType ty) $
-    do	{ ty' <- applySubst ty
+    do	{ ty' <- applySubstTy ty
 	; _ <- lintType ty'
 	; return ty' }
 
+lintInCo :: InCoercion -> LintM OutCoercion
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+  = addLoc (InCo co) $
+    do  { co' <- applySubstCo co
+        ; _   <- lintCoercion co'
+        ; return co' }
+
 -------------------
 lintKind :: Kind -> LintM ()
 -- Check well-formedness of kinds: *, *->*, etc
@@ -598,124 +621,71 @@ lintKind kind
 
 -------------------
 lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv 
-  | isCoVar tv = lintCoVarKind tv
-  | otherwise  = lintKind (tyVarKind tv)
-
--------------------
-lintCoVarKind :: OutCoVar -> LintM ()
--- Check the kind of a coercion binder
-lintCoVarKind tv
-  = do { (ty1,ty2) <- lintSplitCoVar tv
-       ; k1 <- lintType ty1
-       ; k2 <- lintType ty2
-       ; unless (k1 `eqKind` k2) 
-                (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:")
-                              , nest 2 (quotes (ppr tv))
-                              , ppr [k1,k2] ])) }
+lintTyBndrKind tv = lintKind (tyVarKind tv)
 
 -------------------
-lintSplitCoVar :: CoVar -> LintM (Type,Type)
-lintSplitCoVar cv
-  = case coVarKind_maybe cv of
-      Just ts -> return ts
-      Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
-                                , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
-
--------------------
-lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
+lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
-lintCoercion co 
-  = addLoc (InCoercion co) $ lintCoercion' co
-
-lintCoercion' ty@(TyVarTy tv)
-  = do { checkTyVarInScope tv
-       ; if isCoVar tv then return (coVarKind tv) 
-                       else return (ty, ty) }
-
-lintCoercion' ty@(AppTy ty1 ty2) 
-  = do { (s1,t1) <- lintCoercion ty1
-       ; (s2,t2) <- lintCoercion ty2
-       ; check_co_app ty (typeKind s1) [s2]
-       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
-
-lintCoercion' ty@(FunTy ty1 ty2)
-  = do { (s1,t1) <- lintCoercion ty1
-       ; (s2,t2) <- lintCoercion ty2
-       ; check_co_app ty (tyConKind funTyCon) [s1, s2]
-       ; return (FunTy s1 s2, FunTy t1 t2) }
-
-lintCoercion' ty@(TyConApp tc tys) 
-  | Just (ar, desc) <- isCoercionTyCon_maybe tc
-  = do { unless (tys `lengthAtLeast` ar) (badCo ty)
-       ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
-       ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
-       ; check_co_app ty (typeKind s) ss
-       ; return (mkAppTys s ss, mkAppTys t ts) }
+lintCoercion (Refl ty)
+  = do { ty' <- lintInTy ty
+       ; return (ty', ty') }
 
-  | not (tyConHasKind tc)	-- Just something bizarre like SuperKindTyCon
-  = badCo ty
+lintCoercion co@(TyConAppCo tc cos)
+  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+       ; check_co_app co (tyConKind tc) ss
+       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
 
-  | otherwise
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
-       ; check_co_app ty (tyConKind tc) ss
-       ; return (TyConApp tc ss, TyConApp tc ts) }
-
-lintCoercion' ty@(PredTy (ClassP cls tys))
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
-       ; check_co_app ty (tyConKind (classTyCon cls)) ss
-       ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
-
-lintCoercion' (PredTy (IParam n p_ty))
-  = do { (s,t) <- lintCoercion p_ty
-       ; return (PredTy (IParam n s), PredTy (IParam n t)) }
-
-lintCoercion' ty@(PredTy (EqPred {}))
-  = failWithL (badEq ty)
-
-lintCoercion' (ForAllTy tv ty)
-  | isCoVar tv
-  = do { (co1, co2) <- lintSplitCoVar tv
-       ; (s1,t1)    <- lintCoercion co1
-       ; (s2,t2)    <- lintCoercion co2
-       ; (sr,tr)    <- lintCoercion ty
-       ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) }
+lintCoercion co@(AppCo co1 co2)
+  = do { (s1,t1) <- lintCoercion co1
+       ; (s2,t2) <- lintCoercion co2
+       ; check_co_app co (typeKind s1) [s2]
+       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
 
-  | otherwise
-  = do { lintKind (tyVarKind tv)
-       ; (s,t) <- addInScopeVar tv (lintCoercion ty)
-       ; return (ForAllTy tv s, ForAllTy tv t) }
-
-badCo :: Coercion -> LintM a
-badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
-
----------------
-lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
--- Always called with correct number of coercion arguments
--- First arg is just for error message
-lintCoTyConApp _ CoLeft  (co:_) = lintLR   fst 	    co 
-lintCoTyConApp _ CoRight (co:_) = lintLR   snd 	    co   
-lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3   co 
-lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3   co 
-lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co 
-
-lintCoTyConApp _ CoSym (co:_) 
-  = do { (ty1,ty2) <- lintCoercion co
-       ; return (ty2,ty1) }
-
-lintCoTyConApp co CoTrans (co1:co2:_) 
+lintCoercion (ForAllCo v co)
+  = do { lintKind (tyVarKind v)
+       ; (s,t) <- addInScopeVar v (lintCoercion co)
+       ; return (ForAllTy v s, ForAllTy v t) }
+
+lintCoercion (CoVarCo cv)
+  = do { checkTyCoVarInScope cv
+       ; return (coVarKind cv) }
+
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+                                   , co_ax_lhs = lhs
+                                   , co_ax_rhs = rhs }) 
+                           cos)
+  = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
+       ; return (substTyWith tvs tys1 lhs,
+                 substTyWith tvs tys2 rhs) }
+
+lintCoercion (UnsafeCo ty1 ty2)
+  = do { ty1' <- lintInTy ty1
+       ; ty2' <- lintInTy ty2
+       ; return (ty1', ty2') }
+
+lintCoercion (SymCo co) 
+  = do { (ty1, ty2) <- lintCoercion co
+       ; return (ty2, ty1) }
+
+lintCoercion co@(TransCo co1 co2)
   = do { (ty1a, ty1b) <- lintCoercion co1
        ; (ty2a, ty2b) <- lintCoercion co2
-       ; checkL (ty1b `coreEqType` ty2a)
+       ; checkL (ty1b `eqType` ty2a)
                 (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
                     2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
        ; return (ty1a, ty2b) }
 
-lintCoTyConApp _ CoInst (co:arg_ty:_) 
-  = do { co_tys <- lintCoercion co
+lintCoercion the_co@(NthCo d co)
+  = do { (s,t) <- lintCoercion co
+       ; sn <- checkTcApp the_co d s
+       ; tn <- checkTcApp the_co d t
+       ; return (sn, tn) }
+
+lintCoercion (InstCo co arg_ty)
+  = do { co_tys    <- lintCoercion co
        ; arg_kind  <- lintType arg_ty
-       ; case decompInst_maybe co_tys of
-          Just ((tv1,tv2), (ty1,ty2)) 
+       ; case splitForAllTy_maybe `traverse` toPair co_tys of
+          Just (Pair (tv1,ty1) (tv2,ty2))
             | arg_kind `isSubKind` tyVarKind tv1
             -> return (substTyWith [tv1] [arg_ty] ty1, 
                        substTyWith [tv2] [arg_ty] ty2) 
@@ -723,40 +693,20 @@ lintCoTyConApp _ CoInst (co:arg_ty:_)
             -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
 	  Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
 
-lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs 
-                          , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
-  = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
-       ; sequence_ (zipWith checkKinds tvs tys1)
-       ; return (substTyWith tvs tys1 lhs_ty,
-                 substTyWith tvs tys2 rhs_ty) }
-
-lintCoTyConApp _ CoUnsafe (ty1:ty2:_) 
-  = do { _ <- lintType ty1
-       ; _ <- lintType ty2	-- Ignore kinds; it's unsafe!
-       ; return (ty1,ty2) } 
-
-lintCoTyConApp _ _ _ = panic "lintCoTyConApp"  -- Called with wrong number of coercion args
-
 ----------
-lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
-lintLR sel co
-  = do { (ty1,ty2) <- lintCoercion co
-       ; case decompLR_maybe (ty1,ty2) of
-           Just res -> return (sel res)
-           Nothing  -> failWithL (ptext (sLit "Bad argument of left/right")) }
-
-----------
-lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
-lintCsel sel co
-  = do { (ty1,ty2) <- lintCoercion co
-       ; case decompCsel_maybe (ty1,ty2) of
-           Just res -> return (sel res)
-           Nothing  -> failWithL (ptext (sLit "Bad argument of csel")) }
+checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp co n ty
+  | Just (_, tys) <- splitTyConApp_maybe ty
+  , n < length tys
+  = return (tys !! n)
+  | otherwise
+  = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co)
+                  2 (ptext (sLit "Offending type:") <+> ppr ty))
 
 -------------------
 lintType :: OutType -> LintM Kind
 lintType (TyVarTy tv)
-  = do { checkTyVarInScope tv
+  = do { checkTyCoVarInScope tv
        ; return (tyVarKind tv) }
 
 lintType ty@(AppTy t1 t2) 
@@ -767,6 +717,8 @@ lintType ty@(FunTy t1 t2)
   = lint_ty_app ty (tyConKind funTyCon) [t1,t2]
 
 lintType ty@(TyConApp tc tys)
+  | tc `hasKey` eqPredPrimTyConKey	-- See Note [The (~) TyCon] in TysPrim
+  = lint_eq_pred ty tys
   | tyConHasKind tc
   = lint_ty_app ty (tyConKind tc) tys
   | otherwise
@@ -782,15 +734,31 @@ lintType ty@(PredTy (ClassP cls tys))
 lintType (PredTy (IParam _ p_ty))
   = lintType p_ty
 
-lintType ty@(PredTy (EqPred {}))
-  = failWithL (badEq ty)
+lintType ty@(PredTy (EqPred t1 t2))
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; unless (k1 `eqKind` k2) 
+                (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
+                              , nest 2 (ppr ty) ]))
+       ; return unliftedTypeKind }
 
 ----------------
 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
 lint_ty_app ty k tys 
   = do { ks <- mapM lintType tys
        ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
-                      
+
+lint_eq_pred :: Type -> [OutType] -> LintM Kind
+lint_eq_pred ty arg_tys
+  | [ty1,ty2] <- arg_tys
+  = do { k1 <- lintType ty1
+       ; k2 <- lintType ty2
+       ; checkL (k1 `eqKind` k2) 
+                (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
+       ; return unliftedTypeKind }
+  | otherwise
+  = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty)
+
 ----------------
 check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
 check_co_app ty k tys 
@@ -812,10 +780,6 @@ lint_kind_app doc kfn ks = go kfn ks
 		      Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
                                                      (addErrL fail_msg)
                                             ; go kfb ks } 
---------------
-badEq :: Type -> SDoc
-badEq ty = hang (ptext (sLit "Unexpected equality predicate:"))
-              1 (quotes (ppr ty))
 \end{code}
     
 %************************************************************************
@@ -870,7 +834,7 @@ data LintLocInfo
   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
   | TopLevelBindings
   | InType Type		-- Inside a type
-  | InCoercion Coercion	-- Inside a type
+  | InCo   Coercion     -- Inside a coercion
 \end{code}
 
                  
@@ -936,12 +900,15 @@ updateTvSubst subst' m =
 getTvSubst :: LintM TvSubst
 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 
-applySubst :: Type -> LintM Type
-applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
+applySubstTy :: Type -> LintM Type
+applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
+
+applySubstCo :: Coercion -> LintM Coercion
+applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
 
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendSubstL tv ty m
-  = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
+  = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
 \end{code}
 
 \begin{code}
@@ -969,8 +936,8 @@ checkBndrIdInScope binder id
      msg = ptext (sLit "is out of scope inside info for") <+> 
 	   ppr binder
 
-checkTyVarInScope :: TyVar -> LintM ()
-checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
+checkTyCoVarInScope :: TyCoVar -> LintM ()
+checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
 
 checkInScope :: SDoc -> Var -> LintM ()
 checkInScope loc_msg var =
@@ -982,7 +949,7 @@ checkTys :: OutType -> OutType -> Message -> LintM ()
 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 -- annotations need only be consistent, not equal)
 -- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
 \end{code}
 
 %************************************************************************
@@ -1021,8 +988,8 @@ dumpLoc TopLevelBindings
   = (noSrcLoc, empty)
 dumpLoc (InType ty)
   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
-dumpLoc (InCoercion ty)
-  = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
 
 pp_binders :: [Var] -> SDoc
 pp_binders bs = sep (punctuate comma (map pp_binder bs))
@@ -1114,29 +1081,21 @@ mkNonFunAppMsg fun_ty arg_ty arg
 	      hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 	      hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 
-mkTyVarLetErr :: TyVar -> Type -> Message
-mkTyVarLetErr tyvar ty
-  = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
-	  hang (ptext (sLit "Type/coercion variable:"))
-		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
-	  hang (ptext (sLit "Arg type/coercion:"))   
-	         4 (ppr ty)]
-
-mkKindErrMsg :: TyVar -> Type -> Message
-mkKindErrMsg tyvar arg_ty
-  = vcat [ptext (sLit "Kinds don't match in type application:"),
-	  hang (ptext (sLit "Type variable:"))
-		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
-	  hang (ptext (sLit "Arg type:"))   
-	         4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-
-mkCoAppErrMsg :: TyVar -> Type -> Message
-mkCoAppErrMsg tyvar arg_ty
-  = vcat [ptext (sLit "Kinds don't match in coercion application:"),
-	  hang (ptext (sLit "Coercion variable:"))
+mkLetErr :: TyVar -> CoreExpr -> Message
+mkLetErr bndr rhs
+  = vcat [ptext (sLit "Bad `let' binding:"),
+	  hang (ptext (sLit "Variable:"))
+		 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+	  hang (ptext (sLit "Rhs:"))   
+	         4 (ppr rhs)]
+
+mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
+mkTyCoAppErrMsg tyvar arg_co
+  = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
+          hang (ptext (sLit "Type variable:"))
 		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 	  hang (ptext (sLit "Arg coercion:"))   
-	         4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))]
+	         4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
 
 mkTyAppMsg :: Type -> Type -> Message
 mkTyAppMsg ty arg_ty
@@ -1168,6 +1127,15 @@ mkStrictMsg binder
 	      hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
 	     ]
 
+
+mkKindErrMsg :: TyVar -> Type -> Message
+mkKindErrMsg tyvar arg_ty
+  = vcat [ptext (sLit "Kinds don't match in type application:"),
+	  hang (ptext (sLit "Type variable:"))
+		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+	  hang (ptext (sLit "Arg type:"))   
+	         4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
 mkArityMsg :: Id -> Message
 mkArityMsg binder
   = vcat [hsep [ptext (sLit "Demand type has "),
@@ -1203,3 +1171,56 @@ dupExtVars vars
   = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
        2 (ppr vars)
 \end{code}
+
+-------------- DEAD CODE  -------------------
+
+-------------------
+checkCoKind :: CoVar -> OutCoercion -> LintM ()
+-- Both args have had substitution applied
+checkCoKind covar arg_co
+  = do { (s2,t2) <- lintCoercion arg_co
+       ; unless (s1 `eqType` s2 && t1 `coreEqType` t2)
+                (addErrL (mkCoAppErrMsg covar arg_co)) }
+  where
+    (s1,t1) = coVarKind covar
+
+lintCoVarKind :: OutCoVar -> LintM ()
+-- Check the kind of a coercion binder
+lintCoVarKind tv
+  = do { (ty1,ty2) <- lintSplitCoVar tv
+       ; lintEqType ty1 ty2
+
+
+-------------------
+lintSplitCoVar :: CoVar -> LintM (Type,Type)
+lintSplitCoVar cv
+  = case coVarKind_maybe cv of
+      Just ts -> return ts
+      Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
+                                , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
+
+mkCoVarLetErr :: CoVar -> Coercion -> Message
+mkCoVarLetErr covar co
+  = vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
+	  hang (ptext (sLit "Coercion variable:"))
+		 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+	  hang (ptext (sLit "Arg coercion:"))   
+	         4 (ppr co)]
+
+mkCoAppErrMsg :: CoVar -> Coercion -> Message
+mkCoAppErrMsg covar arg_co
+  = vcat [ptext (sLit "Kinds don't match in coercion application:"),
+	  hang (ptext (sLit "Coercion variable:"))
+		 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+	  hang (ptext (sLit "Arg coercion:"))   
+	         4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
+
+
+mkCoAppMsg :: Type -> Coercion -> Message
+mkCoAppMsg ty arg_co
+  = vcat [text "Illegal type application:",
+	      hang (ptext (sLit "exp type:"))
+		 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+	      hang (ptext (sLit "arg type:"))   
+	         4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))]
+
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 42379b4..0405716 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -37,6 +37,7 @@ import OrdList
 import ErrUtils
 import DynFlags
 import Util
+import Pair
 import Outputable
 import MonadUtils
 import FastString
@@ -78,9 +79,9 @@ The goal of this pass is to prepare for code generation.
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 
-    We don't clone TyVars. The code gen doesn't need that, 
+    We don't clone TyVars or CoVars. The code gen doesn't need that, 
     and doing so would be tiresome because then we'd need
-    to substitute in types.
+    to substitute in types and coercions.
 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
@@ -104,19 +105,21 @@ Invariants
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 
-       triv ::= lit |  var  | triv ty  |  /\a. triv  |  triv |> co
+       triv ::= lit |  var  
+              | triv ty  |  /\a. triv 
+              | truv co  |  /\c. triv  |  triv |> co
 
     Applications
-       app ::= lit  |  var  |  app triv  |  app ty  |  app |> co
+       app ::= lit  |  var  |  app triv  |  app ty  | app co | app |> co
 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body
-	      | /\a. body
+	      | /\a. body | /\c. body 
               | body |> co
 
-    Right hand sides (only place where lambdas can occur)
+    Right hand sides (only place where value lambdas can occur)
        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions
@@ -440,9 +443,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- For example
 --	f (g x)	  ===>   ([v = g x], f v)
 
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})       = cpeApp env expr
 
 cpeRhsE env (Var f `App` _ `App` arg)
   | f `hasKey` lazyIdKey  	  -- Replace (lazy a) by a
@@ -528,7 +532,7 @@ rhsToBody (Cast e co)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)
-  | all isTyCoVar bndrs		-- Type lambdas are ok
+  | all isTyVar bndrs		-- Type lambdas are ok
   = return (emptyFloats, expr)
   | otherwise			-- Some value lambdas
   = do { fn <- newVar (exprType expr)
@@ -579,6 +583,10 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 
+    collect_args (App fun arg@(Coercion arg_co)) depth
+      = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+           ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
       	   ; let
@@ -608,7 +616,7 @@ cpeApp env expr
 		-- partial application might be seq'd
 
     collect_args (Cast fun co) depth
-      = do { let (_ty1,ty2) = coercionKind co
+      = do { let Pair _ty1 ty2 = coercionKind co
            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           
@@ -751,11 +759,12 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
+cpe_ExprIsTrivial (Coercion _)             = True
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 \end{code}
 
@@ -1070,7 +1079,7 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr
-  | isLocalId bndr
+  | isLocalId bndr, not (isCoVar bndr)
   = do bndr' <- setVarUnique bndr <$> getUniqueM
        
        -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
@@ -1082,7 +1091,7 @@ cloneBndr env bndr
 
   | otherwise	-- Top level things, which we don't want
 		-- to clone, have become GlobalIds by now
-		-- And we don't clone tyvars
+		-- And we don't clone tyvars, or coercion variables
   = return (env, bndr)
   
 
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index a229b8c..047e6c3 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -12,14 +12,15 @@ module CoreSubst (
 
         -- ** Substituting into expressions and related types
 	deShadowBinds, substSpec, substRulesForImportedIds,
-	substTy, substExpr, substExprSC, substBind, substBindSC,
+	substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
-	substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
+	substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
 
         -- ** Operations on substitutions
 	emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
  	extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
-	extendSubst, extendSubstList, zapSubstEnv,
+        extendCvSubst, extendCvSubstList,
+	extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
         addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
         isInScope, setInScope,
         delBndr, delBndrs,
@@ -37,18 +38,23 @@ module CoreSubst (
 import CoreSyn
 import CoreFVs
 import CoreUtils
-import PprCore
 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 
 import qualified Type
-import Type     ( Type, TvSubst(..), TvSubstEnv )
-import Coercion	   ( isIdentityCoercion )
+import qualified Coercion
+
+	-- We are defining local versions
+import Type     hiding ( substTy, extendTvSubst, extendTvSubstList
+                       , isInScope, substTyVarBndr )
+import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
+
 import OptCoercion ( optCoercion )
+import PprCore     ( pprCoreBindings )
 import VarSet
 import VarEnv
 import Id
 import Name	( Name )
-import Var      ( Var, TyVar, setVarUnique )
+import Var
 import IdInfo
 import Unique
 import UniqSupply
@@ -92,7 +98,8 @@ data Subst
   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
                       -- applying the substitution
           IdSubstEnv  -- Substitution for Ids
-          TvSubstEnv  -- Substitution for TyVars
+          TvSubstEnv  -- Substitution from TyVars to Types
+          CvSubstEnv  -- Substitution from TyCoVars to Coercions
 
 	-- INVARIANT 1: See #in_scope_invariant#
 	-- This is what lets us deal with name capture properly
@@ -126,6 +133,11 @@ In consequence:
 
 * In substIdBndr, we extend the IdSubstEnv only when the unique changes
 
+* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
+  substExpr does nothing (Note that the above rule for substIdBndr
+  maintains this property.  If the incoming envts are both empty, then
+  substituting the type and IdInfo can't change anything.)
+
 * In lookupIdSubst, we *must* look up the Id in the in-scope set, because
   it may contain non-trivial changes.  Example:
 	(/\a. \x:a. ...x...) Int
@@ -140,7 +152,8 @@ In consequence:
 * (However, we don't need to do so for expressions found in the IdSubst
   itself, whose range is assumed to be correct wrt the in-scope set.)
 
-Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
+Why do we make a different choice for the IdSubstEnv than the
+TvSubstEnv and CvSubstEnv?
 
 * For Ids, we change the IdInfo all the time (e.g. deleting the
   unfolding), and adding it back later, so using the TyVar convention
@@ -158,70 +171,82 @@ type IdSubstEnv = IdEnv CoreExpr
 
 ----------------------------
 isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
+isEmptySubst (Subst _ id_env tv_env cv_env) 
+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
 
 emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
 
 mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
-
-mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs ids = Subst in_scope ids tvs
-
--- getTvSubst :: Subst -> TvSubst
--- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 
--- getTvSubstEnv :: Subst -> TvSubstEnv
--- getTvSubstEnv (Subst _ _ tv_env) = tv_env
--- 
--- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
--- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
+mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
+mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
 
 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
 substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _ _) = in_scope
+substInScope (Subst in_scope _ _ _) = in_scope
 
 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
 -- while preserving the in-scope set
 zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 
 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
 
 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
 
 -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 extendTvSubst :: Subst -> TyVar -> Type -> Subst
-extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) 
+extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
 
 -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
-extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
 
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also
--- 'extendIdSubst' and 'extendTvSubst'
-extendSubst :: Subst -> Var -> CoreArg -> Subst
-extendSubst (Subst in_scope ids tvs) tv (Type ty)
-  = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
-extendSubst (Subst in_scope ids tvs) id expr
-  = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
+-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst
+extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)
+
+-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the
+-- 'Subst': see also 'extendCvSubst'
+extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst
+extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
 
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst'
+-- | Add a substitution appropriate to the thing being substituted
+--   (whether an expression, type, or coercion). See also
+--   'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
+extendSubst :: Subst -> Var -> CoreArg -> Subst
+extendSubst subst var arg
+  = case arg of
+      Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty
+      Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
+      _           -> ASSERT( isId    var ) extendIdSubst subst var arg
+
+extendSubstWithVar :: Subst -> Var -> Var -> Subst
+extendSubstWithVar subst v1 v2
+  | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
+  | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
+  | otherwise  = ASSERT( isId    v2 ) extendIdSubst subst v1 (Var v2)
+
+-- | Add a substitution as appropriate to each of the terms being
+--   substituted (whether expressions, types, or coercions). See also
+--   'extendSubst'.
 extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
 extendSubstList subst []	      = subst
 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
 
 -- | Find the substitution for an 'Id' in the 'Subst'
 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _) v
+lookupIdSubst doc (Subst in_scope ids _ _) v
   | not (isLocalId v) = Var v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
@@ -231,18 +256,22 @@ lookupIdSubst doc (Subst in_scope ids _) v
 
 -- | Find the substitution for a 'TyVar' in the 'Subst'
 lookupTvSubst :: Subst -> TyVar -> Type
-lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+
+-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst'
+lookupCvSubst :: Subst -> CoVar -> Coercion
+lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
 
 delBndr :: Subst -> Var -> Subst
-delBndr (Subst in_scope tvs ids) v
-  | isId v    = Subst in_scope tvs (delVarEnv ids v)
-  | otherwise = Subst in_scope (delVarEnv tvs v) ids
+delBndr (Subst in_scope ids tvs cvs) v
+  | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
+  | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
+  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
 
 delBndrs :: Subst -> [Var] -> Subst
-delBndrs (Subst in_scope tvs ids) vs
-  = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id)
-  where
-    (vs_id, vs_tv) = partition isId vs
+delBndrs (Subst in_scope ids tvs cvs) vs
+  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
+      -- Easist thing is just delete all from all!
 
 -- | Simultaneously substitute for a bunch of variables
 --   No left-right shadowing
@@ -252,49 +281,51 @@ mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
 mkOpenSubst in_scope pairs = Subst in_scope
 	    	          	   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
 			  	   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
 
 ------------------------------
 isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
 
 -- | Add the 'Var' to the in-scope set, but do not remove
 -- any existing substitutions for it
 addInScopeSet :: Subst -> VarSet -> Subst
-addInScopeSet (Subst in_scope ids tvs) vs
-  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs
+addInScopeSet (Subst in_scope ids tvs cvs) vs
+  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
 
 -- | Add the 'Var' to the in-scope set: as a side effect,
 -- and remove any existing substitutions for it
 extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
+extendInScope (Subst in_scope ids tvs cvs) v
   = Subst (in_scope `extendInScopeSet` v) 
-	  (ids `delVarEnv` v) (tvs `delVarEnv` v)
+	  (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
 
 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
 extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs) vs
+extendInScopeList (Subst in_scope ids tvs cvs) vs
   = Subst (in_scope `extendInScopeSetList` vs) 
-	  (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
+	  (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
 
 -- | Optimized version of 'extendInScopeList' that can be used if you are certain 
--- all the things being added are 'Id's and hence none are 'TyVar's
+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
 extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs 
+extendInScopeIds (Subst in_scope ids tvs cvs) vs 
   = Subst (in_scope `extendInScopeSetList` vs) 
-	  (ids `delVarEnvList` vs) tvs
+	  (ids `delVarEnvList` vs) tvs cvs
 
 setInScope :: Subst -> InScopeSet -> Subst
-setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs
+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
 \end{code}
 
 Pretty printing, for debugging only
 
 \begin{code}
 instance Outputable Subst where
-  ppr (Subst in_scope ids tvs) 
+  ppr (Subst in_scope ids tvs cvs) 
 	=  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
 	$$ ptext (sLit " IdSubst   =") <+> ppr ids
 	$$ ptext (sLit " TvSubst   =") <+> ppr tvs
+        $$ ptext (sLit " CvSubst   =") <+> ppr cvs   
  	 <> char '>'
 \end{code}
 
@@ -326,10 +357,11 @@ subst_expr subst expr
   where
     go (Var v)	       = lookupIdSubst (text "subst_expr") subst v 
     go (Type ty)       = Type (substTy subst ty)
+    go (Coercion co)   = Coercion (substCo subst co)
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+    go (Cast e co)     = Cast (go e) (substCo subst co)
        -- Do not optimise even identity coercions
        -- Reason: substitution applies to the LHS of RULES, and
        --         if you "optimise" an identity coercion, you may
@@ -416,8 +448,9 @@ preserve occ info in rules.
 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
 substBndr :: Subst -> Var -> (Subst, Var)
 substBndr subst bndr
-  | isTyCoVar bndr  = substTyVarBndr subst bndr
-  | otherwise       = substIdBndr (text "var-bndr") subst subst bndr
+  | isTyVar bndr  = substTyVarBndr subst bndr
+  | isCoVar bndr  = substCoVarBndr subst bndr
+  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
 
 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
 substBndrs :: Subst -> [Var] -> (Subst, [Var])
@@ -439,9 +472,9 @@ substIdBndr :: SDoc
 	    -> (Subst, Id)	-- ^ Transformed pair
 				-- NB: unfolding may be zapped
 
-substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
-    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
   where
     id1 = uniqAway in_scope old_id	-- id1 is cloned if necessary
     id2 | no_type_change = id1
@@ -498,8 +531,8 @@ clone_id    :: Subst			-- Substitution for the IdInfo
 	    -> Subst -> (Id, Unique)	-- Substitition and Id to transform
 	    -> (Subst, Id)		-- Transformed pair
 
-clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
-  = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq)
+  = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
   where
     id1	    = setVarUnique old_id uniq
     id2     = substIdType subst id1
@@ -510,26 +543,40 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
 
 %************************************************************************
 %*									*
-		Types
+		Types and Coercions
 %*									*
 %************************************************************************
 
-For types we just call the corresponding function in Type, but we have
-to repackage the substitution, from a Subst to a TvSubst
+For types and coercions we just call the corresponding functions in
+Type and Coercion, but we have to repackage the substitution, from a
+Subst to a TvSubst.
 
 \begin{code}
 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
-substTyVarBndr (Subst in_scope id_env tv_env) tv
+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 	(TvSubst in_scope' tv_env', tv') 
-	   -> (Subst in_scope' id_env tv_env', tv')
+	   -> (Subst in_scope' id_env tv_env' cv_env, tv')
+
+substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
+  = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
+	(CvSubst in_scope' tv_env' cv_env', cv') 
+	   -> (Subst in_scope' id_env tv_env' cv_env', cv')
 
 -- | See 'Type.substTy'
 substTy :: Subst -> Type -> Type 
 substTy subst ty = Type.substTy (getTvSubst subst) ty
 
 getTvSubst :: Subst -> TvSubst
-getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
+getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv
+
+getCvSubst :: Subst -> CvSubst
+getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
+
+-- | See 'Coercion.substCo'
+substCo :: Subst -> Coercion -> Coercion
+substCo subst co = Coercion.substCo (getCvSubst subst) co
 \end{code}
 
 
@@ -541,8 +588,8 @@ getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
 
 \begin{code}
 substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst _ _ tv_env) id
-  | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
+substIdType subst@(Subst _ _ tv_env cv_env) id
+  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
   | otherwise	= setIdType id (substTy subst old_ty)
 		-- The tyVarsOfType is cheaper than it looks
 		-- because we cache the free tyvars of the type
@@ -555,7 +602,7 @@ substIdType subst@(Subst _ _ tv_env) id
 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 substIdInfo subst new_id info
   | nothing_to_do = Nothing
-  | otherwise     = Just (info `setSpecInfo`   	  substSpec subst new_id old_rules
+  | otherwise     = Just (info `setSpecInfo`      substSpec subst new_id old_rules
 			       `setUnfoldingInfo` substUnfolding subst old_unf)
   where
     old_rules 	  = specInfo info
@@ -594,7 +641,7 @@ substUnfolding _ unf = unf	-- NoUnfolding, OtherCon
 
 -------------------
 substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
-substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
   | Just wkr_expr <- lookupVarEnv ids wkr 
   = case wkr_expr of
       Var w1 -> InlineWrapper w1
@@ -628,7 +675,7 @@ substSpec subst new_id (SpecInfo rules rhs_fvs)
   where
     subst_ru_fn = const (idName new_id)
     new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
-                         (substVarSet subst rhs_fvs)
+                        (substVarSet subst rhs_fvs)
 
 ------------------
 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
@@ -646,7 +693,6 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 --    - Rules for *local* Ids are in the IdInfo for that Id,
 --      and the ru_fn field is simply replaced by the new name 
 --	of the Id
-
 substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
                                        , ru_fn = fn_name, ru_rhs = rhs
@@ -664,7 +710,7 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
 
 ------------------
 substVarSet :: Subst -> VarSet -> VarSet
-substVarSet subst fvs 
+substVarSet subst fvs
   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
   where
     subst_fv subst fv 
@@ -713,7 +759,7 @@ simpleOptExpr expr
 	-- won't *be* substituting for x if it occurs inside a
 	-- lambda.  
 	--
-	-- It's a bit painful to call exprFreeVars, because it makes
+        -- It's a bit painful to call exprFreeVars, because it makes
 	-- three passes instead of two (occ-anal, and go)
 
 simpleOptExprWith :: Subst -> InExpr -> OutExpr
@@ -747,19 +793,22 @@ type OutExpr = CoreExpr
 -- In these functions the substitution maps InVar -> OutExpr
 
 ----------------------
-simple_opt_expr :: Subst -> InExpr -> OutExpr
-simple_opt_expr subst expr
+simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
+simple_opt_expr s e = simple_opt_expr' s e
+
+simple_opt_expr' subst expr
   = go expr
   where
     go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
     go (App e1 e2)      = simple_app subst e1 [go e2]
-    go (Type ty)        = Type (substTy subst ty)
+    go (Type ty)        = Type     (substTy subst ty)
+    go (Coercion co)    = Coercion (optCoercion (getCvSubst subst) co)
     go (Lit lit)        = Lit lit
     go (Note note e)    = Note note (go e)
-    go (Cast e co)      | isIdentityCoercion co' = go e
-       	                | otherwise              = Cast (go e) co' 
+    go (Cast e co)      | isReflCo co' = go e
+       	                | otherwise    = Cast (go e) co' 
                         where
-                          co' = substTy subst co
+                          co' = optCoercion (getCvSubst subst) co
 
     go (Let bind body) = case simple_opt_bind subst bind of
                            (subst', Nothing)   -> simple_opt_expr subst' body
@@ -806,21 +855,25 @@ simple_app subst e as
   = foldl App (simple_opt_expr subst e) as
 
 ----------------------
-simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
-simple_opt_bind subst (Rec prs)
-  = (subst'', Just (Rec (reverse rev_prs')))
+simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind s b 		  -- Can add trace stuff here
+  = simple_opt_bind' s b
+
+simple_opt_bind' subst (Rec prs)
+  = (subst'', res_bind)
   where
+    res_bind            = Just (Rec (reverse rev_prs'))
     (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
     (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
     do_pr (subst, prs) ((b,r), b') 
        = case maybe_substitute subst b r2 of
            Just subst' -> (subst', prs)
-    	   Nothing     -> (subst,  (b2,r2):prs)
+           Nothing     -> (subst,  (b2,r2):prs)
        where
          b2 = add_info subst b b'
          r2 = simple_opt_expr subst r
 
-simple_opt_bind subst (NonRec b r)
+simple_opt_bind' subst (NonRec b r)
   = case maybe_substitute subst b r' of
       Just ext_subst -> (ext_subst, Nothing)
       Nothing        -> (subst', Just (NonRec b2 r'))
@@ -836,10 +889,14 @@ maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
     --   or     returns Nothing
 maybe_substitute subst b r
   | Type ty <- r 	-- let a::* = TYPE ty in <body>
-  = ASSERT( isTyCoVar b )
+  = ASSERT( isTyVar b )
     Just (extendTvSubst subst b ty)
 
-  | isId b		-- let x = e in <body>
+  | Coercion co <- r
+  = ASSERT( isCoVar b )
+    Just (extendCvSubst subst b co)
+
+  | isId b              -- let x = e in <body>
   , safe_to_inline (idOccInfo b) 
   , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
   , not (isStableUnfolding (idUnfolding b))
@@ -859,19 +916,20 @@ maybe_substitute subst b r
 ----------------------
 subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
 subst_opt_bndr subst bndr
-  | isTyCoVar bndr  = substTyVarBndr subst bndr
-  | otherwise       = subst_opt_id_bndr subst bndr
+  | isTyVar bndr  = substTyVarBndr subst bndr
+  | isCoVar bndr  = substCoVarBndr subst bndr
+  | otherwise     = subst_opt_id_bndr subst bndr
 
 subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
 -- Nuke all fragile IdInfo, unfolding, and RULES; 
 --    it gets added back later by add_info
 -- Rather like SimplEnv.substIdBndr
 --
--- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr 
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr 
 -- carefully does not do) because simplOptExpr invalidates it
 
-subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
-  = (Subst new_in_scope new_id_subst tv_subst, new_id)
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
+  = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
   where
     id1	   = uniqAway in_scope old_id
     id2    = setIdType id1 (substTy subst (idType old_id))
@@ -894,9 +952,9 @@ subst_opt_bndrs subst bndrs
 
 ----------------------
 add_info :: Subst -> InVar -> OutVar -> OutVar
-add_info subst old_bndr new_bndr 
- | isTyCoVar old_bndr = new_bndr
- | otherwise          = maybeModifyIdInfo mb_new_info new_bndr
+add_info subst old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
  where
    mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
 \end{code}
@@ -920,3 +978,4 @@ we don't know what phase we're in.  Here's an example
 When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
 to remain visible until Phase 1
 
+
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 603b745..e754c6d 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -15,7 +15,7 @@ module CoreSyn (
 
         -- ** 'Expr' construction
 	mkLets, mkLams,
-	mkApps, mkTyApps, mkVarApps,
+	mkApps, mkTyApps, mkCoApps, mkVarApps,
 	
 	mkIntLit, mkIntLitInt,
 	mkWordLit, mkWordLitWord,
@@ -23,18 +23,19 @@ module CoreSyn (
 	mkFloatLit, mkFloatLitFloat,
 	mkDoubleLit, mkDoubleLitDouble,
 	
-	mkConApp, mkTyBind,
+	mkConApp, mkTyBind, mkCoBind,
 	varToCoreExpr, varsToCoreExprs,
 
-        isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
+        isId, cmpAltCon, cmpAlt, ltAlt,
 	
 	-- ** Simple 'Expr' access functions and predicates
 	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
 	collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
 	collectArgs, coreExprCc, flattenBinds, 
 
-	isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-	notSccNote,
+        isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+        isRuntimeArg, isRuntimeVar,
+        notSccNote,
 
 	-- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
@@ -95,7 +96,7 @@ import Util
 import Data.Data
 import Data.Word
 
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
 \end{code}
 
@@ -239,6 +240,8 @@ data Expr b
 
   | Type  Type			        -- ^ A type: this should only show up at the top
                                         -- level of an Arg
+    
+  | Coercion Coercion                   -- ^ A coercion
   deriving (Data, Typeable)
 
 -- | Type synonym for expressions that occur in function argument positions.
@@ -878,6 +881,8 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
 mkApps    :: Expr b -> [Arg b]  -> Expr b
 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 mkTyApps  :: Expr b -> [Type]   -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps  :: Expr b -> [Coercion] -> Expr b
 -- | Apply a list of type or value variables to a function expression in a nested fashion
 mkVarApps :: Expr b -> [Var] -> Expr b
 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
@@ -886,6 +891,7 @@ mkConApp      :: DataCon -> [Arg b] -> Expr b
 
 mkApps    f args = foldl App		  	   f args
 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
+mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
@@ -956,10 +962,16 @@ mkLets binds body   = foldr Let body binds
 mkTyBind :: TyVar -> Type -> CoreBind
 mkTyBind tv ty      = NonRec tv (Type ty)
 
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co      = NonRec cv (Coercion co)
+
 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v = Var v
-                | otherwise = Type (mkTyVarTy v)
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+                | isCoVar v = Coercion (mkCoVarCo v)
+                | otherwise = ASSERT( isId v ) Var v
 
 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 varsToCoreExprs vs = map varToCoreExpr vs
@@ -1025,7 +1037,7 @@ collectTyAndValBinders expr
 collectTyBinders expr
   = go [] expr
   where
-    go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
     go tvs e			 = (reverse tvs, e)
 
 collectValBinders expr
@@ -1076,15 +1088,23 @@ isRuntimeVar = isId
 isRuntimeArg :: CoreExpr -> Bool
 isRuntimeArg = isValArg
 
--- | Returns @False@ iff the expression is a 'Type' expression at its top level
+-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
 isValArg :: Expr b -> Bool
-isValArg (Type _) = False
-isValArg _        = True
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {})     = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _             = False
 
--- | Returns @True@ iff the expression is a 'Type' expression at its top level
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level.  Note this does NOT include 'Coercion's.
 isTypeArg :: Expr b -> Bool
-isTypeArg (Type _) = True
-isTypeArg _        = False
+isTypeArg (Type {}) = True
+isTypeArg _         = False
 
 -- | The number of binders that bind values rather than types
 valBndrCount :: [CoreBndr] -> Int
@@ -1114,9 +1134,10 @@ seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
-seqExpr (Cast e co)     = seqExpr e `seq` seqType co
+seqExpr (Cast e co)     = seqExpr e `seq` seqCo co
 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
-seqExpr (Type t)        = seqType t
+seqExpr (Type t)       = seqType t
+seqExpr (Coercion co)   = seqCo co
 
 seqExprs :: [CoreExpr] -> ()
 seqExprs [] = ()
@@ -1170,9 +1191,11 @@ data AnnExpr' bndr annot
   | AnnApp	(AnnExpr bndr annot) (AnnExpr bndr annot)
   | AnnCase	(AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
   | AnnLet	(AnnBind bndr annot) (AnnExpr bndr annot)
-  | AnnCast     (AnnExpr bndr annot) Coercion
+  | AnnCast     (AnnExpr bndr annot) (annot, Coercion)
+    		   -- Put an annotation on the (root of) the coercion
   | AnnNote	Note (AnnExpr bndr annot)
   | AnnType	Type
+  | AnnCoercion Coercion
 
 -- | A clone of the 'Alt' type but allowing annotation at every tree node
 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
@@ -1199,12 +1222,13 @@ deAnnotate :: AnnExpr bndr annot -> Expr bndr
 deAnnotate (_, e) = deAnnotate' e
 
 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
-deAnnotate' (AnnType t)           = Type t
+deAnnotate' (AnnType t)          = Type t
+deAnnotate' (AnnCoercion co)      = Coercion co
 deAnnotate' (AnnVar  v)           = Var v
 deAnnotate' (AnnLit  lit)         = Lit lit
 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
+deAnnotate' (AnnCast e (_,co))    = Cast (deAnnotate e) co
 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 
 deAnnotate' (AnnLet bind body)
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 582f873..377bfd8 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -17,7 +17,7 @@ import CoreSyn
 import CoreArity
 import Id
 import IdInfo
-import TcType( tidyType, tidyTyVarBndr )
+import TcType( tidyType, tidyCo, tidyTyVarBndr )
 import Var
 import VarEnv
 import UniqFM
@@ -55,11 +55,12 @@ tidyBind env (Rec prs)
 ------------  Expressions  --------------
 tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
 tidyExpr env (Var v)   	 =  Var (tidyVarOcc env v)
-tidyExpr env (Type ty) 	 =  Type (tidyType env ty)
+tidyExpr env (Type ty)  =  Type (tidyType env ty)
+tidyExpr env (Coercion co) = Coercion (tidyCo env co)
 tidyExpr _   (Lit lit)   =  Lit lit
 tidyExpr env (App f a) 	 =  App (tidyExpr env f) (tidyExpr env a)
 tidyExpr env (Note n e)  =  Note (tidyNote env n) (tidyExpr env e)
-tidyExpr env (Cast e co) =  Cast (tidyExpr env e) (tidyType env co)
+tidyExpr env (Cast e co) =  Cast (tidyExpr env e) (tidyCo env co)
 
 tidyExpr env (Let b e) 
   = tidyBind env b 	=: \ (env', b') ->
@@ -125,7 +126,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
-  | isTyCoVar var = tidyTyVarBndr env var
+  | isTyVar var = tidyTyVarBndr env var
   | otherwise   = tidyIdBndr env var
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index d1b9fa0..051e767 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -60,9 +60,12 @@ import PrelNames
 import VarEnv           ( mkInScopeSet )
 import Bag
 import Util
+import Pair
 import FastTypes
 import FastString
 import Outputable
+import ForeignCall
+
 import Data.Maybe
 \end{code}
 
@@ -107,7 +110,7 @@ mkWwInlineRule id expr arity
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolded
   = mkCoreUnfolding InlineCompulsory True
-                    expr 0    -- Arity of unfolding doesn't matter
+                    (simpleOptExpr expr) 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
 mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
@@ -272,6 +275,9 @@ Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's
 a function call to account for.  Notice also that constructor applications 
 are very cheap, because exposing them to a caller is so valuable.
 
+[25/5/11] All sizes are now multiplied by 10, except for primops.
+This makes primops look cheap, and seems to be almost unversally
+beneficial.  Done partly as a result of #4978.
 
 Note [Do not inline top-level bottoming functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -329,7 +335,7 @@ uncondInline :: Arity -> Int -> Bool
 -- See Note [INLINE for small functions]
 uncondInline arity size 
   | arity == 0 = size == 0
-  | otherwise  = size <= arity + 1
+  | otherwise  = size <= 10 * (arity + 1)
 \end{code}
 
 
@@ -348,27 +354,29 @@ sizeExpr bOMB_OUT_SIZE top_args expr
     size_up (Cast e _) = size_up e
     size_up (Note _ e) = size_up e
     size_up (Type _)   = sizeZero           -- Types cost nothing
+    size_up (Coercion _) = sizeZero
     size_up (Lit lit)  = sizeN (litSize lit)
     size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
     	    	       	 	      	    -- discounts even on nullary constructors
 
     size_up (App fun (Type _)) = size_up fun
+    size_up (App fun (Coercion _)) = size_up fun
     size_up (App fun arg)      = size_up arg  `addSizeNSD`
                                  size_up_app fun [arg]
 
-    size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 1)
+    size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 10)
 		      | otherwise = size_up e
 
     size_up (Let (NonRec binder rhs) body)
       = size_up rhs		`addSizeNSD`
 	size_up body		`addSizeN`
-	(if isUnLiftedType (idType binder) then 0 else 1)
+        (if isUnLiftedType (idType binder) then 0 else 10)
 		-- For the allocation
 		-- If the binder has an unlifted type there is no allocation
 
     size_up (Let (Rec pairs) body)
       = foldr (addSizeNSD . size_up . snd) 
-              (size_up body `addSizeN` length pairs)	-- (length pairs) for the allocation
+              (size_up body `addSizeN` (10 * length pairs))     -- (length pairs) for the allocation
               pairs
 
     size_up (Case (Var v) _ _ alts) 
@@ -385,7 +393,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 		-- the case when we are scrutinising an argument variable
 	  alts_size (SizeIs tot tot_disc tot_scrut)  -- Size of all alternatives
 		    (SizeIs max _        _)          -- Size of biggest alternative
-	 	= SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut
+                = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
 			-- If the variable is known, we produce a discount that
 			-- will take us back to 'max', the size of the largest alternative
 			-- The 1+ is a little discount for reduced allocation in the caller
@@ -395,20 +403,46 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
 	  alts_size tot_size _ = tot_size
 
-    size_up (Case e _ _ alts) = size_up e  `addSizeNSD` 
-                                foldr (addAltSize . size_up_alt) sizeZero alts
-	  	-- We don't charge for the case itself
-		-- It's a strict thing, and the price of the call
-		-- is paid by scrut.  Also consider
-		--	case f x of DEFAULT -> e
-		-- This is just ';'!  Don't charge for it.
-		--
-		-- Moreover, we charge one per alternative.
+    size_up (Case e _ _ alts) = size_up e  `addSizeNSD`
+                                foldr (addAltSize . size_up_alt) case_size alts
+      where
+          case_size
+           | is_inline_scrut e, not (lengthExceeds alts 1)  = sizeN (-10)
+           | otherwise = sizeZero
+                -- Normally we don't charge for the case itself, but
+                -- we charge one per alternative (see size_up_alt,
+                -- below) to account for the cost of the info table
+                -- and comparisons.
+                --
+                -- However, in certain cases (see is_inline_scrut
+                -- below), no code is generated for the case unless
+                -- there are multiple alts.  In these cases we
+                -- subtract one, making the first alt free.
+                -- e.g. case x# +# y# of _ -> ...   should cost 1
+                --      case touch# x# of _ -> ...  should cost 0
+                -- (see #4978)
+                --
+                -- I would like to not have the "not (lengthExceeds alts 1)"
+                -- condition above, but without that some programs got worse
+                -- (spectral/hartel/event and spectral/para).  I don't fully
+                -- understand why. (SDM 24/5/11)
+
+                -- unboxed variables, inline primops and unsafe foreign calls
+                -- are all "inline" things:
+          is_inline_scrut (Var v) = isUnLiftedType (idType v)
+          is_inline_scrut scrut
+              | (Var f, _) <- collectArgs scrut
+                = case idDetails f of
+                    FCallId fc  -> not (isSafeForeignCall fc)
+                    PrimOpId op -> not (primOpOutOfLine op)
+                    _other      -> False
+              | otherwise
+                = False
 
     ------------ 
     -- size_up_app is used when there's ONE OR MORE value args
     size_up_app (App fun arg) args 
-	| isTypeArg arg		   = size_up_app fun args
+	| isTyCoArg arg		   = size_up_app fun args
 	| otherwise		   = size_up arg  `addSizeNSD`
                                      size_up_app fun (arg:args)
     size_up_app (Var fun)     args = size_up_call fun args
@@ -418,14 +452,14 @@ sizeExpr bOMB_OUT_SIZE top_args expr
     size_up_call :: Id -> [CoreExpr] -> ExprSize
     size_up_call fun val_args
        = case idDetails fun of
-           FCallId _        -> sizeN opt_UF_DearOp
+           FCallId _        -> sizeN (10 * (1 + length val_args))
            DataConWorkId dc -> conSize    dc (length val_args)
            PrimOpId op      -> primOpSize op (length val_args)
 	   ClassOpId _ 	    -> classOpSize top_args val_args
 	   _     	    -> funSize top_args fun (length val_args)
 
     ------------ 
-    size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1
+    size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
  	-- Don't charge for args, so that wrappers look cheap
 	-- (See comments about wrappers with Case)
 	--
@@ -461,7 +495,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
 -- Used by CoreUnfold.sizeExpr
-litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
+litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4)
 	-- If size could be 0 then @f "x"@ might be too small
 	-- [Sept03: make literal strings a bit bigger to avoid fruitless 
 	--  duplication of little strings]
@@ -476,7 +510,7 @@ classOpSize _ []
 classOpSize top_args (arg1 : other_args)
   = SizeIs (iUnbox size) arg_discount (_ILIT(0))
   where
-    size = 2 + length other_args
+    size = 20 + (10 * length other_args)
     -- If the class op is scrutinising a lambda bound dictionary then
     -- give it a discount, to encourage the inlining of this function
     -- The actual discount is rather arbitrarily chosen
@@ -504,8 +538,7 @@ funSize top_args fun n_val_args
     res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
     		 | otherwise   	 	    = 0
         -- If the function is partially applied, show a result discount
-
-    size | some_val_args = 1 + n_val_args
+    size | some_val_args = 10 * (1 + n_val_args)
          | otherwise     = 0
 	-- The 1+ is for the function itself
 	-- Add 1 for each non-trivial arg;
@@ -514,16 +547,17 @@ funSize top_args fun n_val_args
 
 conSize :: DataCon -> Int -> ExprSize
 conSize dc n_val_args
-  | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1))	-- Like variables
-
--- See Note [Constructor size]
-  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+  | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10))    -- Like variables
 
 -- See Note [Unboxed tuple result discount]
---  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
+  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args)))
 
 -- See Note [Constructor size]
-  | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+  | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args)))
+     -- discont was (10 * (1 + n_val_args)), but it turns out that
+     -- adding a bigger constant here is an unambiguous win.  We
+     -- REALLY like unfolding constructors that get scrutinised.
+     -- [SDM, 25/5/11]
 \end{code}
 
 Note [Constructor size]
@@ -554,23 +588,15 @@ didn't adopt the idea.
 \begin{code}
 primOpSize :: PrimOp -> Int -> ExprSize
 primOpSize op n_val_args
- | not (primOpIsDupable op) = sizeN opt_UF_DearOp
- | not (primOpOutOfLine op) = sizeN 1
-	-- Be very keen to inline simple primops.
-	-- We give a discount of 1 for each arg so that (op# x y z) costs 2.
-	-- We can't make it cost 1, else we'll inline let v = (op# x y z) 
-	-- at every use of v, which is excessive.
-	--
-	-- A good example is:
-	--	let x = +# p q in C {x}
-	-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-	-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
-
- | otherwise = sizeN n_val_args
+ = if primOpOutOfLine op
+      then sizeN (op_size + n_val_args)
+      else sizeN op_size
+ where
+   op_size = primOpCodeSize op
 
 
 buildSize :: ExprSize
-buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
 	-- We really want to inline applications of build
 	-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 	-- Indeed, we should add a result_discount becuause build is 
@@ -579,7 +605,7 @@ buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
 	-- The "4" is rather arbitrary.
 
 augmentSize :: ExprSize
-augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
 	-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
 	-- e plus ys. The -2 accounts for the \cn 
 
@@ -711,7 +737,7 @@ certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals,
       UnfNever      -> False
       UnfWhen {}    -> True
       UnfIfGoodArgs { ug_size = size} 
-                    -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
+                    -> is_cheap && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold
 
 certainlyWillInline _
   = False
@@ -1059,10 +1085,10 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
 	--  *efficiency* to be gained (e.g. beta reductions, case reductions) 
 	-- by inlining.
 
-  = 1 		-- Discount of 1 because the result replaces the call
+  = 10          -- Discount of 1 because the result replaces the call
 		-- so we count 1 for the function itself
 
-    + length (take n_vals_wanted arg_infos)
+    + 10 * length (take n_vals_wanted arg_infos)
       	       -- Discount of (un-scaled) 1 for each arg supplied, 
    	       -- because the result replaces the call
 
@@ -1072,13 +1098,13 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
     arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
 
     mk_arg_discount _ 	     TrivArg    = 0 
-    mk_arg_discount _ 	     NonTrivArg = 1   
+    mk_arg_discount _        NonTrivArg = 10
     mk_arg_discount discount ValueArg   = discount 
 
     res_discount' = case cont_info of
 			BoringCtxt  -> 0
 			CaseCtxt    -> res_discount
-			_other      -> 4 `min` res_discount
+                        _other      -> 40 `min` res_discount
 		-- res_discount can be very large when a function returns
 		-- constructors; but we only want to invoke that large discount
 		-- when there's a case continuation.
@@ -1147,12 +1173,14 @@ interestingArg e = go e 0
          conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 
     go (Type _)          _ = TrivArg
-    go (App fn (Type _)) n = go fn n    
+    go (Coercion _)      _ = TrivArg
+    go (App fn (Type _)) n = go fn n
+    go (App fn (Coercion _)) n = go fn n
     go (App fn _)        n = go fn (n+1)
     go (Note _ a) 	 n = go a n
     go (Cast e _) 	 n = go e n
     go (Lam v e)  	 n 
-       | isTyCoVar v	   = go e n
+       | isTyVar v	   = go e n
        | n>0	 	   = go e (n-1)
        | otherwise	   = ValueArg
     go (Let _ e)  	 n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
@@ -1208,7 +1236,7 @@ exprIsConApp_maybe id_unf (Cast expr co)
 	Nothing 	                 -> Nothing ;
 	Just (dc, _dc_univ_args, dc_args) -> 
 
-    let (_from_ty, to_ty) = coercionKind co
+    let Pair _from_ty to_ty = coercionKind co
 	dc_tc = dataConTyCon dc
     in
     case splitTyConApp_maybe to_ty of {
@@ -1228,41 +1256,28 @@ exprIsConApp_maybe id_unf (Cast expr co)
         dc_ex_tyvars   = dataConExTyVars dc
         arg_tys        = dataConRepArgTys dc
 
-        dc_eqs :: [(Type,Type)]	  -- All equalities from the DataCon
-        dc_eqs = [(mkTyVarTy tv, ty)   | (tv,ty) <- dataConEqSpec dc] ++
-                 [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
-
-        (ex_args, rest1)    = splitAtList dc_ex_tyvars dc_args
-	(co_args, val_args) = splitAtList dc_eqs rest1
+        (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
 
 	-- Make the "theta" from Fig 3 of the paper
         gammas = decomposeCo tc_arity co
-        theta  = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
-                                (gammas         ++ stripTypeArgs ex_args)
-
-          -- Cast the existential coercion arguments
-        cast_co (ty1, ty2) (Type co) 
-          = Type $ mkSymCoercion (substTy theta ty1)
-		   `mkTransCoercion` co
-		   `mkTransCoercion` (substTy theta ty2)
-        cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
-        new_co_args = zipWith cast_co dc_eqs co_args
-  
+        theta  = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+                                (gammas         ++ map mkReflCo (stripTypeArgs ex_args))
+
           -- Cast the value arguments (which include dictionaries)
 	new_val_args = zipWith cast_arg arg_tys val_args
-	cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+	cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg
     in
 #ifdef DEBUG
     let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
                          ppr ex_args, ppr val_args]
     in
-    ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
-    ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
+    ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+    ASSERT2( all isTypeArg ex_args, dump_doc )
     ASSERT2( equalLength val_args arg_tys, dump_doc )
 #endif
 
-    Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
+    Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
     }}
 
 exprIsConApp_maybe id_unf expr 
@@ -1301,7 +1316,7 @@ exprIsConApp_maybe id_unf expr
 
     -----------
     beta (Lam v body) pairs (arg : args) 
-        | isTypeArg arg
+        | isTyCoArg arg
         = beta body ((v,arg):pairs) args 
 
     beta (Lam {}) _ _    -- Un-saturated, or not a type lambda
@@ -1313,10 +1328,10 @@ exprIsConApp_maybe id_unf expr
           subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
 	  -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
 
-
 stripTypeArgs :: [CoreExpr] -> [Type]
 stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
                      [ty | Type ty <- args]
+  -- We really do want isTypeArg here, not isTyCoArg!
 \end{code}
 
 Note [Unfolding DFuns]
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 70e1db7..4146b62 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -16,7 +16,7 @@ Utility functions on @Core@ syntax
 -- | Commonly useful utilites for manipulating the Core language
 module CoreUtils (
 	-- * Constructing expressions
-	mkSCC, mkCoerce, mkCoerceI,
+	mkSCC, mkCoerce,
 	bindNonRec, needsCaseBinding,
 	mkAltExpr, mkPiType, mkPiTypes,
 
@@ -45,7 +45,7 @@ module CoreUtils (
 
 	-- * Manipulating data constructors and types
 	applyTypeToArgs, applyTypeToArg,
-        dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
+        dataConRepInstPat, dataConRepFSInstPat
     ) where
 
 #include "HsVersions.h"
@@ -62,7 +62,6 @@ import DataCon
 import PrimOp
 import Id
 import IdInfo
-import TcType	( isPredTy )
 import Type
 import Coercion
 import TyCon
@@ -73,6 +72,7 @@ import TysPrim
 import FastString
 import Maybes
 import Util
+import Pair
 import Data.Word
 import Data.Bits
 \end{code}
@@ -91,9 +91,10 @@ exprType :: CoreExpr -> Type
 -- really be said to have a type
 exprType (Var var)	     = idType var
 exprType (Lit lit)	     = literalType lit
+exprType (Coercion co)	     = coercionType co
 exprType (Let _ body)	     = exprType body
 exprType (Case _ _ ty _)     = ty
-exprType (Cast _ co)         = snd (coercionKind co)
+exprType (Cast _ co)         = pSnd (coercionKind co)
 exprType (Note _ e)          = exprType e
 exprType (Lam binder expr)   = mkPiType binder (exprType expr)
 exprType e@(App _ _)
@@ -110,7 +111,7 @@ coreAltType (_,bs,rhs)
   where
     ty           = exprType rhs
     free_tvs     = tyVarsOfType ty
-    bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
+    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -143,10 +144,10 @@ Various possibilities suggest themselves:
    we are doing here.  It's not too expensive, I think.
 
 \begin{code}
-mkPiType  :: EvVar -> Type -> Type
+mkPiType  :: Var -> Type -> Type
 -- ^ Makes a @(->)@ type or a forall type, depending
 -- on whether it is given a type variable or a term variable.
-mkPiTypes :: [EvVar] -> Type -> Type
+mkPiTypes :: [Var] -> Type -> Type
 -- ^ 'mkPiType' for multiple type or value arguments
 
 mkPiType v ty
@@ -172,11 +173,11 @@ applyTypeToArgs e op_ty (Type ty : args)
     go [ty] args
   where
     go rev_tys (Type ty : args) = go (ty:rev_tys) args
-    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
-			 	where
-				  op_ty' = applyTysD msg op_ty (reverse rev_tys)
-				  msg = ptext (sLit "applyTypeToArgs") <+> 
-		    			panic_msg e op_ty
+    go rev_tys rest_args         = applyTypeToArgs e op_ty' rest_args
+	                         where
+			 	   op_ty' = applyTysD msg op_ty (reverse rev_tys)
+				   msg = ptext (sLit "applyTypeToArgs") <+> 
+		    		 	 panic_msg e op_ty
 
 applyTypeToArgs e op_ty (_ : args)
   = case (splitFunTy_maybe op_ty) of
@@ -194,25 +195,22 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 %************************************************************************
 
 \begin{code}
--- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
-mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI (IdCo _) e = e
-mkCoerceI (ACo co) e = mkCoerce co e
-
--- | Wrap the given expression in the coercion safely, coalescing nested coercions
+-- | Wrap the given expression in the coercion safely, dropping
+-- identity coercions and coalescing nested coercions
 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
+mkCoerce co e | isReflCo co = e
 mkCoerce co (Cast expr co2)
-  = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
-                 (_from_ty2, to_ty2) = coercionKind co2} in
-           from_ty `coreEqType` to_ty2 )
-    mkCoerce (mkTransCoercion co2 co) expr
+  = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co; 
+                 Pair _from_ty2  to_ty2 = coercionKind co2} in
+           from_ty `eqType` to_ty2 )
+    mkCoerce (mkTransCo co2 co) expr
 
 mkCoerce co expr 
-  = let (from_ty, _to_ty) = coercionKind co in
---    if to_ty `coreEqType` from_ty
+  = let Pair from_ty _to_ty = coercionKind co in
+--    if to_ty `eqType` from_ty
 --    then expr
 --    else 
-        WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
          (Cast expr co)
 \end{code}
 
@@ -415,7 +413,8 @@ discount.
 \begin{code}
 exprIsTrivial :: CoreExpr -> Bool
 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
-exprIsTrivial (Type _)         = True
+exprIsTrivial (Type _)        = True
+exprIsTrivial (Coercion _)     = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
 exprIsTrivial (Note _       e) = exprIsTrivial e  -- See Note [SCCs are trivial]
@@ -469,10 +468,11 @@ exprIsDupable e
   = isJust (go dupAppSize e)
   where
     go :: Int -> CoreExpr -> Maybe Int
-    go n (Type {}) = Just n
-    go n (Var {})  = decrement n
-    go n (Note _ e) = go n e
-    go n (Cast e _) = go n e
+    go n (Type {})     = Just n
+    go n (Coercion {}) = Just n
+    go n (Var {})      = decrement n
+    go n (Note _ e)    = go n e
+    go n (Cast e _)    = go n e
     go n (App f a) | Just n' <- go n a = go n' f
     go n (Lit lit) | litIsDupable lit = decrement n
     go _ _ = Nothing
@@ -540,13 +540,14 @@ exprIsExpandable = exprIsCheap' isExpandableApp	-- See Note [CONLIKE pragma] in
 
 type CheapAppFun = Id -> Int -> Bool
 exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
-exprIsCheap' _          (Lit _)   = True
-exprIsCheap' _          (Type _)  = True
-exprIsCheap' _          (Var _)   = True
-exprIsCheap' good_app (Note _ e)  = exprIsCheap' good_app e
-exprIsCheap' good_app (Cast e _)  = exprIsCheap' good_app e
-exprIsCheap' good_app (Lam x e)   = isRuntimeVar x
-                                 || exprIsCheap' good_app e
+exprIsCheap' _        (Lit _)      = True
+exprIsCheap' _        (Type _)    = True
+exprIsCheap' _        (Coercion _) = True
+exprIsCheap' _        (Var _)      = True
+exprIsCheap' good_app (Note _ e)   = exprIsCheap' good_app e
+exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
+exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
+                                  || exprIsCheap' good_app e
 
 exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && 
 				          and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
@@ -588,12 +589,10 @@ exprIsCheap' good_app other_expr 	-- Applications and variables
     go _ _ = False
  
     --------------
-    go_pap args = all exprIsTrivial args
- 	-- For constructor applications and primops, check that all
- 	-- the args are trivial.  We don't want to treat as cheap, say,
- 	-- 	(1:2:3:4:5:[])
- 	-- We'll put up with one constructor application, but not dozens
- 	
+    go_pap args = all (exprIsCheap' good_app) args
+        -- Used to be "all exprIsTrivial args" due to concerns about
+        -- duplicating nested constructor applications, but see #4978.
+
     --------------
     go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
  	-- In principle we should worry about primops
@@ -684,8 +683,9 @@ it's applied only to dictionaries.
 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 -- side effects, and can't diverge or raise an exception.
 exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Lit _)     = True
-exprOkForSpeculation (Type _)    = True
+exprOkForSpeculation (Lit _)      = True
+exprOkForSpeculation (Type _)     = True
+exprOkForSpeculation (Coercion _) = True
 
 exprOkForSpeculation (Var v)     
   | isTickBoxOp v = False     -- Tick boxes are *not* suitable for speculation
@@ -865,12 +865,14 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
 	-- we could get an infinite loop
 
     is_hnf_like (Lit _)          = True
-    is_hnf_like (Type _)         = True       -- Types are honorary Values;
+    is_hnf_like (Type _)        = True       -- Types are honorary Values;
                                               -- we don't mind copying them
+    is_hnf_like (Coercion _)     = True       -- Same for coercions
     is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
     is_hnf_like (Note _ e)       = is_hnf_like e
     is_hnf_like (Cast e _)       = is_hnf_like e
-    is_hnf_like (App e (Type _)) = is_hnf_like e
+    is_hnf_like (App e (Type _))    = is_hnf_like e
+    is_hnf_like (App e (Coercion _)) = is_hnf_like e
     is_hnf_like (App e a)        = app_is_value e [a]
     is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
     is_hnf_like _                = False
@@ -896,36 +898,26 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
 These InstPat functions go here to avoid circularity between DataCon and Id
 
 \begin{code}
-dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
-dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 
-dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
-dataConRepFSInstPat = dataConInstPat dataConRepArgTys
-dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat ((fsLit "ipv")))
-  where 
-    dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
-	-- Remember to include the existential dictionaries
-
-dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
-                  -> [FastString]          -- A long enough list of FSs to use for names
-                  -> [Unique]              -- An equally long list of uniques, at least one for each binder
-                  -> DataCon
-	          -> [Type]                -- Types to instantiate the universally quantified tyvars
-	       -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))
+dataConRepFSInstPat = dataConInstPat 
+
+dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names
+               -> [Unique]              -- An equally long list of uniques, at least one for each binder
+               -> DataCon
+	       -> [Type]                -- Types to instantiate the universally quantified tyvars
+	       -> ([TyVar], [Id])          -- Return instantiated variables
 -- dataConInstPat arg_fun fss us con inst_tys returns a triple 
--- (ex_tvs, co_tvs, arg_ids),
+-- (ex_tvs, arg_ids),
 --
 --   ex_tvs are intended to be used as binders for existential type args
 --
---   co_tvs are intended to be used as binders for coercion args and the kinds
---     of these vars have been instantiated by the inst_tys and the ex_tys
---     The co_tvs include both GADT equalities (dcEqSpec) and 
---     programmer-specified equalities (dcEqTheta)
---
 --   arg_ids are indended to be used as binders for value arguments, 
 --     and their types have been instantiated with inst_tys and ex_tys
---     The arg_ids include both dicts (dcDictTheta) and
---     programmer-specified arguments (after rep-ing) (deRepArgTys)
+--     The arg_ids include both evidence and
+--     programmer-specified arguments (both after rep-ing)
 --
 -- Example.
 --  The following constructor T1
@@ -940,29 +932,22 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --
 --  dataConInstPat fss us T1 (a1',b') will return
 --
---  ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
+--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
 --
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
-dataConInstPat arg_fun fss uniqs con inst_tys 
-  = (ex_bndrs, co_bndrs, arg_ids)
+dataConInstPat fss uniqs con inst_tys 
+  = (ex_bndrs, arg_ids)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
-    arg_tys  = arg_fun con
-    eq_spec  = dataConEqSpec con
-    eq_theta = dataConEqTheta con
-    eq_preds = eqSpecPreds eq_spec ++ eq_theta
+    arg_tys  = dataConRepArgTys con
 
     n_ex = length ex_tvs
-    n_co = length eq_preds
 
       -- split the Uniques and FastStrings
-    (ex_uniqs, uniqs')   = splitAt n_ex uniqs
-    (co_uniqs, id_uniqs) = splitAt n_co uniqs'
-
-    (ex_fss, fss')     = splitAt n_ex fss
-    (co_fss, id_fss)   = splitAt n_co fss'
+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
+    (ex_fss,   id_fss)   = splitAt n_ex fss
 
       -- Make existential type variables
     ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
@@ -974,17 +959,9 @@ dataConInstPat arg_fun fss uniqs con inst_tys
       -- Make the instantiating substitution
     subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 
-      -- Make new coercion vars, instantiating kind
-    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
-    mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
-       where
-         new_name = mkSysTvName uniq fs
-         co_kind  = substTy subst (mkPredTy eq_pred)
-
-      -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+      -- Make value vars, instantiating types
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
-
 \end{code}
 
 %************************************************************************
@@ -1003,7 +980,8 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
 
 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
 
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
@@ -1019,7 +997,8 @@ exprIsBig :: Expr b -> Bool
 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
 exprIsBig (Lit _)      = False
 exprIsBig (Var _)      = False
-exprIsBig (Type _)     = False
+exprIsBig (Type _)    = False
+exprIsBig (Coercion _) = False
 exprIsBig (Lam _ e)    = exprIsBig e
 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 exprIsBig (Cast e _)   = exprIsBig e	-- Hopefully coercions are not too big!
@@ -1061,14 +1040,15 @@ eqExprX id_unfolding_fun env e1 e2
       , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
       = go (nukeRnEnvR env) e1 e2'
 
-    go _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
-    go env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-    go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2
+    go _   (Lit lit1)    (Lit lit2)      = lit1 == lit2
+    go env (Type t1)    (Type t2)        = eqTypeX env t1 t2
+    go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
+    go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
     go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2
     go env (Note n1 e1)  (Note n2 e2)  = go_note n1 n2 && go env e1 e2
 
     go env (Lam b1 e1)  (Lam b2 e2)  
-      =  tcEqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
+      =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
       && go (rnBndr2 env b1 b2) e1 e2
 
     go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) 
@@ -1084,7 +1064,7 @@ eqExprX id_unfolding_fun env e1 e2
 
     go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
       =  go env e1 e2
-      && tcEqTypeX env (idType b1) (idType b2)
+      && eqTypeX env (idType b1) (idType b2)
       && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
 
     go _ _ _ = False
@@ -1128,16 +1108,17 @@ exprSize (App f a)       = exprSize f + exprSize a
 exprSize (Lam b e)       = varSize b + exprSize e
 exprSize (Let b e)       = bindSize b + exprSize e
 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
-exprSize (Cast e co)     = (seqType co `seq` 1) + exprSize e
+exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e
 exprSize (Note n e)      = noteSize n + exprSize e
-exprSize (Type t)        = seqType t `seq` 1
+exprSize (Type t)       = seqType t `seq` 1
+exprSize (Coercion co)   = seqCo co `seq` 1
 
 noteSize :: Note -> Int
 noteSize (SCC cc)       = cc `seq` 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
  
 varSize :: Var -> Int
-varSize b  | isTyCoVar b = 1
+varSize b  | isTyVar b = 1
 	   | otherwise = seqType (idType b)		`seq`
 			 megaSeqIdInfo (idInfo b) 	`seq`
 			 1
@@ -1187,30 +1168,23 @@ bndrStats v = oneTM `plusCS` tyStats (varType v)
 exprStats :: CoreExpr -> CoreStats
 exprStats (Var {})        = oneTM
 exprStats (Lit {})        = oneTM
-exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (Type t)        = tyStats t
+exprStats (Coercion c)    = coStats c
 exprStats (App f a)       = exprStats f `plusCS` exprStats a 
 exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e 
 exprStats (Let b e)       = bindStats b `plusCS` exprStats e 
 exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
 exprStats (Cast e co)     = coStats co `plusCS` exprStats e
 exprStats (Note _ e)      = exprStats e
-exprStats (Type ty)       = zeroCS { cs_ty = typeSize ty }
-	  -- Ugh (might be a co)
 
 altStats :: CoreAlt -> CoreStats
 altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
 
-tyCoStats :: Type -> Type -> CoreStats
-tyCoStats fun_ty arg
-  = case splitForAllTy_maybe fun_ty of
-      Just (tv,_) | isCoVar tv -> coStats arg
-      _                        -> tyStats arg
-
 tyStats :: Type -> CoreStats
 tyStats ty = zeroCS { cs_ty = typeSize ty }
 
 coStats :: Coercion -> CoreStats
-coStats co = zeroCS { cs_co = typeSize co }
+coStats co = zeroCS { cs_co = coercionSize co }
 \end{code}
 
 %************************************************************************
@@ -1252,15 +1226,17 @@ hash_expr env (Lam b e)	              = hash_expr (extend_env env b) e
 hash_expr _   (Type _)                = WARN(True, text "hash_expr: type") 1
 -- Shouldn't happen.  Better to use WARN than trace, because trace
 -- prevents the CPR optimisation kicking in for hash_expr.
+hash_expr _   (Coercion _)            = WARN(True, text "hash_expr: coercion") 1
 
 fast_hash_expr :: HashEnv -> CoreExpr -> Word32
-fast_hash_expr env (Var v)     	= hashVar env v
-fast_hash_expr env (Type t)	= fast_hash_type env t
-fast_hash_expr _   (Lit lit)    = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e _)   = fast_hash_expr env e
-fast_hash_expr env (Note _ e)   = fast_hash_expr env e
-fast_hash_expr env (App _ a)    = fast_hash_expr env a	-- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr _   _            = 1
+fast_hash_expr env (Var v)     	 = hashVar env v
+fast_hash_expr env (Type t)	 = fast_hash_type env t
+fast_hash_expr env (Coercion co) = fast_hash_co env co
+fast_hash_expr _   (Lit lit)     = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _)    = fast_hash_expr env e
+fast_hash_expr env (Note _ e)    = fast_hash_expr env e
+fast_hash_expr env (App _ a)     = fast_hash_expr env a	-- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _   _             = 1
 
 fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
@@ -1269,6 +1245,13 @@ fast_hash_type env ty
 					      in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
   | otherwise				    = 1
 
+fast_hash_co :: HashEnv -> Coercion -> Word32
+fast_hash_co env co
+  | Just cv <- getCoVar_maybe co              = hashVar env cv
+  | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
+                                                in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
+  | otherwise                                 = 1
+
 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
 extend_env (n,env) b = (n+1, extendVarEnv env b n)
 
@@ -1368,18 +1351,18 @@ need to address that here.
 \begin{code}
 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
 tryEtaReduce bndrs body 
-  = go (reverse bndrs) body (IdCo (exprType body))
+  = go (reverse bndrs) body (mkReflCo (exprType body))
   where
     incoming_arity = count isId bndrs
 
     go :: [Var]	           -- Binders, innermost first, types [a3,a2,a1]
        -> CoreExpr         -- Of type tr
-       -> CoercionI        -- Of type tr ~ ts
+       -> Coercion         -- Of type tr ~ ts
        -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts
     -- See Note [Eta reduction with casted arguments]
     -- for why we have an accumulating coercion
     go [] fun co
-      | ok_fun fun = Just (mkCoerceI co fun)
+      | ok_fun fun = Just (mkCoerce co fun)
 
     go (b : bs) (App fun arg) co
       | Just co' <- ok_arg b arg co
@@ -1390,7 +1373,7 @@ tryEtaReduce bndrs body
     ---------------
     -- Note [Eta reduction conditions]
     ok_fun (App fun (Type ty)) 
-	| not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+        | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
 	=  ok_fun fun
     ok_fun (Var fun_id)
 	=  not (fun_id `elem` bndrs)
@@ -1406,22 +1389,22 @@ tryEtaReduce bndrs body
        | otherwise = idArity fun   	      
 
     ---------------
-    ok_lam v = isTyCoVar v || isDictId v
+    ok_lam v = isTyVar v || isEvVar v
 
     ---------------
-    ok_arg :: Var 	        -- Of type bndr_t
-           -> CoreExpr          -- Of type arg_t
-           -> CoercionI         -- Of kind (t1~t2)
-           -> Maybe CoercionI   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
-	      	    		--   (and similarly for tyvars, coercion args)
+    ok_arg :: Var              -- Of type bndr_t
+           -> CoreExpr         -- Of type arg_t
+           -> Coercion         -- Of kind (t1~t2)
+           -> Maybe Coercion   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
+                               --   (and similarly for tyvars, coercion args)
     -- See Note [Eta reduction with casted arguments]
     ok_arg bndr (Type ty) co
        | Just tv <- getTyVar_maybe ty
-       , bndr == tv  = Just (mkForAllTyCoI tv co)
+       , bndr == tv  = Just (mkForAllCo tv co)
     ok_arg bndr (Var v) co
-       | bndr == v   = Just (mkFunTyCoI (IdCo (idType bndr)) co)
+       | bndr == v   = Just (mkFunCo (mkReflCo (idType bndr)) co)
     ok_arg bndr (Cast (Var v) co_arg) co
-       | bndr == v  = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)
+       | bndr == v  = Just (mkFunCo (mkSymCo co_arg) co)
        -- The simplifier combines multiple casts into one, 
        -- so we can have a simple-minded pattern match here
     ok_arg _ _ _ = Nothing
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index 07a1dfb..359419c 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -4,7 +4,6 @@
 \begin{code}
 module ExternalCore where
 
-
 data Module 
  = Module Mname [Tdef] [Vdefg]
 
@@ -51,21 +50,21 @@ data Alt
 type Vbind = (Var,Ty)
 type Tbind = (Tvar,Kind)
 
+-- Internally, we represent types and coercions separately; but for
+-- the purposes of external core (at least for now) it's still
+-- convenient to collapse them into a single type.
 data Ty 
   = Tvar Tvar
   | Tcon (Qual Tcon)
   | Tapp Ty Ty
   | Tforall Tbind Ty 
--- We distinguish primitive coercions
--- (represented in GHC by wired-in names), because
--- External Core treats them specially, so we have
--- to print them out with special syntax.
+-- We distinguish primitive coercions because External Core treats
+-- them specially, so we have to print them out with special syntax.
   | TransCoercion Ty Ty
   | SymCoercion Ty
   | UnsafeCoercion Ty Ty
   | InstCoercion Ty Ty
-  | LeftCoercion Ty
-  | RightCoercion Ty
+  | NthCoercion Int Ty
 
 data Kind 
   = Klifted
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index f1d4273..b6bc7d4 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -45,8 +45,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import IdInfo
-import Var      ( EvVar, mkWildCoVar, setTyVarUnique )
+import Var      ( EvVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -58,8 +57,10 @@ import PrelNames
 
 import TcType		( mkSigmaTy )
 import Type
+import Coercion
 import TysPrim
 import DataCon          ( DataCon, dataConWorkId )
+import IdInfo		( vanillaIdInfo, setStrictnessInfo, setArityInfo )
 import Demand
 import Name
 import Outputable
@@ -102,6 +103,7 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
 -- See CoreSyn Note [CoreSyn let/app invariant]
 mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
 mkCoreApp fun arg       = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
                           mk_val_app fun arg arg_ty res_ty
                       where
@@ -117,6 +119,7 @@ mkCoreApps orig_fun orig_args
   where
     go fun _      []               = fun
     go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
+    go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args
     go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
                                      go (mk_val_app fun arg arg_ty res_ty) res_ty args
                                    where
@@ -148,8 +151,7 @@ mk_val_app fun arg arg_ty res_ty
 	-- fragmet of it as the fun part of a 'mk_val_app'.
 
 mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred@(EqPred {}) = mkWildCoVar     (mkPredTy pred)
-mkWildEvBinder pred             = mkWildValBinder (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index cb784e8..78df509 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -13,6 +13,8 @@ import Module
 import CoreSyn
 import HscTypes	
 import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
 import TypeRep
 import Type
 import PprExternalCore () -- Instances
@@ -78,10 +80,7 @@ collect_tdefs tcon tdefs
   where
     tdef | isNewTyCon tcon = 
                 C.Newtype (qtc tcon) 
-                  (case newTyConCo_maybe tcon of
-                     Just co -> qtc co
-                     Nothing       -> pprPanic ("MkExternalCore: newtype tcon\
-                                       should have a coercion: ") (ppr tcon))
+                  (qcc (newTyConCo tcon))
                   (map make_tbind tyvars) 
                   (make_ty (snd (newTyConRhs tcon)))
          | otherwise = 
@@ -94,6 +93,8 @@ collect_tdefs _ tdefs = tdefs
 qtc :: TyCon -> C.Qual C.Tcon
 qtc = make_con_qid . tyConName
 
+qcc :: CoAxiom -> C.Qual C.Tcon
+qcc = make_con_qid . co_ax_name
 
 make_cdef :: DataCon -> C.Cdef
 make_cdef dcon =  C.Constr dcon_name existentials tys
@@ -142,15 +143,16 @@ make_exp (Var v) = do
 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
 make_exp (Lit l) = return $ C.Lit (make_lit l)
 make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
 make_exp (App e1 e2) = do
    rator <- make_exp e1
    rand <- make_exp e2
    return $ C.App rator rand
-make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> 
+make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co))
+make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
 make_exp (Let b e) = do
   vd   <- make_vdef False b
   body <- make_exp e
@@ -170,7 +172,7 @@ make_alt (DataAlt dcon, vs, e) = do
            (map make_tbind tbs)
            (map make_vbind vbs)
 	   newE
-	where (tbs,vbs) = span isTyCoVar vs
+	where (tbs,vbs) = span isTyVar vs
 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
@@ -229,29 +231,12 @@ make_ty' (TyConApp tc ts) 	 = make_tyConApp tc ts
 make_ty' (PredTy p)	= make_ty (predTypeRep p)
 
 make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
-  C.TransCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t]      | tc == symCoercionTyCon =
-  C.SymCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
-  C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t]      | tc == leftCoercionTyCon =
-  C.LeftCoercion (make_ty t)
-make_tyConApp tc [t]      | tc == rightCoercionTyCon =
-  C.RightCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
-  C.InstCoercion (make_ty t1) (make_ty t2)
--- this fails silently if we have an application
--- of a wired-in coercion tycon to the wrong number of args.
--- Not great...
 make_tyConApp tc ts =
   foldl C.Tapp (C.Tcon (qtc tc)) 
 	    (map make_ty ts)
 
-
 make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
-    where (t1, t2) = getEqPredTys p
+make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 make_kind k
   | isLiftedTypeKind k   = C.Klifted
@@ -299,6 +284,25 @@ make_var_qid force_unqual = make_qid force_unqual True
 make_con_qid :: Name -> C.Qual C.Id
 make_con_qid = make_qid False False
 
+make_co :: Coercion -> C.Ty
+make_co (Refl ty)             = make_ty ty
+make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
+make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
+make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
+make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
+make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
+make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_co (SymCo co)            = C.SymCoercion (make_co co)
+make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
+make_co (NthCo d co)          = C.NthCoercion d (make_co co)
+make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
+
+-- Used for both tycon app coercions and axiom instantiations.
+make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo con cos =
+  foldl C.Tapp (C.Tcon con) 
+	    (map make_co cos)
+
 -------
 isALocal :: Name -> CoreM Bool
 isALocal vName = do
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 041b842..e9452dc 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 	-- The function adds parens in context that need
 	-- an atomic value (e.g. function args)
 
-ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
 	           
 ppr_expr _       (Var name) = ppr name
 ppr_expr _       (Lit lit)  = ppr lit
@@ -255,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty) 
  | opt_SuppressTypeApplications	= empty
  | otherwise			= ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr      = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr          = pprParendExpr expr
 \end{code}
 
 Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -268,7 +270,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyCoVar binder = pprKindedTyVarBndr binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
 		     ppIdInfo binder (idInfo binder)
 
@@ -279,7 +281,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
+  | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -287,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 pprTypedLCBinder bind_site debug_on var
   | not debug_on && isDeadBinder var    = char '_'
   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
-  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
+  | isTyVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -298,7 +300,7 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyCoVar binder		= pprKindedTyVarBndr binder
+  | isTyVar binder		= pprKindedTyVarBndr binder
   | opt_SuppressTypeSignatures	= empty
   | otherwise			= hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 3c4b25e..5303b0d 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -106,10 +106,8 @@ pty (SymCoercion t) =
   sep [text "%sym", paty t]
 pty (UnsafeCoercion t1 t2) =
   sep [text "%unsafe", paty t1, paty t2]
-pty (LeftCoercion t) =
-  sep [text "%left", paty t]
-pty (RightCoercion t) =
-  sep [text "%right", paty t]
+pty (NthCoercion n t) =
+  sep [text "%nth", int n, paty t]
 pty (InstCoercion t1 t2) =
   sep [text "%inst", paty t1, paty t2]
 pty t = pbty t
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 2432051..59c102f 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -27,10 +27,10 @@ import TysWiredIn
 import PrelNames
 import TyCon
 import Type
-import Unify( dataConCannotMatch )
 import SrcLoc
 import UniqSet
 import Util
+import BasicTypes
 import Outputable
 import FastString
 \end{code}
@@ -112,7 +112,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
   -- if there are view patterns, just give up - don't know what the function is
 check qs = (untidy_warns, shadowed_eqns)
       where
-	(warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs)
+        tidy_qs = map tidy_eqn qs
+	(warns, used_nos) = check' ([1..] `zip` tidy_qs)
 	untidy_warns = map untidy_exhaustive warns 
 	shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], 
 				not (i `elementOfUniqSet` used_nos)]
@@ -436,14 +437,14 @@ get_lit :: Pat id -> Maybe HsLit
 -- It doesn't matter which one, because they will only be compared
 -- with other HsLits gotten in the same way
 get_lit (LitPat lit)				          = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsIntegral i})    mb _) = Just (HsIntPrim   (mb_neg negate              mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
 get_lit (NPat (OverLit { ol_val = HsIsString s })   _  _) = Just (HsStringPrim s)
 get_lit _                                	          = Nothing
 
-mb_neg :: Num a => Maybe b -> a -> a
-mb_neg Nothing  v = v
-mb_neg (Just _) v = -v
+mb_neg :: (a -> a) -> Maybe b -> a -> a
+mb_neg _      Nothing  v = v
+mb_neg negate (Just _) v = negate v
 
 get_unused_cons :: [Pat Id] -> [DataCon]
 get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
@@ -643,7 +644,7 @@ might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs
 
 -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
 might_fail_pat (LazyPat _)                   = False -- Always succeeds
-might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat, TypePat
+might_fail_pat _                             = False -- VarPat, WildPat, LitPat, NPat
 
 --------------
 might_fail_lpat :: LPat Id -> Bool
@@ -671,8 +672,6 @@ tidy_pat (CoPat _ pat _)  = tidy_pat pat
 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
 tidy_pat (ViewPat _ _ ty)     = WildPat ty
 
-tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
-
 tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
   = pat { pat_args = tidy_con id ps }
 
@@ -696,16 +695,18 @@ tidy_pat (TuplePat ps boxity ty)
   where
     arity = length ps
 
--- Unpack string patterns fully, so we can see when they overlap with
--- each other, or even explicit lists of Chars.
-tidy_pat (LitPat lit)
+tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (LitPat lit)         = tidy_lit_pat lit
+
+tidy_lit_pat :: HsLit -> Pat Id
+-- Unpack string patterns fully, so we can see when they 
+-- overlap with each other, or even explicit lists of Chars.
+tidy_lit_pat lit
   | HsString s <- lit
-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 		  (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
   | otherwise
   = tidyLitPat lit 
-  where
-    mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
 
 -----------------
 tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 0daa6be..37cbc2d 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -301,10 +301,9 @@ addTickHsExpr (HsLet binds e) =
 	liftM2 HsLet
 		(addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
-        (stmts', last_exp') <- addTickLStmts' forQual stmts 
-                                     (addTickLHsExpr last_exp)
-	return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc) 
+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+       ; return (HsDo cxt stmts' srcloc) }
   where
 	forQual = case cxt of
 		    ListComp -> Just $ BinBox QualBinBox
@@ -424,45 +423,50 @@ addTickLStmts isGuard stmts = do
 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
                -> TM ([LStmt Id], a)
 addTickLStmts' isGuard lstmts res
-  = bindLocals binders $ do
-        lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
-        a <- res
-        return (lstmts', a)
-  where
-        binders = collectLStmtsBinders lstmts
+  = bindLocals (collectLStmtsBinders lstmts) $ 
+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+       ; a <- res
+       ; return (lstmts', a) }
 
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt _isGuard (LastStmt e ret) = do
+	liftM2 LastStmt
+		(addTickLHsExpr e)
+		(addTickSyntaxExpr hpcSrcSpan ret)
 addTickStmt _isGuard (BindStmt pat e bind fail) = do
 	liftM4 BindStmt
 		(addTickLPat pat)
 		(addTickLHsExprAlways e)
 		(addTickSyntaxExpr hpcSrcSpan bind)
 		(addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' ty) = do
-	liftM3 ExprStmt
+addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
+	liftM4 ExprStmt
 		(addTick isGuard e)
 		(addTickSyntaxExpr hpcSrcSpan bind')
+		(addTickSyntaxExpr hpcSrcSpan guard')
 		(return ty)
 addTickStmt _isGuard (LetStmt binds) = do
 	liftM LetStmt
 		(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs) = do
-    liftM ParStmt 
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
+    liftM4 ParStmt 
         (mapM (addTickStmtAndBinders isGuard) pairs)
-
-addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
-    liftM4 TransformStmt 
-        (addTickLStmts isGuard stmts)
-        (return ids)
-        (addTickLHsExprAlways usingExpr)
-        (addTickMaybeByLHsExpr maybeByExpr)
-
-addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
-    liftM4 GroupStmt 
-        (addTickLStmts isGuard stmts)
-        (return binderMap)
-        (fmapMaybeM  addTickLHsExprAlways by)
-	(fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+        (addTickSyntaxExpr hpcSrcSpan bindExpr)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+                                    , trS_by = by, trS_using = using
+                                    , trS_ret = returnExpr, trS_bind = bindExpr
+                                    , trS_fmap = liftMExpr }) = do
+    t_s <- addTickLStmts isGuard stmts
+    t_y <- fmapMaybeM  addTickLHsExprAlways by
+    t_u <- addTickLHsExprAlways using
+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
 
 addTickStmt isGuard stmt@(RecStmt {})
   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
@@ -483,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) =
         (addTickLStmts isGuard stmts)
         (return ids)
 
-addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
-addTickMaybeByLHsExpr maybeByExpr = 
-    case maybeByExpr of
-        Nothing -> return Nothing
-        Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
-
 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 addTickHsLocalBinds (HsValBinds binds) = 
 	liftM HsValBinds 
@@ -569,9 +567,9 @@ addTickHsCmd (HsLet binds c) =
 	liftM2 HsLet
 		(addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
-        (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
-	return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsCmd (HsDo cxt stmts srcloc)
+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+       ; return (HsDo cxt stmts' srcloc) }
 
 addTickHsCmd (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
         liftM5 HsArrApp
@@ -610,9 +608,12 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
     binders = collectLocalBinders local_binds
 
 addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
-addTickCmdGRHS (GRHS stmts cmd) = do
-  (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
-  return $ GRHS stmts' expr'
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS stmts cmd)
+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) 
+                                   stmts (addTickLHsCmd cmd)
+       ; return $ GRHS stmts' expr' }
 
 addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
 addTickLCmdStmts stmts = do
@@ -635,10 +636,15 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
 		(addTickLHsCmd c)
 		(return bind)
 		(return fail)
-addTickCmdStmt (ExprStmt c bind' ty) = do
-	liftM3 ExprStmt
+addTickCmdStmt (LastStmt c ret) = do
+	liftM2 LastStmt
+		(addTickLHsCmd c)
+		(addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (ExprStmt c bind' guard' ty) = do
+	liftM4 ExprStmt
 		(addTickLHsCmd c)
-		(return bind')
+		(addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
 		(return ty)
 addTickCmdStmt (LetStmt binds) = do
 	liftM LetStmt
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 0e7c032..b2131ca 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -535,6 +535,8 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
 
+
+
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
@@ -592,4 +594,4 @@ simplifyBind (Rec (rbs@((b,e):rbs'))) =
     else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
 
 simplifyBinds = concatMap simplifyBind
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 58bf6b8..7f798f8 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
                         core_body,
         exprFreeVars core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
-  = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+  = dsCmdDo ids local_vars env_ids res_ty stmts 
 
 --	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 --	A | xs |- ci :: [tsi] ti
@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 				-- so don't pull on it too early
 	-> Type			-- return type of the statement
 	-> [LStmt Id]		-- statements to desugar
-	-> LHsExpr Id		-- body
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet)		-- set of local vars that occur free
 
@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 --	--------------------------
 --	A | xs |- do { c } :: [] t
 
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
   = dsLCmd ids local_vars env_ids [] res_ty body
 
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
     let
         bound_vars = mkVarSet (collectLStmtBinders stmt)
         local_vars' = local_vars `unionVarSet` bound_vars
     (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
-        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts 
         return (core_stmts, fv_stmts, varSetElems fv_stmts))
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
     return (do_compose ids
@@ -674,7 +675,7 @@ dsCmdStmt
 --		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 --			arr snd >>> ss
 
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
     core_mux <- matchEnvStack env_ids []
         (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
@@ -1061,7 +1062,6 @@ collectl (L _ pat) bndrs
 
     go (SigPatIn pat _)           = collectl pat bndrs
     go (SigPatOut pat _)          = collectl pat bndrs
-    go (TypePat _)                = bndrs
     go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
     go (ViewPat _ pat _)          = collectl pat bndrs
     go p@(QuasiQuotePat {})       = pprPanic "collectl/go" (ppr p)
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 815c0d1..65cb815 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+		 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
 		 DsEvBind(..), AutoScc(..)
   ) where
 
@@ -36,6 +36,7 @@ import Digraph
 
 import TcType
 import Type
+import Coercion
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
@@ -230,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
-    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvSuperClass d _) = [d]
 
@@ -247,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
     (arg_tys, _) = splitFunTys rho
     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
                    ++ map mkWildValBinder arg_tys
-    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
                                       co_var
                         | otherwise = mkWildEvBinder p
     
@@ -263,7 +264,7 @@ dsEvTerm :: EvTerm -> CoreExpr
 dsEvTerm (EvId v)                = Var v
 dsEvTerm (EvCast v co)           = Cast (Var v) co
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvCoercion co)         = Coercion co
 dsEvTerm (EvSuperClass d n)
   = ASSERT( isClassPred (classSCTheta cls !! n) )
     	    -- We can only select *dictionary* superclasses
@@ -597,17 +598,13 @@ decomposeRuleLhs bndrs lhs
 
    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
                       2 (ppr opt_lhs)
-   dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
-				 <+> ptext (sLit "is not bound in RULE lhs"))
+   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
+			     , ptext (sLit "is not bound in RULE lhs")])
                       2 (ppr opt_lhs)
    pp_bndr bndr
-    | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
-    | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
-    | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
-    | otherwise     = ptext (sLit "variable") <+> ppr bndr
-
-   get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" 
-                                 (tcSplitPredTy_maybe (idType b))
+    | isTyVar bndr  = ptext (sLit "type variable") <+> quotes (ppr bndr)
+    | isEvVar bndr  = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
+    | otherwise     = ptext (sLit "variable") <+> quotes (ppr bndr)
 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]
@@ -634,7 +631,6 @@ otherwise we don't match when given an argument like
 NB: tcSimplifyRuleLhs is very careful not to generate complicated
     dictionary expressions that we might have to match
 
-
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index f46d99e..58ebc26 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -273,7 +273,7 @@ boxResult result_ty
 	; let io_data_con = head (tyConDataCons io_tycon)
 	      toIOCon     = dataConWrapId io_data_con
 
-	      wrap the_call = mkCoerceI (mkSymCoI co) $
+	      wrap the_call = mkCoerce (mkSymCo co) $
 			      mkApps (Var toIOCon)
 			    	     [ Type io_res_ty, 
 			    	       Lam state_id $
@@ -372,7 +372,7 @@ resultWrapper result_ty
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+       return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 5b566a0..2ac19ce 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -49,8 +49,8 @@ import DynFlags
 import StaticFlags
 import CostCentre
 import Id
-import Var
 import VarSet
+import VarEnv
 import DataCon
 import TysWiredIn
 import BasicTypes
@@ -335,26 +335,12 @@ dsExpr (HsLet binds body) = do
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
-dsExpr (HsDo ListComp stmts body result_ty)
-  =	-- Special case for list comprehensions
-    dsListComp stmts body elt_ty
-  where
-    [elt_ty] = tcTyConAppArgs result_ty
-
-dsExpr (HsDo DoExpr stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo GhciStmt stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo MDoExpr stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo PArrComp stmts body result_ty)
-  =	-- Special case for array comprehensions
-    dsPArrComp (map unLoc stmts) body elt_ty
-  where
-    [elt_ty] = tcTyConAppArgs result_ty
+dsExpr (HsDo ListComp  stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp  stmts _)      = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr    stmts _)      = dsDo stmts 
+dsExpr (HsDo GhciStmt  stmts _)      = dsDo stmts 
+dsExpr (HsDo MDoExpr   stmts _)      = dsDo stmts 
+dsExpr (HsDo MonadComp stmts _)      = dsMonadComp stmts
 
 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
@@ -537,12 +523,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 
     mk_alt upd_fld_env con
       = do { let (univ_tvs, ex_tvs, eq_spec, 
-		  eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
+		  theta, arg_tys, _) = dataConFullSig con
 		 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
 
 		-- I'm not bothering to clone the ex_tvs
 	   ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
-	   ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
+	   ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
 	   ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
 	   ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
     					 (dataConFieldLabels con) arg_ids
@@ -553,21 +539,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 		 wrap = mkWpEvVarApps theta_vars          `WpCompose` 
 			mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
 			mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
-				       , isNothing (lookupTyVar wrap_subst tv) ]
+				       , not (tv `elemVarEnv` wrap_subst) ]
     	         rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 
 			-- Tediously wrap the application in a cast
 			-- Note [Update for GADTs]
 		 wrapped_rhs | null eq_spec = rhs
 			     | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
-		 wrap_co = mkTyConApp tycon [ lookup tv ty 
-					    | (tv,ty) <- univ_tvs `zip` out_inst_tys]
-		 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
-					Just ty' -> ty'
-					Nothing  -> ty
-		 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
-					   | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
-		 
+		 wrap_co = mkTyConAppCo tycon [ lookup tv ty
+					      | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+		 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
+					Just co' -> co'
+					Nothing  -> mkReflCo ty
+		 wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
+				       | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+
     	         pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
 					 , pat_dicts = eqs_vars ++ theta_vars
 					 , pat_binds = emptyTcEvBinds
@@ -607,7 +593,7 @@ dsExpr (HsTick ix vars e) = do
 
 dsExpr (HsBinTick ixT ixF e) = do
   e2 <- dsLExpr e
-  do { ASSERT(exprType e2 `coreEqType` boolTy)
+  do { ASSERT(exprType e2 `eqType` boolTy)
        mkBinaryTickBox ixT ixF e2
      }
 \end{code}
@@ -718,25 +704,20 @@ handled in DsListComp).  Basically does the translation given in the
 Haskell 98 report:
 
 \begin{code}
-dsDo	:: [LStmt Id]
-	-> LHsExpr Id
-	-> Type			-- Type of the whole expression
-	-> DsM CoreExpr
-
-dsDo stmts body result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
   = goL stmts
   where
-    -- result_ty must be of the form (m b)
-    (m_ty, _b_ty) = tcSplitAppTy result_ty
-
-    goL [] = dsLExpr body
-    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+    goL [] = panic "dsDo"
+    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
   
-    go _ (ExprStmt rhs then_expr _) stmts
+    go _ (LastStmt body _) stmts
+      = ASSERT( null stmts ) dsLExpr body
+        -- The 'return' op isn't used for 'do' expressions
+
+    go _ (ExprStmt rhs then_expr _ _) stmts
       = do { rhs2 <- dsLExpr rhs
-           ; case tcSplitAppTy_maybe (exprType rhs2) of
-                Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
-                _                                 -> return ()
+           ; warnDiscardedDoBindings rhs (exprType rhs2) 
            ; then_expr2 <- dsExpr then_expr
 	   ; rest <- goL stmts
 	   ; return (mkApps then_expr2 [rhs2, rest]) }
@@ -760,29 +741,29 @@ dsDo stmts body result_ty
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_rec_rets = rec_rets }) stmts
+                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
       = ASSERT( length rec_ids > 0 )
         goL (new_bind_stmt : stmts)
       where
-        -- returnE <- dsExpr return_id
-        -- mfixE <- dsExpr mfix_id
-        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
-                                         bind_op 
+        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+                                         mfix_app bind_op 
                                          noSyntaxExpr  -- Tuple cannot fail
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+        tup_ty       = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
-
-        mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
-        mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
-                                             (mkFunTy tup_ty body_ty))
-        mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
-        body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
-        return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-	body_ty    = mkAppTy m_ty tup_ty
-        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
+        mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+                                                 (mkFunTy tup_ty body_ty))
+        mfix_pat     = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+        body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
+        ret_app      = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+        ret_stmt     = noLoc $ mkLastStmt ret_app
+		     -- This LastStmt will be desugared with dsDo, 
+		     -- which ignores the return_op in the LastStmt,
+		     -- so we must apply the return_op explicitly 
 
 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
@@ -800,104 +781,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++
 		  showSDoc (ppr (getLoc pat))
 \end{code}
 
-Translation for RecStmt's: 
------------------------------
-We turn (RecStmt [v1,..vn] stmts) into:
-  
-  (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
-				      return (v1,..vn))
-
-\begin{code}
-{-
-dsMDo   :: HsStmtContext Name
-        -> [(Name,Id)]
-	-> [LStmt Id]
-	-> LHsExpr Id
-	-> Type			-- Type of the whole expression
-	-> DsM CoreExpr
-
-dsMDo ctxt tbl stmts body result_ty
-  = goL stmts
-  where
-    goL [] = dsLExpr body
-    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-  
-    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
-    return_id = lookupEvidence tbl returnMName
-    bind_id   = lookupEvidence tbl bindMName
-    then_id   = lookupEvidence tbl thenMName
-    fail_id   = lookupEvidence tbl failMName
-
-    go _ (LetStmt binds) stmts
-      = do { rest <- goL stmts
-	   ; dsLocalBinds binds rest }
-
-    go _ (ExprStmt rhs then_expr rhs_ty) stmts
-      = do { rhs2 <- dsLExpr rhs
-	   ; warnDiscardedDoBindings rhs m_ty rhs_ty
-           ; then_expr2 <- dsExpr then_expr
-           ; rest <- goL stmts
-           ; return (mkApps then_expr2 [rhs2, rest]) }
-    
-    go _ (BindStmt pat rhs bind_op _) stmts
-      = do { body     <- goL stmts
-           ; rhs'     <- dsLExpr rhs
-           ; bind_op' <- dsExpr bind_op
-           ; var   <- selectSimpleMatchVarL pat
-	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
-                                     result_ty (cantFailMatchResult body)
-           ; match_code <- handle_failure pat match fail_op
-           ; return (mkApps bind_op [rhs', Lam var match_code]) }
-    
-    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
-                    , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
-                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
-      = ASSERT( length rec_ids > 0 )
-        ASSERT( length rec_ids == length rec_rets )
-        ASSERT( isEmptyTcEvBinds _ev_binds )
-        pprTrace "dsMDo" (ppr later_ids) $
-	 goL (new_bind_stmt : stmts)
-      where
-        new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
-                                         bind_op noSyntaxExpr
-	
-		-- Remove the later_ids that appear (without fancy coercions) 
-		-- in rec_rets, because there's no need to knot-tie them separately
-		-- See Note [RecStmt] in HsExpr
-	later_ids'   = filter (`notElem` mono_rec_ids) later_ids
-	mono_rec_ids = [ id | HsVar id <- rec_rets ]
-    
-        mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
-	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
-					     (mkFunTy tup_ty body_ty))
-
-	-- The rec_tup_pat must bind the rec_ids only; remember that the 
-	-- 	trimmed_laters may share the same Names
-	-- Meanwhile, the later_pats must bind the later_vars
-	rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
-	later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
-	rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
-
-	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
-	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
-	body_ty = mkAppTy m_ty tup_ty
-	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
-
-        return_app  = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-
-	mk_wild_pat :: Id -> LPat Id 
-   	mk_wild_pat v = noLoc $ WildPat $ idType v
-
-	mk_later_pat :: Id -> LPat Id
-	mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
-		       | otherwise	     = nlVarPat v
-
- 	mk_tup_pat :: [LPat Id] -> LPat Id
-  	mk_tup_pat [p] = p
-	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
--}
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -914,7 +797,7 @@ warnAboutIdentities (Var v) co_fn
   | idName v `elem` conversionNames
   , let fun_ty = exprType (co_fn (Var v))
   , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-  , arg_ty `tcEqType` res_ty  -- So we are converting  ty -> ty
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
                  , nest 2 $ ptext (sLit "can probably be omitted")
                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
@@ -937,30 +820,34 @@ conversionNames
 
 \begin{code}
 -- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
-warnDiscardedDoBindings rhs container_ty returning_ty = do {
-          -- Warn about discarding non-() things in 'monadic' binding
-        ; warn_unused <- doptDs Opt_WarnUnusedDoBind
-        ; if warn_unused && not (returning_ty `tcEqType` unitTy)
-           then warnDs (unusedMonadBind rhs returning_ty)
-           else do {
-          -- Warn about discarding m a things in 'monadic' binding of the same type,
-          -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
-        ; warn_wrong <- doptDs Opt_WarnWrongDoBind
-        ; case tcSplitAppTy_maybe returning_ty of
-                  Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
-                                                            warnDs (wrongMonadBind rhs returning_ty)
-                  _ -> return () } }
+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+  = do {  -- Warn about discarding non-() things in 'monadic' binding
+       ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+       ; if warn_unused && not (isUnitTy elt_ty)
+         then warnDs (unusedMonadBind rhs elt_ty)
+         else 
+         -- Warn about discarding m a things in 'monadic' binding of the same type,
+         -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+    do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+       ; case tcSplitAppTy_maybe elt_ty of
+           Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
+                              -> warnDs (wrongMonadBind rhs elt_ty)
+           _ -> return () } }
+
+  | otherwise	-- RHS does have type of form (m ty), which is wierd
+  = return ()   -- but at lesat this warning is irrelevant
 
 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
-unusedMonadBind rhs returning_ty
-  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+unusedMonadBind rhs elt_ty
+  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
 
 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
-wrongMonadBind rhs returning_ty
-  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+wrongMonadBind rhs elt_ty
+  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
 \end{code}
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 2c2d7f2..aee1594 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -28,7 +28,6 @@ import Type
 import TyCon
 import Coercion
 import TcType
-import Var
 
 import CmmExpr
 import CmmUtils
@@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do
                  IsFunction
              _ -> IsData
    (resTy, foRhs) <- resultWrapper ty
-   ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let
         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
         stdcall_info = fun_type_arg_stdcall_info cconv ty
@@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do
     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 
-    let io_app = mkLams tvs                $
-                 Lam cback                 $
-                 mkCoerceI (mkSymCoI co)   $
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkCoerce (mkSymCo co) $
                  mkApps (Var bindIOId)
                         [ Type stable_ptr_ty
                         , Type res_ty       
@@ -483,7 +482,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 	 typeCmmType (mkStablePtrPrimTy alphaTy))
 
   -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `coreEqType` unitTy	-- Look through any newtypes
+  res_hty_is_unit = res_hty `eqType` unitTy	-- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
 	   | otherwise	     = showStgType res_hty
@@ -677,7 +676,7 @@ getPrimTyOf ty
 -- e.g. 'W' is a signed 32-bit integer.
 primTyDescChar :: Type -> Char
 primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
  | otherwise
  = case typePrimRep (getPrimTyOf ty) of
      IntRep	 -> signed_word
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index a7260e2..d3fcf76 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -106,11 +106,11 @@ matchGuards [] _ rhs _
 	-- NB:	The success of this clause depends on the typechecker not
 	-- 	wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
 	--	If it does, you'll get bogus overlap warnings
-matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
+matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
   | Just addTicks <- isTrueLHsExpr e = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs addTicks match_result)
-matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     pred_expr <- dsLExpr expr
     return (mkGuardedMatchResult pred_expr match_result)
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index cd22b8f..aabd6b0 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -3,9 +3,10 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
-Desugaring list comprehensions and array comprehensions
+Desugaring list comprehensions, monad comprehensions and array comprehensions
 
 \begin{code}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
@@ -13,11 +14,11 @@ Desugaring list comprehensions and array comprehensions
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module DsListComp ( dsListComp, dsPArrComp ) where
+module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
 
 import HsSyn
 import TcHsSyn
@@ -37,6 +38,7 @@ import PrelNames
 import SrcLoc
 import Outputable
 import FastString
+import TcType
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -47,12 +49,14 @@ There will be at least one ``qualifier'' in the input.
 
 \begin{code}
 dsListComp :: [LStmt Id] 
-	   -> LHsExpr Id
-	   -> Type		-- Type of list elements
+	   -> Type		-- Type of entire list 
 	   -> DsM CoreExpr
-dsListComp lquals body elt_ty = do 
+dsListComp lquals res_ty = do 
     dflags <- getDOptsDs
     let quals = map unLoc lquals
+        elt_ty = case tcTyConAppArgs res_ty of
+                   [elt_ty] -> elt_ty
+                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
     
     if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
        -- Either rules are switched off, or we are ignoring what there are;
@@ -60,8 +64,8 @@ dsListComp lquals body elt_ty = do
        -- Wadler-style desugaring
        || isParallelComp quals
        -- Foldr-style desugaring can't handle parallel list comprehensions
-        then deListComp quals body (mkNilExpr elt_ty)
-        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body) 
+        then deListComp quals (mkNilExpr elt_ty)
+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) 
              -- Foldr/build should be enabled, so desugar 
              -- into foldrs and builds
 
@@ -72,92 +76,69 @@ dsListComp lquals body elt_ty = do
     -- mix of possibly a single element in length, so we do this to leave the possibility open
     isParallelComp = any isParallelStmt
   
-    isParallelStmt (ParStmt _) = True
-    isParallelStmt _           = False
+    isParallelStmt (ParStmt _ _ _ _) = True
+    isParallelStmt _                 = False
     
     
 -- This function lets you desugar a inner list comprehension and a list of the binders
 -- of that comprehension that we need in the outer comprehension into such an expression
 -- and the type of the elements that it outputs (tuples of binders)
 dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
-dsInnerListComp (stmts, bndrs) = do
-        expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
-        return (expr, bndrs_tuple_type)
-    where
-        bndrs_types = map idType bndrs
-        bndrs_tuple_type = mkBigCoreTupTy bndrs_types
-        
+dsInnerListComp (stmts, bndrs)
+  = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) 
+                            (mkListTy bndrs_tuple_type)
+       ; return (expr, bndrs_tuple_type) }
+  where
+    bndrs_tuple_type = mkBigCoreVarTupTy bndrs
         
--- This function factors out commonality between the desugaring strategies for TransformStmt.
--- Given such a statement it gives you back an expression representing how to compute the transformed
--- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
- = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
-      ; usingExpr' <- dsLExpr usingExpr
-    
-      ; using_args <-
-          case maybeByExpr of
-            Nothing -> return [expr]
-            Just byExpr -> do
-                byExpr' <- dsLExpr byExpr
-                
-                us <- newUniqueSupply
-                [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
-                let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
-                
-                return [Lam tuple_binder byExprWrapper, expr]
-
-      ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
-            pat = mkBigLHsVarPatTup binders
-      ; return (inner_list_expr, pat) }
-    
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- Given such a statement it gives you back an expression representing how to compute the transformed
 -- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsGroupStmt (GroupStmt stmts binderMap by using) = do
-    let (fromBinders, toBinders) = unzip binderMap
-        
-        fromBindersTypes = map idType fromBinders
-        toBindersTypes = map idType toBinders
-        
-        toBindersTupleType = mkBigCoreTupTy toBindersTypes
+dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+                       , trS_by = by, trS_using = using }) = do
+    let (from_bndrs, to_bndrs) = unzip binderMap
+        from_bndrs_tys  = map idType from_bndrs
+        to_bndrs_tys    = map idType to_bndrs
+        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
     
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
+    (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs)
     
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
-    usingExpr' <- dsLExpr (either id noLoc using)
+    usingExpr' <- dsLExpr using
     usingArgs <- case by of
                    Nothing   -> return [expr]
  		   Just by_e -> do { by_e' <- dsLExpr by_e
-                                   ; us <- newUniqueSupply
-                                   ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
-                                   ; let by_wrap = mkTupleCase us fromBinders by_e' 
-                                                   from_tup_id (Var from_tup_id)
-                                   ; return [Lam from_tup_id by_wrap, expr] }
+                                   ; lam <- matchTuple from_bndrs by_e'
+                                   ; return [lam, expr] }
     
     -- Create an unzip function for the appropriate arity and element types and find "map"
-    (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
+    unzip_stuff <- mkUnzipBind form from_bndrs_tys
     map_id <- dsLookupGlobalId mapName
 
     -- Generate the expressions to build the grouped list
     let -- First we apply the grouping function to the inner list
-        inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
+        inner_list_expr = mkApps usingExpr' usingArgs
         -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
         -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
         -- the "b" to be a tuple of "to" lists!
-        unzipped_inner_list_expr = mkApps (Var map_id) 
-            [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
         -- Then finally we bind the unzip function around that expression
-        bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
-    
-    -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
-    let pat = mkBigLHsVarPatTup toBinders
+        bound_unzipped_inner_list_expr 
+          = case unzip_stuff of
+              Nothing -> inner_list_expr
+              Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $
+                                            mkApps (Var map_id) $
+                                            [ Type (mkListTy from_tup_ty)
+                                            , Type to_bndrs_tup_ty
+                                            , Var unzip_fn
+                                            , inner_list_expr]
+
+    -- Build a pattern that ensures the consumer binds into the NEW binders, 
+    -- which hold lists rather than single values
+    let pat = mkBigLHsVarPatTup to_bndrs
     return (bound_unzipped_inner_list_expr, pat)
-    
 \end{code}
 
 %************************************************************************
@@ -226,53 +207,50 @@ with the Unboxed variety.
 
 \begin{code}
 
-deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
-
-deListComp (ParStmt stmtss_w_bndrs : quals) body list
-  = do
-    exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
-    let (exps, qual_tys) = unzip exps_and_qual_tys
-    
-    (zip_fn, zip_rhs) <- mkZipBind qual_tys
+deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
 
-	-- Deal with [e | pat <- zip l1 .. ln] in example above
-    deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 
-		   quals body list
+deListComp [] _ = panic "deListComp"
 
-  where 
-	bndrs_s = map snd stmtss_w_bndrs
-
-	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
-	pat  = mkBigLHsPatTup pats
-	pats = map mkBigLHsVarPatTup bndrs_s
-
-	-- Last: the one to return
-deListComp [] body list = do    -- Figure 7.4, SLPJ, p 135, rule C above
-    core_body <- dsLExpr body
-    return (mkConsExpr (exprType core_body) core_body list)
+deListComp (LastStmt body _ : quals) list 
+  =     -- Figure 7.4, SLPJ, p 135, rule C above
+    ASSERT( null quals )
+    do { core_body <- dsLExpr body
+       ; return (mkConsExpr (exprType core_body) core_body list) }
 
 	-- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ : quals) body list = do  -- rule B above
+deListComp (ExprStmt guard _ _ _ : quals) list = do  -- rule B above
     core_guard <- dsLExpr guard
-    core_rest <- deListComp quals body list
+    core_rest <- deListComp quals list
     return (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) body list = do
-    core_rest <- deListComp quals body list
+deListComp (LetStmt binds : quals) list = do
+    core_rest <- deListComp quals list
     dsLocalBinds binds core_rest
 
-deListComp (stmt@(TransformStmt {}) : quals) body list = do
-    (inner_list_expr, pat) <- dsTransformStmt stmt
-    deBindComp pat inner_list_expr quals body list
+deListComp (stmt@(TransStmt {}) : quals) list = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    deBindComp pat inner_list_expr quals list
 
-deListComp (stmt@(GroupStmt {}) : quals) body list = do
-    (inner_list_expr, pat) <- dsGroupStmt stmt
-    deBindComp pat inner_list_expr quals body list
-
-deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
+deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
     core_list1 <- dsLExpr list1
-    deBindComp pat core_list1 quals body core_list2
+    deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+       ; let (exps, qual_tys) = unzip exps_and_qual_tys
+    
+       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+	-- Deal with [e | pat <- zip l1 .. ln] in example above
+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 
+		    quals list }
+  where 
+	bndrs_s = map snd stmtss_w_bndrs
+
+	-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+	pat  = mkBigLHsPatTup pats
+	pats = map mkBigLHsVarPatTup bndrs_s
 \end{code}
 
 
@@ -280,10 +258,9 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov
 deBindComp :: OutPat Id
            -> CoreExpr
            -> [Stmt Id]
-           -> LHsExpr Id
            -> CoreExpr
            -> DsM (Expr Id)
-deBindComp pat core_list1 quals body core_list2 = do
+deBindComp pat core_list1 quals core_list2 = do
     let
         u3_ty@u1_ty = exprType core_list1	-- two names, same thing
 
@@ -300,7 +277,7 @@ deBindComp pat core_list1 quals body core_list2 = do
         core_fail   = App (Var h) (Var u3)
         letrec_body = App (Var h) core_list1
         
-    rest_expr <- deListComp quals body core_fail
+    rest_expr <- deListComp quals core_fail
     core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail	
     
     let
@@ -335,48 +312,43 @@ TE[ e | p <- l , q ] c n = let
 \begin{code}
 dfListComp :: Id -> Id -- 'c' and 'n'
         -> [Stmt Id]   -- the rest of the qual's
-        -> LHsExpr Id
         -> DsM CoreExpr
 
-	-- Last: the one to return
-dfListComp c_id n_id [] body = do
-    core_body <- dsLExpr body
-    return (mkApps (Var c_id) [core_body, Var n_id])
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt body _ : quals) 
+  = ASSERT( null quals )
+    do { core_body <- dsLExpr body
+       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
 
 	-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _  : quals) body = do
+dfListComp c_id n_id (ExprStmt guard _ _ _  : quals) = do
     core_guard <- dsLExpr guard
-    core_rest <- dfListComp c_id n_id quals body
+    core_rest <- dfListComp c_id n_id quals
     return (mkIfThenElse core_guard core_rest (Var n_id))
 
-dfListComp c_id n_id (LetStmt binds : quals) body = do
+dfListComp c_id n_id (LetStmt binds : quals) = do
     -- new in 1.3, local bindings
-    core_rest <- dfListComp c_id n_id quals body
+    core_rest <- dfListComp c_id n_id quals
     dsLocalBinds binds core_rest
 
-dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
-    (inner_list_expr, pat) <- dsTransformStmt stmt
-    -- Anyway, we bind the newly transformed list via the generic binding function
-    dfBindComp c_id n_id (pat, inner_list_expr) quals body
-
-dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
-    (inner_list_expr, pat) <- dsGroupStmt stmt
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
     -- Anyway, we bind the newly grouped list via the generic binding function
-    dfBindComp c_id n_id (pat, inner_list_expr) quals body
+    dfBindComp c_id n_id (pat, inner_list_expr) quals 
     
-dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
     -- evaluate the two lists
     core_list1 <- dsLExpr list1
     
     -- Do the rest of the work in the generic binding builder
-    dfBindComp c_id n_id (pat, core_list1) quals body
+    dfBindComp c_id n_id (pat, core_list1) quals
                
 dfBindComp :: Id -> Id	        -- 'c' and 'n'
        -> (LPat Id, CoreExpr)
 	   -> [Stmt Id] 	        -- the rest of the qual's
-	   -> LHsExpr Id
 	   -> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals body = do
+dfBindComp c_id n_id (pat, core_list1) quals = do
     -- find the required type
     let x_ty   = hsLPatType pat
         b_ty   = idType n_id
@@ -385,7 +357,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do
     [b, x] <- newSysLocalsDs [b_ty, x_ty]
 
     -- build rest of the comprehesion
-    core_rest <- dfListComp c_id b quals body
+    core_rest <- dfListComp c_id b quals
 
     -- build the pattern match
     core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
@@ -439,7 +411,7 @@ mkZipBind elt_tys = do
 			-- Increasing order of tag
             
             
-mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
 -- mkUnzipBind [t1, t2] 
 -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
 --     -> case ax of
@@ -449,28 +421,29 @@ mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
 --      ys)
 -- 
 -- We use foldr here in all cases, even if rules are turned off, because we may as well!
-mkUnzipBind elt_tys = do
-    ax  <- newSysLocalDs elt_tuple_ty
-    axs <- newSysLocalDs elt_list_tuple_ty
-    ys  <- newSysLocalDs elt_tuple_list_ty
-    xs  <- mapM newSysLocalDs elt_tys
-    xss <- mapM newSysLocalDs elt_list_tys
+mkUnzipBind ThenForm _
+ = return Nothing    -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys 
+  = do { ax  <- newSysLocalDs elt_tuple_ty
+       ; axs <- newSysLocalDs elt_list_tuple_ty
+       ; ys  <- newSysLocalDs elt_tuple_list_ty
+       ; xs  <- mapM newSysLocalDs elt_tys
+       ; xss <- mapM newSysLocalDs elt_list_tys
     
-    unzip_fn <- newSysLocalDs unzip_fn_ty
-
-    [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
-    let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
-        
-        concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
-        tupled_concat_expression = mkBigCoreTup concat_expressions
-        
-        folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
-        folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
-        folder_body = mkLams [ax, axs] folder_body_outer_case
-        
-    unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
-    return (unzip_fn, mkLams [ys] unzip_body)
+       ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+    	     concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+    	     tupled_concat_expression = mkBigCoreTup concat_expressions
+    	    
+    	     folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+    	     folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+    	     folder_body = mkLams [ax, axs] folder_body_outer_case
+    	    
+       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
   where
     elt_tuple_ty       = mkBigCoreTupTy elt_tys
     elt_tuple_list_ty  = mkListTy elt_tuple_ty
@@ -480,9 +453,6 @@ mkUnzipBind elt_tys = do
     unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
             
     mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-            
-            
-
 \end{code}
 
 %************************************************************************
@@ -498,11 +468,10 @@ mkUnzipBind elt_tys = do
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --
 dsPArrComp :: [Stmt Id] 
-            -> LHsExpr Id
-            -> Type		    -- Don't use; called with `undefined' below
             -> DsM CoreExpr
-dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
-  dePArrParComp qss body
+
+-- Special case for parallel comprehension
+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
 
 -- Special case for simple generators:
 --
@@ -513,7 +482,7 @@ dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
 --  <<[:e' | p <- e, qs:]>> = 
 --    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
 --
-dsPArrComp (BindStmt p e _ _ : qs) body _ = do
+dsPArrComp (BindStmt p e _ _ : qs) = do
     filterP <- dsLookupDPHId filterPName
     ce <- dsLExpr e
     let ety'ce  = parrElemType ce
@@ -523,38 +492,41 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do
     pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
     let gen | isIrrefutableHsPat p = ce
             | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
-    dePArrComp qs body p gen
+    dePArrComp qs p gen
 
-dsPArrComp qs            body _  = do -- no ParStmt in `qs'
+dsPArrComp qs = do -- no ParStmt in `qs'
     sglP <- dsLookupDPHId singletonPName
     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
-    dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
+    dePArrComp qs (noLoc $ WildPat unitTy) unitArray
 
 
 
 -- the work horse
 --
 dePArrComp :: [Stmt Id] 
-	   -> LHsExpr Id
 	   -> LPat Id		-- the current generator pattern
 	   -> CoreExpr		-- the current generator expression
 	   -> DsM CoreExpr
+
+dePArrComp [] _ _ = panic "dePArrComp"
+
 --
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
-dePArrComp [] e' pa cea = do
-    mapP <- dsLookupDPHId mapPName
-    let ty = parrElemType cea
-    (clam, ty'e') <- deLambda ty pa e'
-    return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+dePArrComp (LastStmt e' _ : quals) pa cea
+  = ASSERT( null quals )
+    do { mapP <- dsLookupDPHId mapPName
+       ; let ty = parrElemType cea
+       ; (clam, ty'e') <- deLambda ty pa e'
+       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
 --
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
-dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
+dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
     filterP <- dsLookupDPHId filterPName
     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
-    dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
 
 --
 --  <<[:e' | p <- e, qs:]>> pa ea =
@@ -569,7 +541,7 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
-dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
+dePArrComp (BindStmt p e _ _ : qs) pa cea = do
     filterP <- dsLookupDPHId filterPName
     crossMapP <- dsLookupDPHId crossMapPName
     ce <- dsLExpr e
@@ -585,7 +557,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
     let ety'cef = ety'ce		    -- filter doesn't change the element type
         pa'     = mkLHsPatTup [pa, p]
 
-    dePArrComp qs body pa' (mkApps (Var crossMapP) 
+    dePArrComp qs pa' (mkApps (Var crossMapP) 
                                  [Type ety'cea, Type ety'cef, cea, clam])
 --
 --  <<[:e' | let ds, qs:]>> pa ea = 
@@ -594,7 +566,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
 --  where
 --    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
 --
-dePArrComp (LetStmt ds : qs) body pa cea = do
+dePArrComp (LetStmt ds : qs) pa cea = do
     mapP <- dsLookupDPHId mapPName
     let xs     = collectLocalBinders ds
         ty'cea = parrElemType cea
@@ -609,14 +581,14 @@ dePArrComp (LetStmt ds : qs) body pa cea = do
     ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
     let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
         proj   = mkLams [v] ccase
-    dePArrComp qs body pa' (mkApps (Var mapP) 
+    dePArrComp qs pa' (mkApps (Var mapP) 
                                    [Type ty'cea, Type errTy, proj, cea])
 --
 -- The parser guarantees that parallel comprehensions can only appear as
 -- singeltons qualifier lists, which we already special case in the caller.
 -- So, encountering one here is a bug.
 --
-dePArrComp (ParStmt _ : _) _ _ _ = 
+dePArrComp (ParStmt _ _ _ _ : _) _ _ = 
   panic "DsListComp.dePArrComp: malformed comprehension AST"
 
 --  <<[:e' | qs | qss:]>> pa ea = 
@@ -625,17 +597,17 @@ dePArrComp (ParStmt _ : _) _ _ _ =
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
-dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
-dePArrParComp qss body = do
+dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp qss quals = do
     (pQss, ceQss) <- deParStmt qss
-    dePArrComp [] body pQss ceQss
+    dePArrComp quals pQss ceQss
   where
     deParStmt []             =
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
     deParStmt ((qs, xs):qss) = do        -- first statement
       let res_expr = mkLHsVarTuple xs
-      cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
       parStmts qss (mkLHsVarPatTup xs) cqs
     ---
     parStmts []             pa cea = return (pa, cea)
@@ -644,7 +616,7 @@ dePArrParComp qss body = do
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
           res_expr = mkLHsVarTuple xs
-      cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
       let ty'cqs = parrElemType cqs
           cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
       parStmts qss pa' cea'
@@ -682,3 +654,222 @@ parrElemType e  =
     _							  -> panic
       "DsListComp.parrElemType: not a parallel array type"
 \end{code}
+
+Translation for monad comprehensions
+
+\begin{code}
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [LStmt Id] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [LStmt Id] -> DsM CoreExpr
+dsMcStmts []                    = panic "dsMcStmts"
+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
+
+dsMcStmt (LastStmt body ret_op) stmts
+  = ASSERT( null stmts )
+    do { body' <- dsLExpr body
+       ; ret_op' <- dsExpr ret_op
+       ; return (App ret_op' body') }
+
+--   [ .. | let binds, stmts ]
+dsMcStmt (LetStmt binds) stmts 
+  = do { rest <- dsMcStmts stmts
+       ; dsLocalBinds binds rest }
+
+--   [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
+  = do { rhs' <- dsLExpr rhs
+       ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+--   [ .. | exp, stmts ]
+--
+dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts 
+  = do { exp'       <- dsLExpr exp
+       ; guard_exp' <- dsExpr guard_exp
+       ; then_exp'  <- dsExpr then_exp
+       ; rest       <- dsMcStmts stmts
+       ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
+                                   , rest ] }
+
+-- Group statements desugar like this:
+--
+--   [| (q, then group by e using f); rest |]
+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> 
+--         case unzip n_tup of qv' -> [| rest |]
+--
+-- where   variables (v1:t1, ..., vk:tk) are bound by q
+--         qv = (v1, ..., vk)
+--         qt = (t1, ..., tk)
+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+--         n_tup :: n qt
+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+                    , trS_by = by, trS_using = using
+                    , trS_ret = return_op, trS_bind = bind_op
+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+  = do { let (from_bndrs, to_bndrs) = unzip bndrs
+             from_bndr_tys          = map idType from_bndrs	-- Types ty
+
+       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+       ; expr <- dsInnerMonadComp stmts from_bndrs return_op
+
+       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+       -- function required? If so, create that desugared function and add to arguments
+       ; usingExpr' <- dsLExpr using
+       ; usingArgs <- case by of
+                        Nothing   -> return [expr]
+                        Just by_e -> do { by_e' <- dsLExpr by_e
+                                        ; lam <- matchTuple from_bndrs by_e'
+                                        ; return [lam, expr] }
+
+       -- Generate the expressions to build the grouped list
+       -- Build a pattern that ensures the consumer binds into the NEW binders, 
+       -- which hold monads rather than single values
+       ; bind_op' <- dsExpr bind_op
+       ; let bind_ty  = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
+             n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty   -- n (a,b,c)
+             tup_n_ty = mkBigCoreVarTupTy to_bndrs
+
+       ; body       <- dsMcStmts stmts_rest
+       ; n_tup_var  <- newSysLocalDs n_tup_ty
+       ; tup_n_var  <- newSysLocalDs tup_n_ty
+       ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys
+       ; us         <- newUniqueSupply
+       ; let rhs'  = mkApps usingExpr' usingArgs
+             body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
+		   
+       ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+--   [ body | qs1 | qs2 | qs3 ]
+--     ->  [ body | (bndrs1, (bndrs2, bndrs3)) 
+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+--   mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
+ = do  { exps_w_tys  <- mapM ds_inner pairs   -- Pairs (exp :: m ty, ty)
+       ; mzip_op'    <- dsExpr mzip_op
+
+       ; let -- The pattern variables
+             pats = map (mkBigLHsVarPatTup . snd) pairs
+             -- Pattern with tuples of variables
+             -- [v1,v2,v3]  =>  (v1, (v2, v3))
+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+	     (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> 
+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+                                  mkBoxedTupleTy [t1,t2])) 
+                               exps_w_tys
+
+       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
+  where
+    ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
+                                 ; return (exp, tup_ty) }
+       where 
+         mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
+         tup_ty      = mkBigCoreVarTupTy bndrs
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+--       returns the Core term
+--  \x. case x of (a,b,c) -> body 
+matchTuple ids body
+  = do { us <- newUniqueSupply
+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat Id
+             -> CoreExpr        -- ^ the desugared rhs of the bind statement
+             -> SyntaxExpr Id
+             -> SyntaxExpr Id
+             -> [LStmt Id]
+             -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op stmts
+  = do  { body     <- dsMcStmts stmts 
+        ; bind_op' <- dsExpr bind_op
+        ; var      <- selectSimpleMatchVarL pat
+        ; let bind_ty = exprType bind_op' 	-- rhs -> (pat -> res1) -> res2
+              res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
+        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+                                  res1_ty (cantFailMatchResult body)
+        ; match_code <- handle_failure pat match fail_op
+        ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+
+  where
+    -- In a monad comprehension expression, pattern-match failure just calls
+    -- the monadic `fail` rather than throwing an exception
+    handle_failure pat match fail_op
+      | matchCanFail match
+        = do { fail_op' <- dsExpr fail_op
+             ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+             ; extractMatchResult match (App fail_op' fail_msg) }
+      | otherwise
+        = extractMatchResult match (error "It can't fail") 
+
+    mk_fail_msg :: Located e -> String
+    mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++ 
+                      showSDoc (ppr (getLoc pat))
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+--    dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of 
+--       [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [LStmt Id]
+                 -> [Id]	-- Return a tuple of these variables
+                 -> HsExpr Id	-- The monomorphic "return" operator
+                 -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+--   unzip :: m (a,b,..) -> (m a,m b,..)
+--   unzip m_tuple = ( liftM selN1 m_tuple
+--                   , liftM selN2 m_tuple
+--                   , .. )
+--
+--   mkMcUnzipM fmap ys [t1, t2]
+--     = ( fmap (selN1 :: (t1, t2) -> t1) ys
+--       , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+           -> SyntaxExpr TcId	-- fmap
+	   -> Id		-- Of type n (a,b,c)
+	   -> [Type]		-- [a,b,c]
+	   -> DsM CoreExpr	-- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _ 	
+  = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+  = do { fmap_op' <- dsExpr fmap_op
+       ; xs       <- mapM newSysLocalDs elt_tys
+       ; let tup_ty = mkBigCoreTupTy elt_tys
+       ; tup_xs   <- newSysLocalDs tup_ty
+ 
+       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
+                           [ Type tup_ty, Type (elt_tys !! i)
+                           , mk_sel i, Var ys]
+
+             mk_sel n = Lam tup_xs $ 
+                        mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
+
+       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index e34c696..a4b47ee 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -420,6 +420,10 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 	-- Singleton => Ok
 	-- Empty     => Too hard, signature ignored
 rep_sig (L loc (TypeSig nm ty))       = rep_proto nm ty loc
+rep_sig (L _   (GenericSig nm _))     = failWithDs msg
+  where msg = vcat  [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
+                    , ptext (sLit "Default signatures are not supported by Template Haskell") ]
+
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 rep_sig _                             = return []
@@ -631,7 +635,6 @@ repTy (HsKindSig t k)       = do
                                 k1 <- repKind k
                                 repTSig t1 k1
 repTy (HsSpliceTy splice _ _) = repSplice splice
-repTy ty@(HsNumTy _)          = notHandled "Number types (for generics)" (ppr ty)
 repTy ty		      = notHandled "Exotic form of type" (ppr ty)
 
 -- represent a kind
@@ -721,23 +724,19 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 			       ; wrapGenSyms ss z }
 
 -- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt sts body _) 
+repE e@(HsDo ctxt sts _) 
  | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts; 
-	body'	<- addBinds ss $ repLE body;
-	ret	<- repNoBindSt body';	
-        e'      <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+        e'      <- repDoE (nonEmptyCoreList zs);
         wrapGenSyms ss e' }
 
  | ListComp <- ctxt
  = do { (ss,zs) <- repLSts sts; 
-	body'	<- addBinds ss $ repLE body;
-	ret	<- repNoBindSt body';	
-        e'      <- repComp (nonEmptyCoreList (zs ++ [ret]));
+        e'      <- repComp (nonEmptyCoreList zs);
         wrapGenSyms ss e' }
 
   | otherwise
-  = notHandled "mdo and [: :]" (ppr e)
+  = notHandled "mdo, monad comprehension and [: :]" (ppr e)
 
 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
@@ -817,7 +816,7 @@ repGuards other
      wrapGenSyms (concat xs) gd }
   where 
     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+    process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
            = do { x <- repLNormalGE e1 e2;
                   return ([], x) }
     process (L _ (GRHS ss rhs))
@@ -876,7 +875,7 @@ repSts (LetStmt bs : ss) =
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
       ; return (ss1++ss2, z : zs) } 
-repSts (ExprStmt e _ _ : ss) =       
+repSts (ExprStmt e _ _ _ : ss) =       
    do { e2 <- repLE e
       ; z <- repNoBindSt e2 
       ; (ss2,zs) <- repSts ss
@@ -1584,7 +1583,7 @@ repLiteral lit
 mk_integer :: Integer -> DsM HsLit
 mk_integer  i = do integer_ty <- lookupType integerTyConName
                    return $ HsInteger i integer_ty
-mk_rational :: Rational -> DsM HsLit
+mk_rational :: FractionalLit -> DsM HsLit
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
 mk_string :: FastString -> DsM HsLit
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 3a97687..8b5c0a9 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -53,7 +53,6 @@ import CoreUtils
 import MkCore
 import MkId
 import Id
-import Var
 import Name
 import Literal
 import TyCon
@@ -75,7 +74,6 @@ import StaticFlags
 \end{code}
 
 
-
 %************************************************************************
 %*									*
 		Rebindable syntax
@@ -256,10 +254,9 @@ wrapBinds [] e = e
 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body	-- Can deal with term variables *or* type variables
-  | new==old    = body
-  | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
-  | otherwise   = Let (NonRec new (Var old))         body
+wrapBind new old body	-- NB: this function must deal with term
+  | new==old    = body	-- variables, type variables or coercion variables
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
 
 seqVar :: Var -> CoreExpr -> CoreExpr
 seqVar var body = Case (Var var) var (exprType body)
@@ -299,10 +296,11 @@ mkCoPrimCaseMatchResult var ty match_alts
                                                   return (LitAlt lit, [], body)
 
 
-mkCoAlgCaseMatchResult :: Id					-- Scrutinee
-                    -> Type                                     -- Type of exp
-		    -> [(DataCon, [CoreBndr], MatchResult)]	-- Alternatives
-		    -> MatchResult
+mkCoAlgCaseMatchResult 
+  :: Id					   -- Scrutinee
+  -> Type                                  -- Type of exp
+  -> [(DataCon, [CoreBndr], MatchResult)]  -- Alternatives (bndrs *include* tyvars, dicts)
+  -> MatchResult
 mkCoAlgCaseMatchResult var ty match_alts 
   | isNewTyCon tycon		-- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
@@ -605,7 +603,7 @@ mkSelectorBinds pat val_expr
         return (bndr_var, rhs_expr)
       where
         error_expr = mkCoerce co (Var err_var)
-        co         = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
+        co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
 
     is_simple_lpat p = is_simple_pat (unLoc p)
 
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 5c6b224..1a044d3 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -29,6 +29,7 @@ import DataCon
 import MatchCon
 import MatchLit
 import Type
+import Coercion
 import TysWiredIn
 import ListSetOps
 import SrcLoc
@@ -522,7 +523,7 @@ tidy1 _ (LitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 tidy1 _ (NPat lit mb_neg eq)
-  = return (idDsWrapper, tidyNPat lit mb_neg eq)
+  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
 
 -- BangPatterns: Pattern matching is already strict in constructors,
 -- tuples etc, so the last case strips off the bang for thoses patterns.
@@ -825,7 +826,7 @@ sameGroup (PgCon _)  (PgCon _)  = True		-- One case expression
 sameGroup (PgLit _)  (PgLit _)  = True		-- One case expression
 sameGroup (PgN l1)   (PgN l2)   = l1==l2	-- Order is significant
 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2	-- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo	t1)  (PgCo t2)  = t1 `coreEqType` t2
+sameGroup (PgCo	t1)  (PgCo t2)  = t1 `eqType` t2
 	-- CoPats are in the same goup only if the type of the
 	-- enclosed pattern is the same. The patterns outside the CoPat
 	-- always have the same type, so this boils down to saying that
@@ -873,7 +874,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         -- which resolve the overloading (e.g., fromInteger 1),
         -- because these expressions get written as a bunch of different variables
         -- (presumably to improve sharing)
-        tcEqType (overLitType l) (overLitType l') && l == l'
+        eqType (overLitType l) (overLitType l') && l == l'
     exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
@@ -897,7 +898,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
 
     ---------
     tup_arg (Present e1) (Present e2) = lexp e1 e2
-    tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+    tup_arg (Missing t1) (Missing t2) = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -910,9 +911,9 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     --        equating different ways of writing a coercion)
     wrap WpHole WpHole = True
     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpCast c)  (WpCast c')     = tcEqType c c'
+    wrap (WpCast c)  (WpCast c')     = coreEqCoercion c c'
     wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
-    wrap (WpTyApp t) (WpTyApp t')    = tcEqType t t'
+    wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
     -- Enhancement: could implement equality for more wrappers
     --   if it seems useful (lams and lets)
     wrap _ _ = False
@@ -920,7 +921,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     ---------
     ev_term :: EvTerm -> EvTerm -> Bool
     ev_term (EvId a)       (EvId b)       = a==b
-    ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+    ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
     ev_term _ _ = False	
 
     ---------
@@ -959,3 +960,4 @@ If the first arg matches '1' but the second does not match 'True', we
 cannot jump to the third equation!  Because the same argument might
 match '2'!
 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 03fa325..d84b901 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -28,7 +28,6 @@ import DsUtils
 import Util	( all2, takeList, zipEqual )
 import ListSetOps ( runs )
 import Id
-import Var      ( Var )
 import NameEnv
 import SrcLoc
 import Outputable
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 5e5e81d..0bd2538 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -33,6 +33,7 @@ import Literal
 import SrcLoc
 import Data.Ratio
 import Outputable
+import BasicTypes
 import Util
 import FastString
 \end{code}
@@ -64,8 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s))
 dsLit (HsCharPrim   c) = return (Lit (MachChar c))
 dsLit (HsIntPrim    i) = return (Lit (MachInt i))
 dsLit (HsWordPrim   w) = return (Lit (MachWord w))
-dsLit (HsFloatPrim  f) = return (Lit (MachFloat f))
-dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
+dsLit (HsFloatPrim  f) = return (Lit (MachFloat (fl_value f)))
+dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
 
 dsLit (HsChar c)       = return (mkCharExpr c)
 dsLit (HsString str)   = mkStringExprFS str
@@ -73,8 +74,8 @@ dsLit (HsInteger i _)  = mkIntegerExpr i
 dsLit (HsInt i)	       = return (mkIntExpr i)
 
 dsLit (HsRat r ty) = do
-   num   <- mkIntegerExpr (numerator r)
-   denom <- mkIntegerExpr (denominator r)
+   num   <- mkIntegerExpr (numerator (fl_value r))
+   denom <- mkIntegerExpr (denominator (fl_value r))
    return (mkConApp ratio_data_con [Type integer_ty, num, denom])
   where
     (ratio_data_con, integer_ty) 
@@ -112,8 +113,8 @@ hsLitKey (HsIntPrim     i) = mkMachInt  i
 hsLitKey (HsWordPrim    w) = mkMachWord w
 hsLitKey (HsCharPrim    c) = MachChar   c
 hsLitKey (HsStringPrim  s) = MachStr    s
-hsLitKey (HsFloatPrim   f) = MachFloat  f
-hsLitKey (HsDoublePrim  d) = MachDouble d
+hsLitKey (HsFloatPrim   f) = MachFloat  (fl_value f)
+hsLitKey (HsDoublePrim  d) = MachDouble (fl_value d)
 hsLitKey (HsString s)	   = MachStr    s
 hsLitKey l                 = pprPanic "hsLitKey" (ppr l)
 
@@ -124,8 +125,8 @@ hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
 litValKey :: OverLitVal -> Bool -> Literal
 litValKey (HsIntegral i)   False = MachInt i
 litValKey (HsIntegral i)   True  = MachInt (-i)
-litValKey (HsFractional r) False = MachFloat r
-litValKey (HsFractional r) True  = MachFloat (-r)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 \end{code}
 
@@ -152,8 +153,14 @@ tidyLitPat (HsString s)
 tidyLitPat lit = LitPat lit
 
 ----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
-tidyNPat (OverLit val False _ ty) mb_neg _
+tidyNPat :: (HsLit -> Pat Id)	-- How to tidy a LitPat
+	    	 -- We need this argument because tidyNPat is called
+		 -- both by Match and by Check, but they tidy LitPats 
+		 -- slightly differently; and we must desugar 
+		 -- literals consistently (see Trac #5117)
+         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id 
+         -> Pat Id
+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
 	-- False: Take short cuts only if the literal is not using rebindable syntax
 	-- 
 	-- Once that is settled, look for cases where the type of the 
@@ -169,7 +176,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
   | isWordTy ty,   Just int_lit <- mb_int_lit = mk_con_pat wordDataCon   (HsWordPrim   int_lit)
   | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
   | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
-  | isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit)
+  | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
@@ -180,12 +187,12 @@ tidyNPat (OverLit val False _ ty) mb_neg _
 		   (Just _,  HsIntegral i) -> Just (-i)
 		   _ -> Nothing
 	
-    mb_rat_lit :: Maybe Rational
+    mb_rat_lit :: Maybe FractionalLit
     mb_rat_lit = case (mb_neg, val) of
-		   (Nothing, HsIntegral   i) -> Just (fromInteger i)
-		   (Just _,  HsIntegral   i) -> Just (fromInteger (-i))
+		   (Nothing, HsIntegral   i) -> Just (integralFractionalLit (fromInteger i))
+		   (Just _,  HsIntegral   i) -> Just (integralFractionalLit (fromInteger (-i)))
 		   (Nothing, HsFractional f) -> Just f
-		   (Just _, HsFractional f)  -> Just (-f)
+		   (Just _, HsFractional f)  -> Just (negateFractionalLit f)
 		   _ -> Nothing
 	
     mb_str_lit :: Maybe FastString
@@ -193,7 +200,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
 		   (Nothing, HsIsString s) -> Just s
 		   _ -> Nothing
 
-tidyNPat over_lit mb_neg eq 
+tidyNPat _ over_lit mb_neg eq 
   = NPat over_lit mb_neg eq
 \end{code}
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0a56719..8a98775 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -36,11 +36,6 @@ Flag ghci
     Default: False
     Manual: True
 
-Flag ncg
-    Description: Build the NCG.
-    Default: False
-    Manual: True
-
 Flag stage1
     Description: Is this stage 1?
     Default: False
@@ -88,9 +83,6 @@ Library
         CPP-Options: -DGHCI
         Include-Dirs: ../libffi/build/include
 
-    if !flag(ncg)
-        CPP-Options: -DOMIT_NATIVE_CODEGEN
-
     Build-Depends: bin-package-db
     Build-Depends: hoopl
 
@@ -425,6 +417,7 @@ Library
         Generics
         InstEnv
         TyCon
+        Kind
         Type
         TypeRep
         Unify
@@ -451,6 +444,7 @@ Library
         MonadUtils
         OrdList
         Outputable
+        Pair
         Panic
         Pretty
         Serialized
@@ -491,10 +485,7 @@ Library
         Vectorise.Exp
         Vectorise
 
-    -- We only need to expose more modules as some of the ncg code is used
-    -- by the LLVM backend so its always included
-    if flag(ncg)
-        Exposed-Modules:
+    Exposed-Modules:
             AsmCodeGen
             TargetReg
             NCGMonad
@@ -504,10 +495,6 @@ Library
             RegClass
             PIC
             Platform
-            Alpha.Regs
-            Alpha.RegInfo
-            Alpha.Instr
-            Alpha.CodeGen
             X86.Regs
             X86.RegInfo
             X86.Instr
@@ -566,7 +553,6 @@ Library
             TcSplice
             Convert
             ByteCodeAsm
-            ByteCodeFFI
             ByteCodeGen
             ByteCodeInstr
             ByteCodeItbls
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 76b393f..8ed34c3 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -49,8 +49,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo '{-# LANGUAGE CPP #-}'                                        >> $@
 	@echo 'module Config where'                                         >> $@
 	@echo                                                               >> $@
-	@echo 'import Distribution.System'                                  >> $@
-	@echo                                                               >> $@
 	@echo '#include "ghc_boot_platform.h"'                              >> $@
 	@echo                                                               >> $@
 	@echo 'cBuildPlatformString :: String'                              >> $@
@@ -60,42 +58,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo 'cTargetPlatformString :: String'                             >> $@
 	@echo 'cTargetPlatformString = TargetPlatform_NAME'                 >> $@
 	@echo                                                               >> $@
-# Sync this with checkArch in configure.ac
-	@echo 'cTargetArch :: Arch'                                         >> $@
-	@echo '#if i386_TARGET_ARCH'                                        >> $@
-	@echo 'cTargetArch = I386'                                          >> $@
-	@echo '#elif x86_64_TARGET_ARCH'                                    >> $@
-	@echo 'cTargetArch = X86_64'                                        >> $@
-	@echo '#elif powerpc_TARGET_ARCH'                                   >> $@
-	@echo 'cTargetArch = PPC'                                           >> $@
-	@echo '#elif powerpc64_TARGET_ARCH'                                 >> $@
-	@echo 'cTargetArch = PPC64'                                         >> $@
-	@echo '#elif sparc_TARGET_ARCH || sparc64_TARGET_ARCH'              >> $@
-	@echo 'cTargetArch = Sparc'                                         >> $@
-	@echo '#elif arm_TARGET_ARCH'                                       >> $@
-	@echo 'cTargetArch = Arm'                                           >> $@
-	@echo '#elif mips_TARGET_ARCH || mipseb_TARGET_ARCH || mipsel_TARGET_ARCH' >> $@
-	@echo 'cTargetArch = Mips'                                          >> $@
-	@echo '#elif 0'                                                     >> $@
-	@echo 'cTargetArch = SH'                                            >> $@
-	@echo '#elif ia64_TARGET_ARCH'                                      >> $@
-	@echo 'cTargetArch = IA64'                                          >> $@
-	@echo '#elif s390_TARGET_ARCH'                                      >> $@
-	@echo 'cTargetArch = S390'                                          >> $@
-	@echo '#elif alpha_TARGET_ARCH'                                     >> $@
-	@echo 'cTargetArch = Alpha'                                         >> $@
-	@echo '#elif hppa_TARGET_ARCH || hppa1_1_TARGET_ARCH'               >> $@
-	@echo 'cTargetArch = Hppa'                                          >> $@
-	@echo '#elif rs6000_TARGET_ARCH'                                    >> $@
-	@echo 'cTargetArch = Rs6000'                                        >> $@
-	@echo '#elif m68k_TARGET_ARCH'                                      >> $@
-	@echo 'cTargetArch = M68k'                                          >> $@
-	@echo '#elif vax_TARGET_ARCH'                                       >> $@
-	@echo 'cTargetArch = Vax'                                           >> $@
-	@echo '#else'                                                       >> $@
-	@echo '#error Unknown target arch'                                  >> $@
-	@echo '#endif'                                                      >> $@
-	@echo                                                               >> $@
 	@echo 'cProjectName          :: String'                             >> $@
 	@echo 'cProjectName          = "$(ProjectName)"'                    >> $@
 	@echo 'cProjectVersion       :: String'                             >> $@
@@ -108,8 +70,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo 'cBooterVersion        = "$(GhcVersion)"'                     >> $@
 	@echo 'cStage                :: String'                             >> $@
 	@echo 'cStage                = show (STAGE :: Int)'                 >> $@
-	@echo 'cCcOpts               :: [String]'                           >> $@
-	@echo 'cCcOpts               = words "$(CONF_CC_OPTS_STAGE$*)"'     >> $@
 	@echo 'cGccLinkerOpts        :: [String]'                           >> $@
 	@echo 'cGccLinkerOpts        = words "$(CONF_GCC_LINKER_OPTS_STAGE$*)"' >> $@
 	@echo 'cLdLinkerOpts         :: [String]'                           >> $@
@@ -292,7 +252,7 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl        \
               compiler/primop-has-side-effects.hs-incl \
               compiler/primop-out-of-line.hs-incl      \
               compiler/primop-commutable.hs-incl       \
-              compiler/primop-needs-wrapper.hs-incl    \
+              compiler/primop-code-size.hs-incl        \
               compiler/primop-can-fail.hs-incl         \
               compiler/primop-strictness.hs-incl       \
               compiler/primop-primop-info.hs-incl
@@ -318,8 +278,8 @@ compiler/primop-out-of-line.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
 	"$(GENPRIMOP_INPLACE)" --out-of-line        < $< > $@
 compiler/primop-commutable.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
 	"$(GENPRIMOP_INPLACE)" --commutable         < $< > $@
-compiler/primop-needs-wrapper.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
-	"$(GENPRIMOP_INPLACE)" --needs-wrapper      < $< > $@
+compiler/primop-code-size.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
+	"$(GENPRIMOP_INPLACE)" --code-size          < $< > $@
 compiler/primop-can-fail.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
 	"$(GENPRIMOP_INPLACE)" --can-fail           < $< > $@
 compiler/primop-strictness.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
@@ -373,12 +333,6 @@ endif
 
 endif
 
-ifeq "$(GhcWithNativeCodeGen)" "NO"
-# XXX This should logically be a CPP option, but there doesn't seem to
-# be a flag for that
-compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN
-endif
-
 ifeq "$(TargetOS_CPP)" "openbsd"
 compiler_CONFIGURE_OPTS += --ld-options=-E
 endif
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index dfc77e5..af9fbe9 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -30,7 +30,9 @@ import PrimOp
 import Constants
 import FastString
 import SMRep
+import DynFlags
 import Outputable
+import Platform
 
 import Control.Monad    ( foldM )
 import Control.Monad.ST ( runST )
@@ -113,14 +115,14 @@ instance Outputable UnlinkedBCO where
 -- bytecode address in this BCO.
 
 -- Top level assembler fn.
-assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs proto_bcos tycons
+assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs dflags proto_bcos tycons
   = do  itblenv <- mkITbls tycons
-        bcos    <- mapM assembleBCO proto_bcos
+        bcos    <- mapM (assembleBCO dflags) proto_bcos
         return (ByteCode bcos itblenv)
 
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
    = let
          -- pass 1: collect up the offsets of the local labels.
          -- Remember that the first insn starts at offset
@@ -152,7 +154,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
          ptrs  <- return emptySS :: IO (SizedSeq BCOPtr)
          let init_asm_state = (insns,lits,ptrs)
          (final_insns, final_lits, final_ptrs)
-            <- mkBits findLabel init_asm_state instrs
+            <- mkBits dflags findLabel init_asm_state instrs
 
          let asm_insns = ssElts final_insns
              n_insns   = sizeSS final_insns
@@ -228,12 +230,13 @@ largeArg w
  | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
 
 -- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word)              -- label finder
+mkBits :: DynFlags
+       -> (Word16 -> Word)              -- label finder
        -> AsmState
        -> [BCInstr]                     -- instructions (in)
        -> IO AsmState
 
-mkBits findLabel st proto_insns
+mkBits dflags findLabel st proto_insns
   = foldM doInstr st proto_insns
     where
        doInstr :: AsmState -> BCInstr -> IO AsmState
@@ -247,14 +250,14 @@ mkBits findLabel st proto_insns
                                         instr2 st2 bci_PUSH_G p
                PUSH_PRIMOP op     -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
                                         instr2 st2 bci_PUSH_G p
-               PUSH_BCO proto     -> do ul_bco <- assembleBCO proto
+               PUSH_BCO proto     -> do ul_bco <- assembleBCO dflags proto
                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                         instr2 st2 bci_PUSH_G p
-               PUSH_ALTS proto    -> do ul_bco <- assembleBCO proto
+               PUSH_ALTS proto    -> do ul_bco <- assembleBCO dflags proto
                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                         instr2 st2 bci_PUSH_ALTS p
                PUSH_ALTS_UNLIFTED proto pk -> do
-                                        ul_bco <- assembleBCO proto
+                                        ul_bco <- assembleBCO dflags proto
                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                         instr2 st2 (push_alts pk) p
                PUSH_UBX  (Left lit) nws
@@ -395,12 +398,11 @@ mkBits findLabel st proto_insns
           = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
-#ifdef mingw32_TARGET_OS
        literal st (MachLabel fs (Just sz) _)
+        | platformOS (targetPlatform dflags) == OSMinGW32
             = litlabel st (appendFS fs (mkFastString ('@':show sz)))
         -- On Windows, stdcall labels have a suffix indicating the no. of
         -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
-#endif
        literal st (MachLabel fs _ _) = litlabel st fs
        literal st (MachWord w)     = int st (fromIntegral w)
        literal st (MachInt j)      = int st (fromIntegral j)
diff --git a/compiler/ghci/ByteCodeFFI.lhs b/compiler/ghci/ByteCodeFFI.lhs
deleted file mode 100644
index 1589fe1..0000000
--- a/compiler/ghci/ByteCodeFFI.lhs
+++ /dev/null
@@ -1,28 +0,0 @@
-%
-% (c) The University of Glasgow 2001-2008
-%
-
-ByteCodeGen: Generate machine-code sequences for foreign import
-
-\begin{code}
-module ByteCodeFFI ( moan64 ) where
-
-import Outputable
-import System.IO
-import System.IO.Unsafe
-
-moan64 :: String -> SDoc -> a
-moan64 msg pp_rep
-   = unsafePerformIO (
-        hPutStrLn stderr (
-        "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++
-        "code properly yet.  You can work around this for the time being\n" ++
-        "by compiling this module and all those it imports to object code,\n" ++
-        "and re-starting your GHCi session.  The panic below contains information,\n" ++
-        "intended for the GHC implementors, about the exact place where GHC gave up.\n"
-        )
-     )
-     `seq`
-     pprPanic msg pp_rep
-\end{code}
-
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index f34ac9c..426f4f2 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -30,10 +30,7 @@ import CoreFVs
 import Type
 import DataCon
 import TyCon
--- import Type
 import Util
--- import DataCon
-import Var
 import VarSet
 import TysPrim
 import DynFlags
@@ -50,38 +47,36 @@ import Data.List
 import Foreign
 import Foreign.C
 
--- import GHC.Exts		( Int(..) )
-
-import Control.Monad	( when )
+import Control.Monad
 import Data.Char
 
 import UniqSupply
 import BreakArray
 import Data.Maybe
-import Module 
-import IdInfo 
+import Module
+import IdInfo
 
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
 
 -- -----------------------------------------------------------------------------
--- Generating byte code for a complete module 
+-- Generating byte code for a complete module
 
 byteCodeGen :: DynFlags
             -> [CoreBind]
-	    -> [TyCon]
-            -> ModBreaks 
+            -> [TyCon]
+            -> ModBreaks
             -> IO CompiledByteCode
-byteCodeGen dflags binds tycs modBreaks 
+byteCodeGen dflags binds tycs modBreaks
    = do showPass dflags "ByteCodeGen"
 
-        let flatBinds = [ (bndr, freeVars rhs) 
-			| (bndr, rhs) <- flattenBinds binds]
+        let flatBinds = [ (bndr, freeVars rhs)
+                        | (bndr, rhs) <- flattenBinds binds]
 
-        us <- mkSplitUniqSupply 'y'  
-        (BcM_State _us _final_ctr mallocd _, proto_bcos) 
-           <- runBc us modBreaks (mapM schemeTopBind flatBinds)  
+        us <- mkSplitUniqSupply 'y'
+        (BcM_State _us _final_ctr mallocd _, proto_bcos)
+           <- runBc us modBreaks (mapM schemeTopBind flatBinds)
 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -89,15 +84,15 @@ byteCodeGen dflags binds tycs modBreaks
         dumpIfSet_dyn dflags Opt_D_dump_BCOs
            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
-        assembleBCOs proto_bcos tycs
-        
+        assembleBCOs dflags proto_bcos tycs
+
 -- -----------------------------------------------------------------------------
 -- Generating byte code for an expression
 
--- Returns: (the root BCO for this expression, 
+-- Returns: (the root BCO for this expression,
 --           a list of auxilary BCOs resulting from compiling closures)
 coreExprToBCOs :: DynFlags
-	       -> CoreExpr
+               -> CoreExpr
                -> IO UnlinkedBCO
 coreExprToBCOs dflags expr
  = do showPass dflags "ByteCodeGen"
@@ -106,11 +101,11 @@ coreExprToBCOs dflags expr
       -- should be harmless, since it's never used for anything
       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
           invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
-	  
+
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _us _final_ctr mallocd _ , proto_bco)  
+      (BcM_State _us _final_ctr mallocd _ , proto_bco)
          <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
 
       when (notNull mallocd)
@@ -118,7 +113,7 @@ coreExprToBCOs dflags expr
 
       dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
 
-      assembleBCO proto_bco
+      assembleBCO dflags proto_bco
 
 
 -- -----------------------------------------------------------------------------
@@ -152,18 +147,18 @@ mkProtoBCO
    -> Int
    -> Word16
    -> [StgWord]
-   -> Bool   	-- True <=> is a return point, rather than a function
+   -> Bool      -- True <=> is a return point, rather than a function
    -> [BcPtr]
    -> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks 
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
    = ProtoBCO {
-	protoBCOName = nm,
-	protoBCOInstrs = maybe_with_stack_check,
-	protoBCOBitmap = bitmap,
-	protoBCOBitmapSize = bitmap_size,
-	protoBCOArity = arity,
-	protoBCOExpr = origin,
-	protoBCOPtrs = mallocd_blocks
+        protoBCOName = nm,
+        protoBCOInstrs = maybe_with_stack_check,
+        protoBCOBitmap = bitmap,
+        protoBCOBitmapSize = bitmap_size,
+        protoBCOArity = arity,
+        protoBCOExpr = origin,
+        protoBCOPtrs = mallocd_blocks
       }
      where
         -- Overestimate the stack usage (in words) of this BCO,
@@ -174,17 +169,17 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check
-	   | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
-		-- don't do stack checks at return points,
-		-- everything is aggregated up to the top BCO
-		-- (which must be a function).
+           | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+                -- don't do stack checks at return points,
+                -- everything is aggregated up to the top BCO
+                -- (which must be a function).
                 -- That is, unless the stack usage is >= AP_STACK_SPLIM,
                 -- see bug #1466.
            | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
            = STKCHECK stack_usage : peep_d
            | otherwise
-           = peep_d	-- the supposedly common case
-             
+           = peep_d     -- the supposedly common case
+
         -- We assume that this sum doesn't wrap
         stack_usage = sum (map bciStackUse peep_d)
 
@@ -214,19 +209,19 @@ argBits (rep : args)
 schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
 
 
-schemeTopBind (id, rhs) 
+schemeTopBind (id, rhs)
   | Just data_con <- isDataConWorkId_maybe id,
     isNullaryRepDataCon data_con = do
-    	-- Special case for the worker of a nullary data con.
-	-- It'll look like this:	Nil = /\a -> Nil a
-	-- If we feed it into schemeR, we'll get 
-	--	Nil = Nil
-	-- because mkConAppCode treats nullary constructor applications
-	-- by just re-using the single top-level definition.  So
-	-- for the worker itself, we must allocate it directly.
+        -- Special case for the worker of a nullary data con.
+        -- It'll look like this:        Nil = /\a -> Nil a
+        -- If we feed it into schemeR, we'll get
+        --      Nil = Nil
+        -- because mkConAppCode treats nullary constructor applications
+        -- by just re-using the single top-level definition.  So
+        -- for the worker itself, we must allocate it directly.
     -- ioToBc (putStrLn $ "top level BCO")
     emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
-                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) 
+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
 
   | otherwise
   = schemeR [{- No free variables -}] (id, rhs)
@@ -242,18 +237,18 @@ schemeTopBind (id, rhs)
 --
 -- Park the resulting BCO in the monad.  Also requires the
 -- variable to which this value was bound, so as to give the
--- resulting BCO a name. 
+-- resulting BCO a name.
 
-schemeR :: [Id] 		-- Free vars of the RHS, ordered as they
-				-- will appear in the thunk.  Empty for
-				-- top-level things, which have no free vars.
-	-> (Id, AnnExpr Id VarSet)
-	-> BcM (ProtoBCO Name)
+schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
+                                -- will appear in the thunk.  Empty for
+                                -- top-level things, which have no free vars.
+        -> (Id, AnnExpr Id VarSet)
+        -> BcM (ProtoBCO Name)
 schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -269,40 +264,40 @@ collect (_, e) = go [] e
     go xs (AnnLam x (_,e))        = go (x:xs) e
     go xs not_lambda              = (reverse xs, not_lambda)
 
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) 
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
-   = let 
-	 all_args  = reverse args ++ fvs
-	 arity     = length all_args
-	 -- all_args are the args in reverse order.  We're compiling a function
-	 -- \fv1..fvn x1..xn -> e 
-	 -- i.e. the fvs come first
+   = let
+         all_args  = reverse args ++ fvs
+         arity     = length all_args
+         -- all_args are the args in reverse order.  We're compiling a function
+         -- \fv1..fvn x1..xn -> e
+         -- i.e. the fvs come first
 
          szsw_args = map (fromIntegral . idSizeW) all_args
          szw_args  = sum szsw_args
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
 
-	 -- make the arg bitmap
-	 bits = argBits (reverse (map idCgRep all_args))
-	 bitmap_size = genericLength bits
-	 bitmap = mkBitmap bits
+         -- make the arg bitmap
+         bits = argBits (reverse (map idCgRep all_args))
+         bitmap_size = genericLength bits
+         bitmap = mkBitmap bits
      in do
-     body_code <- schemeER_wrk szw_args p_init body   
- 
+     body_code <- schemeER_wrk szw_args p_init body
+
      emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
-		arity bitmap_size bitmap False{-not alts-})
+                 arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
 schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
-   | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do 
-        code <- schemeE d 0 p newRhs 
-        arr <- getBreakArray 
+   | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+        code <- schemeE d 0 p newRhs
+        arr <- getBreakArray
         let idOffSets = getVarOffSets d p tickInfo
         let tickNumber = tickInfo_number tickInfo
-        let breakInfo = BreakInfo 
+        let breakInfo = BreakInfo
                         { breakInfo_module = tickInfo_module tickInfo
-                        , breakInfo_number = tickNumber 
+                        , breakInfo_number = tickNumber
                         , breakInfo_vars = idOffSets
                         , breakInfo_resty = exprType (deAnnotate' newRhs)
                         }
@@ -310,15 +305,15 @@ schemeER_wrk d p rhs
                          BA arr# ->
                              BRK_FUN arr# (fromIntegral tickNumber) breakInfo
         return $ breakInstr `consOL` code
-   | otherwise = schemeE d 0 p rhs 
+   | otherwise = schemeE d 0 p rhs
 
 getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals 
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
 
 getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
-getOffSet d env id 
+getOffSet d env id
    = case lookupBCEnv_maybe id env of
-        Nothing     -> Nothing 
+        Nothing     -> Nothing
         Just offset -> Just (id, d - offset)
 
 fvsToEnv :: BCEnv -> VarSet -> [Id]
@@ -330,22 +325,22 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
 --
 -- The code that constructs the thunk, and the code that executes
 -- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs, 
-		      isId v,		-- Could be a type variable
-		      v `Map.member` p]
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+                      isId v,           -- Could be a type variable
+                      v `Map.member` p]
 
 -- -----------------------------------------------------------------------------
 -- schemeE
 
-data TickInfo 
-   = TickInfo   
+data TickInfo
+   = TickInfo
      { tickInfo_number :: Int     -- the (module) unique number of the tick
-     , tickInfo_module :: Module  -- the origin of the ticked expression 
+     , tickInfo_module :: Module  -- the origin of the ticked expression
      , tickInfo_locals :: [Id]    -- the local vars in scope at the ticked expression
-     } 
+     }
 
 instance Outputable TickInfo where
-   ppr info = text "TickInfo" <+> 
+   ppr info = text "TickInfo" <+>
               parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
                       ppr (tickInfo_locals info))
 
@@ -358,7 +353,7 @@ schemeE d s p e
    = schemeE d s p e'
 
 -- Delegate tail-calls to schemeT.
-schemeE d s p e@(AnnApp _ _) 
+schemeE d s p e@(AnnApp _ _)
    = schemeT d s p e
 
 schemeE d s p e@(AnnVar v)
@@ -367,12 +362,12 @@ schemeE d s p e@(AnnVar v)
      schemeT d s p e
 
    | otherwise
-   = do -- Returning an unlifted value.  
+   = do -- Returning an unlifted value.
         -- Heave it on the stack, SLIDE, and RETURN.
         (push, szw) <- pushAtom d p (AnnVar v)
-        return (push 			-- value onto stack
-                  `appOL`  mkSLIDE szw (d-s) -- clear to sequel
-                  `snocOL` RETURN_UBX v_rep)	-- go
+        return (push                       -- value onto stack
+                `appOL`  mkSLIDE szw (d-s) -- clear to sequel
+                `snocOL` RETURN_UBX v_rep) -- go
    where
       v_type = idType v
       v_rep = typeCgRep v_type
@@ -380,17 +375,17 @@ schemeE d s p e@(AnnVar v)
 schemeE d s p (AnnLit literal)
    = do (push, szw) <- pushAtom d p (AnnLit literal)
         let l_rep = typeCgRep (literalType literal)
-        return (push 			-- value onto stack
-               `appOL`  mkSLIDE szw (d-s) 	-- clear to sequel
-               `snocOL` RETURN_UBX l_rep)	-- go
+        return (push                       -- value onto stack
+                `appOL`  mkSLIDE szw (d-s) -- clear to sequel
+                `snocOL` RETURN_UBX l_rep) -- go
 
 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
    | (AnnVar v, args_r_to_l) <- splitApp rhs,
      Just data_con <- isDataConWorkId_maybe v,
      dataConRepArity data_con == length args_r_to_l
-   = do	-- Special case for a non-recursive let whose RHS is a 
-	-- saturatred constructor application.
-	-- Just allocate the constructor and carry on
+   = do -- Special case for a non-recursive let whose RHS is a
+        -- saturatred constructor application.
+        -- Just allocate the constructor and carry on
         alloc_code <- mkConAppCode d s p data_con args_r_to_l
         body_code <- schemeE (d+1) s (Map.insert x d p) body
         return (alloc_code `appOL` body_code)
@@ -407,8 +402,8 @@ schemeE d s p (AnnLet binds (_,body))
          -- Sizes of free vars
          sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
 
-	 -- the arity of each rhs
-	 arities = map (genericLength . fst . collect) rhss
+         -- the arity of each rhs
+         arities = map (genericLength . fst . collect) rhss
 
          -- This p', d' defn is safe because all the items being pushed
          -- are ptrs, so all have size 1.  d' and p' reflect the stack
@@ -421,33 +416,33 @@ schemeE d s p (AnnLet binds (_,body))
          -- ToDo: don't build thunks for things with no free variables
          build_thunk _ [] size bco off arity
             = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
-	   where 
-		mkap | arity == 0 = MKAP
-		     | otherwise  = MKPAP
+           where
+                mkap | arity == 0 = MKAP
+                     | otherwise  = MKPAP
          build_thunk dd (fv:fvs) size bco off arity = do
-              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) 
+              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
               more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
               return (push_code `appOL` more_push_code)
 
          alloc_code = toOL (zipWith mkAlloc sizes arities)
-	   where mkAlloc sz 0
+           where mkAlloc sz 0
                     | is_tick     = ALLOC_AP_NOUPD sz
                     | otherwise   = ALLOC_AP sz
-		 mkAlloc sz arity = ALLOC_PAP arity sz
+                 mkAlloc sz arity = ALLOC_PAP arity sz
 
-         is_tick = case binds of 
+         is_tick = case binds of
                      AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
                      _other -> False
 
-	 compile_bind d' fvs x rhs size arity off = do
-		bco <- schemeR fvs (x,rhs)
-		build_thunk d' fvs size bco off arity
+         compile_bind d' fvs x rhs size arity off = do
+                bco <- schemeR fvs (x,rhs)
+                build_thunk d' fvs size bco off arity
 
-	 compile_binds = 
-	    [ compile_bind d' fvs x rhs size arity n
-	    | (fvs, x, rhs, size, arity, n) <- 
-		zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
-	    ]
+         compile_binds =
+            [ compile_bind d' fvs x rhs size arity n
+            | (fvs, x, rhs, size, arity, n) <-
+                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+            ]
      in do
      body_code <- schemeE d' s p' body
      thunk_codes <- sequence compile_binds
@@ -464,7 +459,7 @@ schemeE d s p exp@(AnnCase {})
    = if isUnLiftedType ty
         then do
           -- If the result type is unlifted, then we must generate
-          --   let f = \s . case tick# of _ -> e 
+          --   let f = \s . case tick# of _ -> e
           --   in  f realWorld#
           -- When we stop at the breakpoint, _result will have an unlifted
           -- type and hence won't be bound in the environment, but the
@@ -472,7 +467,7 @@ schemeE d s p exp@(AnnCase {})
           id <- newId (mkFunTy realWorldStatePrimTy ty)
           st <- newId realWorldStatePrimTy
           let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
-                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) 
+                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
                                                     (emptyVarSet, AnnVar realWorldPrimId)))
           schemeE d s p letExp
         else do
@@ -486,42 +481,42 @@ schemeE d s p exp@(AnnCase {})
 
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-	-- Convert 
-	--	case .... of x { (# VoidArg'd-thing, a #) -> ... }
-	-- to
-	-- 	case .... of a { DEFAULT -> ... }
-	-- becuse the return convention for both are identical.
-	--
-	-- Note that it does not matter losing the void-rep thing from the
-	-- envt (it won't be bound now) because we never look such things up.
+        -- Convert
+        --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
+        -- to
+        --      case .... of a { DEFAULT -> ... }
+        -- becuse the return convention for both are identical.
+        --
+        -- Note that it does not matter losing the void-rep thing from the
+        -- envt (it won't be bound now) because we never look such things up.
 
    = --trace "automagic mashing of case alts (# VoidArg, a #)" $
-     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
+     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
+     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
-	-- Similarly, convert
-	--	case .... of x { (# a #) -> ... }
-	-- to
-	--	case .... of a { DEFAULT -> ... }
+        -- Similarly, convert
+        --      case .... of x { (# a #) -> ... }
+        -- to
+        --      case .... of a { DEFAULT -> ... }
    = --trace "automagic mashing of case alts (# a #)"  $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} 
+     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
 schemeE d s p (AnnCase scrut bndr _ alts)
-   = doCase d s p scrut bndr alts False{-not an unboxed tuple-} 
+   = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
 
 schemeE _ _ _ expr
-   = pprPanic "ByteCodeGen.schemeE: unhandled case" 
+   = pprPanic "ByteCodeGen.schemeE: unhandled case"
                (pprCoreExpr (deAnnotate' expr))
 
-{- 
+{-
    Ticked Expressions
    ------------------
-  
+
    A ticked expression looks like this:
 
       case tick<n> var1 ... varN of DEFAULT -> e
@@ -535,7 +530,7 @@ schemeE _ _ _ expr
 
   otherwise we return Nothing.
 
-  The idea is that the "case tick<n> ..." is really just an annotation on 
+  The idea is that the "case tick<n> ..." is really just an annotation on
   the code. When we find such a thing, we pull out the useful information,
   and then compile the code as if it was just the expression "e".
 
@@ -544,10 +539,10 @@ schemeE _ _ _ expr
 isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
 isTickedExp' (AnnCase scrut _bndr _type alts)
    | Just tickInfo <- isTickedScrut scrut,
-     [(DEFAULT, _bndr, rhs)] <- alts 
+     [(DEFAULT, _bndr, rhs)] <- alts
      = Just (tickInfo, rhs)
    where
-   isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo 
+   isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
    isTickedScrut expr
       | Var id <- f,
         Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
@@ -559,7 +554,7 @@ isTickedExp' (AnnCase scrut _bndr _type alts)
       where
       (f, args) = collectArgs $ deAnnotate expr
       idsOfArgs :: [Expr Id] -> [Id]
-      idsOfArgs = catMaybes . map exprId 
+      idsOfArgs = catMaybes . map exprId
       exprId :: Expr Id -> Maybe Id
       exprId (Var id) = Just id
       exprId _        = Nothing
@@ -583,16 +578,16 @@ isTickedExp' _ = Nothing
 --     (# b #) and treat it as  b.
 --
 -- 3.  Application of a constructor, by defn saturated.
---     Split the args into ptrs and non-ptrs, and push the nonptrs, 
+--     Split the args into ptrs and non-ptrs, and push the nonptrs,
 --     then the ptrs, and then do PACK and RETURN.
 --
 -- 4.  Otherwise, it must be a function call.  Push the args
 --     right to left, SLIDE and ENTER.
 
 schemeT :: Word16       -- Stack depth
-        -> Sequel 	-- Sequel depth
-        -> BCEnv 	-- stack env
-        -> AnnExpr' Id VarSet 
+        -> Sequel       -- Sequel depth
+        -> BCEnv        -- stack env
+        -> AnnExpr' Id VarSet
         -> BcM BCInstrList
 
 schemeT d s p app
@@ -601,13 +596,13 @@ schemeT d s p app
 --   = panic "schemeT ?!?!"
 
 --   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
---   = error "?!?!" 
+--   = error "?!?!"
 
    -- Case 0
    | Just (arg, constr_names) <- maybe_is_tagToEnum_call
    = do (push, arg_words) <- pushAtom d p arg
         tagToId_sequence <- implement_tagToId constr_names
-        return (push `appOL`  tagToId_sequence            
+        return (push `appOL`  tagToId_sequence
                        `appOL`  mkSLIDE 1 (d+arg_words-s)
                        `snocOL` ENTER)
 
@@ -619,20 +614,20 @@ schemeT d s p app
    | Just con <- maybe_saturated_dcon,
      isUnboxedTupleCon con
    = case args_r_to_l of
-	[arg1,arg2] | isVoidArgAtom arg1 -> 
-		  unboxedTupleReturn d s p arg2
-	[arg1,arg2] | isVoidArgAtom arg2 -> 
-		  unboxedTupleReturn d s p arg1
-	_other -> unboxedTupleException
+        [arg1,arg2] | isVoidArgAtom arg1 ->
+                  unboxedTupleReturn d s p arg2
+        [arg1,arg2] | isVoidArgAtom arg2 ->
+                  unboxedTupleReturn d s p arg1
+        _other -> unboxedTupleException
 
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
    = do alloc_con <- mkConAppCode d s p con args_r_to_l
-        return (alloc_con	 `appOL` 
-                  mkSLIDE 1 (d - s) `snocOL`
-                  ENTER)
+        return (alloc_con         `appOL`
+                mkSLIDE 1 (d - s) `snocOL`
+                ENTER)
 
-   -- Case 4: Tail call of function 
+   -- Case 4: Tail call of function
    | otherwise
    = doTailCall d s p fn args_r_to_l
 
@@ -641,54 +636,54 @@ schemeT d s p app
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
                  | Just (tyc, _) <- splitTyConApp_maybe (repType ty),
-		   isDataTyCon tyc
-		   = map (getName . dataConWorkId) (tyConDataCons tyc)
-		   -- NOTE: use the worker name, not the source name of
-		   -- the DataCon.  See DataCon.lhs for details.
-		 | otherwise
+                   isDataTyCon tyc
+                   = map (getName . dataConWorkId) (tyConDataCons tyc)
+                   -- NOTE: use the worker name, not the source name of
+                   -- the DataCon.  See DataCon.lhs for details.
+                 | otherwise
                    = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
            in
            case app of
               (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
                  -> case isPrimOpId_maybe v of
                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
-		       _		-> Nothing
+                       _                -> Nothing
               _ -> Nothing
 
-	-- Extract the args (R->L) and fn
-	-- The function will necessarily be a variable, 
-	-- because we are compiling a tail call
+        -- Extract the args (R->L) and fn
+        -- The function will necessarily be a variable,
+        -- because we are compiling a tail call
       (AnnVar fn, args_r_to_l) = splitApp app
 
       -- Only consider this to be a constructor application iff it is
       -- saturated.  Otherwise, we'll call the constructor wrapper.
       n_args = length args_r_to_l
-      maybe_saturated_dcon  
-	= case isDataConWorkId_maybe fn of
-		Just con | dataConRepArity con == n_args -> Just con
-		_ -> Nothing
+      maybe_saturated_dcon
+        = case isDataConWorkId_maybe fn of
+                Just con | dataConRepArity con == n_args -> Just con
+                _ -> Nothing
 
 -- -----------------------------------------------------------------------------
--- Generate code to build a constructor application, 
+-- Generate code to build a constructor application,
 -- leaving it on top of the stack
 
 mkConAppCode :: Word16 -> Sequel -> BCEnv
-	     -> DataCon 		-- The data constructor
-	     -> [AnnExpr' Id VarSet] 	-- Args, in *reverse* order
-	     -> BcM BCInstrList
+             -> DataCon                 -- The data constructor
+             -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
+             -> BcM BCInstrList
 
-mkConAppCode _ _ _ con []	-- Nullary constructor
+mkConAppCode _ _ _ con []       -- Nullary constructor
   = ASSERT( isNullaryRepDataCon con )
     return (unitOL (PUSH_G (getName (dataConWorkId con))))
-	-- Instead of doing a PACK, which would allocate a fresh
-	-- copy of this constructor, use the single shared version.
+        -- Instead of doing a PACK, which would allocate a fresh
+        -- copy of this constructor, use the single shared version.
 
-mkConAppCode orig_d _ p con args_r_to_l 
+mkConAppCode orig_d _ p con args_r_to_l
   = ASSERT( dataConRepArity con == length args_r_to_l )
     do_pushery orig_d (non_ptr_args ++ ptr_args)
  where
-	-- The args are already in reverse order, which is the way PACK
-	-- expects them to be.  We must push the non-ptrs after the ptrs.
+        -- The args are already in reverse order, which is the way PACK
+        -- expects them to be.  We must push the non-ptrs after the ptrs.
       (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
 
       do_pushery d (arg:args)
@@ -697,8 +692,8 @@ mkConAppCode orig_d _ p con args_r_to_l
               return (push `appOL` more_push_code)
       do_pushery d []
          = return (unitOL (PACK con n_arg_words))
-	 where
-	   n_arg_words = d - orig_d
+         where
+           n_arg_words = d - orig_d
 
 
 -- -----------------------------------------------------------------------------
@@ -709,42 +704,42 @@ mkConAppCode orig_d _ p con args_r_to_l
 -- returned, even if it is a pointed type.  We always just return.
 
 unboxedTupleReturn
-	:: Word16 -> Sequel -> BCEnv
-	-> AnnExpr' Id VarSet -> BcM BCInstrList
+        :: Word16 -> Sequel -> BCEnv
+        -> AnnExpr' Id VarSet -> BcM BCInstrList
 unboxedTupleReturn d s p arg = do
   (push, sz) <- pushAtom d p arg
-  return (push `appOL`
-	    mkSLIDE sz (d-s) `snocOL`
-	    RETURN_UBX (atomRep arg))
+  return (push                      `appOL`
+          mkSLIDE sz (d-s)          `snocOL`
+          RETURN_UBX (atomRep arg))
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
 
 doTailCall
-	:: Word16 -> Sequel -> BCEnv
-	-> Id -> [AnnExpr' Id VarSet]
-	-> BcM BCInstrList
+        :: Word16 -> Sequel -> BCEnv
+        -> Id -> [AnnExpr' Id VarSet]
+        -> BcM BCInstrList
 doTailCall init_d s p fn args
   = do_pushes init_d args (map atomRep args)
   where
   do_pushes d [] reps = do
-	ASSERT( null reps ) return ()
+        ASSERT( null reps ) return ()
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
-	ASSERT( sz == 1 ) return ()
-	return (push_fn `appOL` (
-		  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
-		  unitOL ENTER))
+        ASSERT( sz == 1 ) return ()
+        return (push_fn `appOL` (
+                  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+                  unitOL ENTER))
   do_pushes d args reps = do
       let (push_apply, n, rest_of_reps) = findPushSeq reps
-	  (these_args, rest_of_args) = splitAt n args
+          (these_args, rest_of_args) = splitAt n args
       (next_d, push_code) <- push_seq d these_args
-      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps 
-		--                ^^^ for the PUSH_APPLY_ instruction
+      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+      --                          ^^^ for the PUSH_APPLY_ instruction
       return (push_code `appOL` (push_apply `consOL` instrs))
 
   push_seq d [] = return (d, nilOL)
   push_seq d (arg:args) = do
-    (push_code, sz) <- pushAtom d p arg 
+    (push_code, sz) <- pushAtom d p arg
     (final_d, more_push_code) <- push_seq (d+sz) args
     return (final_d, push_code `appOL` more_push_code)
 
@@ -779,10 +774,10 @@ findPushSeq _
 -- Case expressions
 
 doCase  :: Word16 -> Sequel -> BCEnv
-	-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-	-> Bool  -- True <=> is an unboxed tuple case, don't enter the result
-	-> BcM BCInstrList
-doCase d s p (_,scrut) bndr alts is_unboxed_tuple 
+        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+        -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
+        -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
   = let
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
@@ -790,58 +785,58 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- on top of the itbl.
         ret_frame_sizeW = 2
 
-	-- An unlifted value gets an extra info table pushed on top
-	-- when it is returned.
-	unlifted_itbl_sizeW | isAlgCase = 0
-	  		    | otherwise = 1
+        -- An unlifted value gets an extra info table pushed on top
+        -- when it is returned.
+        unlifted_itbl_sizeW | isAlgCase = 0
+                            | otherwise = 1
 
-	-- depth of stack after the return value has been pushed
-	d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+        -- depth of stack after the return value has been pushed
+        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
 
-	-- depth of stack after the extra info table for an unboxed return
-	-- has been pushed, if any.  This is the stack depth at the
-	-- continuation.
+        -- depth of stack after the extra info table for an unboxed return
+        -- has been pushed, if any.  This is the stack depth at the
+        -- continuation.
         d_alts = d_bndr + unlifted_itbl_sizeW
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves
         p_alts = Map.insert bndr (d_bndr - 1) p
 
-	bndr_ty = idType bndr
+        bndr_ty = idType bndr
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 
         -- given an alt, return a discr and code for it.
-	codeAlt (DEFAULT, _, (_,rhs))
-	   = do rhs_code <- schemeE d_alts s p_alts rhs
-	        return (NoDiscr, rhs_code)
+        codeAlt (DEFAULT, _, (_,rhs))
+           = do rhs_code <- schemeE d_alts s p_alts rhs
+                return (NoDiscr, rhs_code)
 
         codeAlt alt@(_, bndrs, (_,rhs))
-	   -- primitive or nullary constructor alt: no need to UNPACK
-	   | null real_bndrs = do
-		rhs_code <- schemeE d_alts s p_alts rhs
+           -- primitive or nullary constructor alt: no need to UNPACK
+           | null real_bndrs = do
+                rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
-	   -- algebraic alt with some binders
+           -- algebraic alt with some binders
            | otherwise =
              let
-		 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
-		 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
-		 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
-		 bind_sizes   = ptr_sizes ++ nptrs_sizes
-		 size         = sum ptr_sizes + sum nptrs_sizes
-		 -- the UNPACK instruction unpacks in reverse order...
-		 p' = Map.insertList
-			(zip (reverse (ptrs ++ nptrs))
-			  (mkStackOffsets d_alts (reverse bind_sizes)))
-                        p_alts 
-	     in do
+                 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+                 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
+                 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
+                 bind_sizes   = ptr_sizes ++ nptrs_sizes
+                 size         = sum ptr_sizes + sum nptrs_sizes
+                 -- the UNPACK instruction unpacks in reverse order...
+                 p' = Map.insertList
+                        (zip (reverse (ptrs ++ nptrs))
+                          (mkStackOffsets d_alts (reverse bind_sizes)))
+                        p_alts
+             in do
              MASSERT(isAlgCase)
-	     rhs_code <- schemeE (d_alts+size) s p' rhs
+             rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
 	   where
-	     real_bndrs = filter (not.isTyCoVar) bndrs
+	     real_bndrs = filterOut isTyVar bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
-        my_discr (DataAlt dc, _, _) 
+        my_discr (DataAlt dc, _, _)
            | isUnboxedTupleCon dc
            = unboxedTupleException
            | otherwise
@@ -854,20 +849,20 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                        MachChar i    -> DiscrI (ord i)
                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 
-        maybe_ncons 
+        maybe_ncons
            | not isAlgCase = Nothing
-           | otherwise 
+           | otherwise
            = case [dc | (DataAlt dc, _, _) <- alts] of
                 []     -> Nothing
                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
 
-	-- the bitmap is relative to stack depth d, i.e. before the
-	-- BCO, info table and return value are pushed on.
-	-- This bit of code is v. similar to buildLivenessMask in CgBindery,
-	-- except that here we build the bitmap from the known bindings of
-	-- things that are pointers, whereas in CgBindery the code builds the
-	-- bitmap from the free slots and unboxed bindings.
-	-- (ToDo: merge?)
+        -- the bitmap is relative to stack depth d, i.e. before the
+        -- BCO, info table and return value are pushed on.
+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+        -- except that here we build the bitmap from the known bindings of
+        -- things that are pointers, whereas in CgBindery the code builds the
+        -- bitmap from the free slots and unboxed bindings.
+        -- (ToDo: merge?)
         --
         -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
         -- The bitmap must cover the portion of the stack up to the sequel only.
@@ -878,32 +873,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         bitmap_size = d-s
         bitmap_size' :: Int
         bitmap_size' = fromIntegral bitmap_size
-	bitmap = intsToReverseBitmap bitmap_size'{-size-}
+        bitmap = intsToReverseBitmap bitmap_size'{-size-}
                         (sortLe (<=) (filter (< bitmap_size') rel_slots))
-	  where
-	  binds = Map.toList p
-	  rel_slots = map fromIntegral $ concat (map spread binds)
-	  spread (id, offset)
-		| isFollowableArg (idCgRep id) = [ rel_offset ]
-		| otherwise = []
-		where rel_offset = d - offset - 1
+          where
+          binds = Map.toList p
+          rel_slots = map fromIntegral $ concat (map spread binds)
+          spread (id, offset)
+                | isFollowableArg (idCgRep id) = [ rel_offset ]
+                | otherwise = []
+                where rel_offset = d - offset - 1
 
      in do
      alt_stuff <- mapM codeAlt alts
      alt_final <- mkMultiBranch maybe_ncons alt_stuff
 
-     let 
+     let
          alt_bco_name = getName bndr
          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
-			0{-no arity-} bitmap_size bitmap True{-is alts-}
+                       0{-no arity-} bitmap_size bitmap True{-is alts-}
      -- in
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
---	     "\n      bitmap = " ++ show bitmap) $ do
+--            "\n      bitmap = " ++ show bitmap) $ do
      scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
-	    | isAlgCase = PUSH_ALTS alt_bco'
-	    | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+            | isAlgCase = PUSH_ALTS alt_bco'
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
      return (push_alts `consOL` scrut_code)
 
 
@@ -914,17 +909,17 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 -- deferencing ForeignObj#s and adjusting addrs to point to
 -- payloads in Ptr/Byte arrays.  Then, generate the marshalling
 -- (machine) code for the ccall, and create bytecodes to call that and
--- then return in the right way.  
+-- then return in the right way.
 
-generateCCall :: Word16 -> Sequel 		-- stack and sequel depths
+generateCCall :: Word16 -> Sequel       -- stack and sequel depths
               -> BCEnv
-              -> CCallSpec		-- where to call
-              -> Id 			-- of target, for type info
-              -> [AnnExpr' Id VarSet]	-- args (atoms)
+              -> CCallSpec              -- where to call
+              -> Id                     -- of target, for type info
+              -> [AnnExpr' Id VarSet]   -- args (atoms)
               -> BcM BCInstrList
 
 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-   = let 
+   = let
          -- useful constants
          addr_sizeW :: Word16
          addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
@@ -935,19 +930,19 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- CgRep of what was actually pushed.
 
          pargs _ [] = return []
-         pargs d (a:az) 
+         pargs d (a:az)
             = let arg_ty = repType (exprType (deAnnotate' a))
 
               in case splitTyConApp_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
                     -- contains.
-		    Just (t, _)
-		     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+                    Just (t, _)
+                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
                        -> do rest <- pargs (d + addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
                              return ((code,AddrRep):rest)
 
-		     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
                        -> do rest <- pargs (d + addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
                              return ((code,AddrRep):rest)
@@ -991,18 +986,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          (returns_void, r_rep)
             = case maybe_getCCallReturnRep (idType fn) of
                  Nothing -> (True,  VoidRep)
-                 Just rr -> (False, rr) 
+                 Just rr -> (False, rr)
          {-
-         Because the Haskell stack grows down, the a_reps refer to 
+         Because the Haskell stack grows down, the a_reps refer to
          lowest to highest addresses in that order.  The args for the call
          are on the stack.  Now push an unboxed Addr# indicating
-         the C function to call.  Then push a dummy placeholder for the 
-         result.  Finally, emit a CCALL insn with an offset pointing to the 
+         the C function to call.  Then push a dummy placeholder for the
+         result.  Finally, emit a CCALL insn with an offset pointing to the
          Addr# just pushed, and a literal field holding the mallocville
          address of the piece of marshalling code we generate.
-         So, just prior to the CCALL insn, the stack looks like this 
+         So, just prior to the CCALL insn, the stack looks like this
          (growing down, as usual):
-                 
+
             <arg_n>
             ...
             <arg_1>
@@ -1010,7 +1005,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
             <placeholder-for-result#> (must be an unboxed type)
 
          The interpreter then calls the marshall code mentioned
-         in the CCALL insn, passing it (& <placeholder-for-result#>), 
+         in the CCALL insn, passing it (& <placeholder-for-result#>),
          that is, the addr of the topmost word in the stack.
          When this returns, the placeholder will have been
          filled in.  The placeholder is slid down to the sequel
@@ -1053,7 +1048,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- Get the arg reps, zapping the leading Addr# in the dynamic case
          a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
                 | is_static = a_reps_pushed_RAW
-                | otherwise = if null a_reps_pushed_RAW 
+                | otherwise = if null a_reps_pushed_RAW
                               then panic "ByteCodeGen.generateCCall: dyn with no args"
                               else tail a_reps_pushed_RAW
 
@@ -1062,7 +1057,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
             | is_static
             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
                d_after_args + addr_sizeW)
-            | otherwise	-- is already on the stack
+            | otherwise -- is already on the stack
             = (nilOL, d_after_args)
 
          -- Push the return placeholder.  For a call returning nothing,
@@ -1070,17 +1065,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          r_sizeW   = fromIntegral (primRepSizeW r_rep)
          d_after_r = d_after_Addr + r_sizeW
          r_lit     = mkDummyLiteral r_rep
-         push_r    = (if   returns_void 
-                      then nilOL 
+         push_r    = (if   returns_void
+                      then nilOL
                       else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
 
          -- generate the marshalling code we're going to call
 
-	 -- Offset of the next stack frame down the stack.  The CCALL
- 	 -- instruction needs to describe the chunk of stack containing
-	 -- the ccall args to the GC, so it needs to know how large it
-	 -- is.  See comment in Interpreter.c with the CCALL instruction.
-	 stk_offset   = d_after_r - s
+         -- Offset of the next stack frame down the stack.  The CCALL
+         -- instruction needs to describe the chunk of stack containing
+         -- the ccall args to the GC, so it needs to know how large it
+         -- is.  See comment in Interpreter.c with the CCALL instruction.
+         stk_offset   = d_after_r - s
 
      -- in
      -- the only difference in libffi mode is that we prepare a cif
@@ -1119,7 +1114,7 @@ mkDummyLiteral pr
         _         -> panic "mkDummyLiteral"
 
 
--- Convert (eg) 
+-- Convert (eg)
 --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 --
@@ -1136,9 +1131,9 @@ mkDummyLiteral pr
 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 maybe_getCCallReturnRep fn_ty
    = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
-         maybe_r_rep_to_go  
+         maybe_r_rep_to_go
             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
-         (r_tycon, r_reps) 
+         (r_tycon, r_reps)
             = case splitTyConApp_maybe (repType r_ty) of
                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
                       Nothing -> blargh
@@ -1148,19 +1143,19 @@ maybe_getCCallReturnRep fn_ty
               && case maybe_r_rep_to_go of
                     Nothing    -> True
                     Just r_rep -> r_rep /= PtrRep
-                                  -- if it was, it would be impossible 
-                                  -- to create a valid return value 
+                                  -- if it was, it would be impossible
+                                  -- to create a valid return value
                                   -- placeholder on the stack
 
          blargh :: a -- Used at more than one type
-         blargh = pprPanic "maybe_getCCallReturn: can't handle:" 
+         blargh = pprPanic "maybe_getCCallReturn: can't handle:"
                            (pprType fn_ty)
-     in 
+     in
      --trace (showSDoc (ppr (a_reps, r_reps))) $
      if ok then maybe_r_rep_to_go else blargh
 
 -- Compile code which expects an unboxed Int on the top of stack,
--- (call it i), and pushes the i'th closure in the supplied list 
+-- (call it i), and pushes the i'th closure in the supplied list
 -- as a consequence.
 implement_tagToId :: [Name] -> BcM BCInstrList
 implement_tagToId names
@@ -1172,13 +1167,13 @@ implement_tagToId names
                                 [0 ..] names
             steps = map (mkStep label_exit) infos
         return (concatOL steps
-                  `appOL` 
+                  `appOL`
                   toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
      where
         mkStep l_exit (my_label, next_label, n, name_for_n)
-           = toOL [LABEL my_label, 
-                   TESTEQ_I n next_label, 
-                   PUSH_G name_for_n, 
+           = toOL [LABEL my_label,
+                   TESTEQ_I n next_label,
+                   PUSH_G name_for_n,
                    JMP l_exit]
 
 
@@ -1197,10 +1192,13 @@ implement_tagToId names
 
 pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
 
-pushAtom d p e 
-   | Just e' <- bcView e 
+pushAtom d p e
+   | Just e' <- bcView e
    = pushAtom d p e'
 
+pushAtom _ _ (AnnCoercion {})	-- Coercions are zero-width things, 
+   = return (nilOL, 0)	  	-- treated just like a variable VoidArg
+
 pushAtom d p (AnnVar v)
    | idCgRep v == VoidArg
    = return (nilOL, 0)
@@ -1214,19 +1212,19 @@ pushAtom d p (AnnVar v)
    | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable
    = let l = d - d_v + sz - 2
      in return (toOL (genericReplicate sz (PUSH_L l)), sz)
-	 -- d - d_v 		    the number of words between the TOS 
-	 --			    and the 1st slot of the object
-	 --
-	 -- d - d_v - 1 	    the offset from the TOS of the 1st slot
-	 --
-	 -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot
-	 --			    of the object.
-	 --
-	 -- Having found the last slot, we proceed to copy the right number of
-	 -- slots on to the top of the stack.
+         -- d - d_v                 the number of words between the TOS
+         --                         and the 1st slot of the object
+         --
+         -- d - d_v - 1             the offset from the TOS of the 1st slot
+         --
+         -- d - d_v - 1 + sz - 1    the offset from the TOS of the last slot
+         --                         of the object.
+         --
+         -- Having found the last slot, we proceed to copy the right number of
+         -- slots on to the top of the stack.
 
     | otherwise  -- v must be a global variable
-    = ASSERT(sz == 1) 
+    = ASSERT(sz == 1)
       return (unitOL (PUSH_G (getName v)), sz)
 
     where
@@ -1242,31 +1240,31 @@ pushAtom _ _ (AnnLit lit)
         MachFloat _   -> code FloatArg
         MachDouble _  -> code DoubleArg
         MachChar _    -> code NonPtrArg
-	MachNullAddr  -> code NonPtrArg
+        MachNullAddr  -> code NonPtrArg
         MachStr s     -> pushStr s
         l             -> pprPanic "pushAtom" (ppr l)
      where
         code rep
            = let size_host_words = fromIntegral (cgRepSizeW rep)
-             in  return (unitOL (PUSH_UBX (Left lit) size_host_words), 
+             in  return (unitOL (PUSH_UBX (Left lit) size_host_words),
                            size_host_words)
 
-        pushStr s 
+        pushStr s
            = let getMallocvilleAddr
                     = case s of
-                         FastString _ n _ fp _ -> 
-			    -- we could grab the Ptr from the ForeignPtr,
-			    -- but then we have no way to control its lifetime.
-			    -- In reality it'll probably stay alive long enoungh
-			    -- by virtue of the global FastString table, but
-			    -- to be on the safe side we copy the string into
-			    -- a malloc'd area of memory.
+                         FastString _ n _ fp _ ->
+                            -- we could grab the Ptr from the ForeignPtr,
+                            -- but then we have no way to control its lifetime.
+                            -- In reality it'll probably stay alive long enoungh
+                            -- by virtue of the global FastString table, but
+                            -- to be on the safe side we copy the string into
+                            -- a malloc'd area of memory.
                                 do ptr <- ioToBc (mallocBytes (n+1))
                                    recordMallocBc ptr
                                    ioToBc (
                                       withForeignPtr fp $ \p -> do
-				         memcpy ptr p (fromIntegral n)
-				         pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+                                         memcpy ptr p (fromIntegral n)
+                                         pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
                                          return ptr
                                       )
              in do
@@ -1274,11 +1272,8 @@ pushAtom _ _ (AnnLit lit)
                 -- Get the addr on the stack, untaggedly
                 return (unitOL (PUSH_UBX (Right addr) 1), 1)
 
-pushAtom d p (AnnCast e _)
-   = pushAtom d p (snd e)
-
 pushAtom _ _ expr
-   = pprPanic "ByteCodeGen.pushAtom" 
+   = pprPanic "ByteCodeGen.pushAtom"
               (pprCoreExpr (deAnnotate (undefined, expr)))
 
 foreign import ccall unsafe "memcpy"
@@ -1290,14 +1285,14 @@ foreign import ccall unsafe "memcpy"
 -- of making a multiway branch using a switch tree.
 -- What a load of hassle!
 
-mkMultiBranch :: Maybe Int	--  # datacons in tycon, if alg alt
-				-- a hint; generates better code
-				-- Nothing is always safe
-              -> [(Discr, BCInstrList)] 
+mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
+                                -- a hint; generates better code
+                                -- Nothing is always safe
+              -> [(Discr, BCInstrList)]
               -> BcM BCInstrList
 mkMultiBranch maybe_ncons raw_ways
    = let d_way     = filter (isNoDiscr.fst) raw_ways
-         notd_ways = sortLe 
+         notd_ways = sortLe
                         (\w1 w2 -> leAlt (fst w1) (fst w2))
                         (filter (not.isNoDiscr.fst) raw_ways)
 
@@ -1305,14 +1300,14 @@ mkMultiBranch maybe_ncons raw_ways
          mkTree [] _range_lo _range_hi = return the_default
 
          mkTree [val] range_lo range_hi
-            | range_lo `eqAlt` range_hi 
+            | range_lo `eqAlt` range_hi
             = return (snd val)
             | otherwise
             = do label_neq <- getLabelBc
-                 return (testEQ (fst val) label_neq 
-   			  `consOL` (snd val
-   			  `appOL`   unitOL (LABEL label_neq)
-                          `appOL`   the_default))
+                 return (testEQ (fst val) label_neq
+                         `consOL` (snd val
+                         `appOL`   unitOL (LABEL label_neq)
+                         `appOL`   the_default))
 
          mkTree vals range_lo range_hi
             = let n = length vals `div` 2
@@ -1324,11 +1319,11 @@ mkMultiBranch maybe_ncons raw_ways
               code_lo <- mkTree vals_lo range_lo (dec v_mid)
               code_hi <- mkTree vals_hi v_mid range_hi
               return (testLT v_mid label_geq
-                        `consOL` (code_lo
-			`appOL`   unitOL (LABEL label_geq)
-			`appOL`   code_hi))
- 
-         the_default 
+                      `consOL` (code_lo
+                      `appOL`   unitOL (LABEL label_geq)
+                      `appOL`   code_hi))
+
+         the_default
             = case d_way of [] -> unitOL CASEFAIL
                             [(_, def)] -> def
                             _ -> panic "mkMultiBranch/the_default"
@@ -1353,12 +1348,12 @@ mkMultiBranch maybe_ncons raw_ways
             = panic "mkMultiBranch: awesome foursome"
             | otherwise
             = case fst (head notd_ways) of
-              	DiscrI _ -> ( DiscrI minBound, 	DiscrI maxBound )
-              	DiscrW _ -> ( DiscrW minBound, 	DiscrW maxBound )
-              	DiscrF _ -> ( DiscrF minF,     	DiscrF maxF )
-              	DiscrD _ -> ( DiscrD minD,     	DiscrD maxD )
-              	DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
-              	NoDiscr -> panic "mkMultiBranch NoDiscr"
+                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )
+                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )
+                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )
+                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )
+                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+                NoDiscr -> panic "mkMultiBranch NoDiscr"
 
          (algMinBound, algMaxBound)
             = case maybe_ncons of
@@ -1388,8 +1383,8 @@ mkMultiBranch maybe_ncons raw_ways
          dec (DiscrI i) = DiscrI (i-1)
          dec (DiscrW w) = DiscrW (w-1)
          dec (DiscrP i) = DiscrP (i-1)
-         dec other      = other		-- not really right, but if you
-		-- do cases on floating values, you'll get what you deserve
+         dec other      = other         -- not really right, but if you
+                -- do cases on floating values, you'll get what you deserve
 
          -- same snotty comment applies to the following
          minF, maxF :: Float
@@ -1406,7 +1401,7 @@ mkMultiBranch maybe_ncons raw_ways
 -- Supporting junk for the compilation schemes
 
 -- Describes case alts
-data Discr 
+data Discr
    = DiscrI Int
    | DiscrW Word
    | DiscrF Float
@@ -1431,9 +1426,9 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id))
 
 -- See bug #1257
 unboxedTupleException :: a
-unboxedTupleException 
-   = ghcError 
-        (ProgramError 
+unboxedTupleException
+   = ghcError
+        (ProgramError
            ("Error: bytecode compiler can't handle unboxed tuples.\n"++
             "  Possibly due to foreign import/export decls in source.\n"++
             "  Workaround: use -fobject-code, or compile this module to .o separately."))
@@ -1443,11 +1438,11 @@ mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
 
 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
-	-- The arguments are returned in *right-to-left* order
+        -- The arguments are returned in *right-to-left* order
 splitApp e | Just e' <- bcView e = splitApp e'
-splitApp (AnnApp (_,f) (_,a)) 	 = case splitApp f of 
-			      	      (f', as) -> (f', a:as)
-splitApp e		      	 = (e, [])
+splitApp (AnnApp (_,f) (_,a))    = case splitApp f of
+                                      (f', as) -> (f', a:as)
+splitApp e                       = (e, [])
 
 
 bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
@@ -1456,23 +1451,25 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 --  b) type applications
 --  c) casts
 --  d) notes
--- Type lambdas *can* occur in random expressions, 
+-- Type lambdas *can* occur in random expressions,
 -- whereas value lambdas cannot; that is why they are nuked here
 bcView (AnnNote _ (_,e)) 	     = Just e
 bcView (AnnCast (_,e) _) 	     = Just e
-bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
+bcView (AnnLam v (_,e)) | isTyVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
 bcView _                             = Nothing
 
 isVoidArgAtom :: AnnExpr' Var ann -> Bool
 isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
 isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
+isVoidArgAtom (AnnCoercion {})        = True
 isVoidArgAtom _ 	              = False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
 atomPrimRep (AnnVar v)    	    = typePrimRep (idType v)
 atomPrimRep (AnnLit l)    	    = typePrimRep (literalType l)
+atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
 atomRep :: AnnExpr' Id ann -> CgRep
@@ -1493,32 +1490,32 @@ mkStackOffsets original_depth szsw
 
 type BcPtr = Either ItblPtr (Ptr ())
 
-data BcM_State 
-   = BcM_State { 
+data BcM_State
+   = BcM_State {
         uniqSupply :: UniqSupply,       -- for generating fresh variable names
-	nextlabel :: Word16,		-- for generating local labels
-	malloced  :: [BcPtr],		-- thunks malloced for current BCO
-					-- Should be free()d when it is GCd
-        breakArray :: BreakArray        -- array of breakpoint flags 
+        nextlabel :: Word16,            -- for generating local labels
+        malloced  :: [BcPtr],           -- thunks malloced for current BCO
+                                        -- Should be free()d when it is GCd
+        breakArray :: BreakArray        -- array of breakpoint flags
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
 
 ioToBc :: IO a -> BcM a
-ioToBc io = BcM $ \st -> do 
-  x <- io 
+ioToBc io = BcM $ \st -> do
+  x <- io
   return (st, x)
 
 runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us modBreaks (BcM m) 
-   = m (BcM_State us 0 [] breakArray)   
+runBc us modBreaks (BcM m)
+   = m (BcM_State us 0 [] breakArray)
    where
    breakArray = modBreaks_flags modBreaks
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
   (st1, q) <- expr st0
-  let BcM k = cont q 
+  let BcM k = cont q
   (st2, r) <- k st1
   return (st2, r)
 
@@ -1557,10 +1554,10 @@ getLabelBc
 
 getLabelsBc :: Word16 -> BcM [Word16]
 getLabelsBc n
-  = BcM $ \st -> let ctr = nextlabel st 
-		 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+  = BcM $ \st -> let ctr = nextlabel st
+                 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
 
-getBreakArray :: BcM BreakArray 
+getBreakArray :: BcM BreakArray
 getBreakArray = BcM $ \st -> return (st, breakArray st)
 
 newUnique :: BcM Unique
@@ -1570,7 +1567,7 @@ newUnique = BcM $
                            in  return (newState, uniq)
 
 newId :: Type -> BcM Id
-newId ty = do 
+newId ty = do
     uniq <- newUnique
     return $ mkSysLocal tickFS uniq ty
 
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index d44a00b..49c5488 100644
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -124,7 +124,7 @@ data BCInstr
    | CASEFAIL
    | JMP              LocalLabel
 
-   -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
+   -- For doing calls to C (via glue code generated by libffi)
    | CCALL            Word16    -- stack frame size
                       (Ptr ())  -- addr of the glue code
                       Word16    -- whether or not the call is interruptible
diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs
index 310ddb5..cd593f7 100644
--- a/compiler/ghci/ObjLink.lhs
+++ b/compiler/ghci/ObjLink.lhs
@@ -28,6 +28,8 @@ import Control.Monad    ( when )
 import Foreign.C
 import Foreign		( nullPtr )
 import GHC.Exts         ( Ptr(..) )
+import GHC.IO.Encoding  ( fileSystemEncoding )
+import qualified GHC.Foreign as GHC
 
 
 
@@ -35,17 +37,21 @@ import GHC.Exts         ( Ptr(..) )
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 
+-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
+withFileCString :: FilePath -> (CString -> IO a) -> IO a
+withFileCString = GHC.withCString fileSystemEncoding
+
 insertSymbol :: String -> String -> Ptr a -> IO ()
 insertSymbol obj_name key symbol
     = let str = prefixUnderscore key
-      in withCString obj_name $ \c_obj_name ->
-         withCString str $ \c_str ->
+      in withFileCString obj_name $ \c_obj_name ->
+         withCAString str $ \c_str ->
           c_insertSymbol c_obj_name c_str symbol
 
 lookupSymbol :: String -> IO (Maybe (Ptr a))
 lookupSymbol str_in = do
    let str = prefixUnderscore str_in
-   withCString str $ \c_str -> do
+   withCAString str $ \c_str -> do
      addr <- c_lookupSymbol c_str
      if addr == nullPtr
 	then return Nothing
@@ -60,7 +66,7 @@ loadDLL :: String -> IO (Maybe String)
 -- Nothing      => success
 -- Just err_msg => failure
 loadDLL str = do
-  maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+  maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
   if maybe_errmsg == nullPtr
 	then return Nothing
 	else do str <- peekCString maybe_errmsg
@@ -68,19 +74,19 @@ loadDLL str = do
 
 loadArchive :: String -> IO ()
 loadArchive str = do
-   withCString str $ \c_str -> do
+   withFileCString str $ \c_str -> do
      r <- c_loadArchive c_str
      when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
 
 loadObj :: String -> IO ()
 loadObj str = do
-   withCString str $ \c_str -> do
+   withFileCString str $ \c_str -> do
      r <- c_loadObj c_str
      when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
 
 unloadObj :: String -> IO ()
 unloadObj str =
-   withCString str $ \c_str -> do
+   withFileCString str $ \c_str -> do
      r <- c_unloadObj c_str
      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
 
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b4068a7..b6c97c3 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -45,22 +45,19 @@ import TyCon
 import Name
 import VarEnv
 import Util
-import ListSetOps
 import VarSet
 import TysPrim
 import PrelNames
 import TysWiredIn
 import DynFlags
-import Outputable
+import Outputable as Ppr
 import FastString
--- import Panic
-
 import Constants        ( wORD_SIZE )
-
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
 import GHC.IO ( IO(..) )
 
+import StaticFlags( opt_PprStyle_Debug )
 import Control.Monad
 import Data.Maybe
 import Data.Array.Base
@@ -186,7 +183,7 @@ getClosureData a =
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
-                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
            ASSERT(elems >= 0) return ()
            ptrsList `seq` 
             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
@@ -346,10 +343,17 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt}
   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) 
     <+> hsep (map (ppr_term1 True) tt) 
 -} -- TODO Printing infix constructors properly
-  | null tt   = return$ ppr dc
-  | otherwise = do
-         tt_docs <- mapM (y app_prec) tt
-         return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+  | null sub_terms_to_show
+  = return (ppr dc)
+  | otherwise 
+  = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
+       ; return $ cparen (p >= app_prec) $
+         sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
+  where
+    sub_terms_to_show	-- Don't show the dictionary arguments to 
+    			-- constructors unless -dppr-debug is on
+      | opt_PprStyle_Debug = tt
+      | otherwise = dropList (dataConTheta dc) tt
 
 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 ppr_termM y p RefWrap{wrapped_term=t}  = do
@@ -414,55 +418,70 @@ cPprTerm printers_ = go 0 where
   firstJustM [] = return Nothing
 
 -- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
 cPprTermBase y =
   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) 
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
-           (\ p t -> doList p t)
-  , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
-  , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
-  , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
-  , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
-  , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
+           ppr_list
+  , ifTerm (isTyCon intTyCon    . ty) ppr_int
+  , ifTerm (isTyCon charTyCon   . ty) ppr_char
+  , ifTerm (isTyCon floatTyCon  . ty) ppr_float
+  , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+  , ifTerm (isIntegerTy         . ty) ppr_integer
   ]
-     where ifTerm pred f prec t@Term{}
-               | pred t    = Just `liftM` f prec t
-           ifTerm _ _ _ _  = return Nothing
-
-           isTupleTy ty    = fromMaybe False $ do 
-             (tc,_) <- tcSplitTyConApp_maybe ty 
-             return (isBoxedTupleTyCon tc)
-
-           isTyCon a_tc ty = fromMaybe False $ do 
-             (tc,_) <- tcSplitTyConApp_maybe ty
-             return (a_tc == tc)
-
-           isIntegerTy ty = fromMaybe False $ do
-             (tc,_) <- tcSplitTyConApp_maybe ty
-             return (tyConName tc == integerTyConName)
-
-           coerceShow f _p = return . text . show . f . unsafeCoerce# . val
-
-           --Note pprinting of list terms is not lazy
-           doList p (Term{subTerms=[h,t]}) = do
-               let elems      = h : getListTerms t
-                   isConsLast = not(termType(last elems) `coreEqType` termType h)
-               print_elems <- mapM (y cons_prec) elems
-               return$ if isConsLast
-                     then cparen (p >= cons_prec) 
-                        . pprDeeperList fsep 
-                        . punctuate (space<>colon)
-                        $ print_elems
-                     else brackets (pprDeeperList fcat$
-                                         punctuate comma print_elems)
-
-                where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
-                      getListTerms Term{subTerms=[]}    = []
-                      getListTerms t@Suspension{}       = [t]
-                      getListTerms t = pprPanic "getListTerms" (ppr t)
-           doList _ _ = panic "doList"
+ where 
+   ifTerm :: (Term -> Bool)
+          -> (Precedence -> Term -> m SDoc)
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm pred f prec t@Term{}
+       | pred t    = Just `liftM` f prec t
+   ifTerm _ _ _ _  = return Nothing
+
+   isTupleTy ty    = fromMaybe False $ do 
+     (tc,_) <- tcSplitTyConApp_maybe ty 
+     return (isBoxedTupleTyCon tc)
+
+   isTyCon a_tc ty = fromMaybe False $ do 
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (a_tc == tc)
+
+   isIntegerTy ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (tyConName tc == integerTyConName)
+
+   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer 
+      :: Precedence -> Term -> m SDoc
+   ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
+   ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+   ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))
+   ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))
+   ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+   --Note pprinting of list terms is not lazy
+   ppr_list :: Precedence -> Term -> m SDoc
+   ppr_list p (Term{subTerms=[h,t]}) = do
+       let elems      = h : getListTerms t
+           isConsLast = not(termType(last elems) `eqType` termType h)
+   	   is_string  = all (isCharTy . ty) elems
+
+       print_elems <- mapM (y cons_prec) elems
+       if is_string
+        then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+        else if isConsLast
+        then return $ cparen (p >= cons_prec) 
+                    $ pprDeeperList fsep 
+                    $ punctuate (space<>colon) print_elems
+        else return $ brackets 
+                    $ pprDeeperList fcat
+                    $ punctuate comma print_elems
+
+        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+              getListTerms Term{subTerms=[]}    = []
+              getListTerms t@Suspension{}       = [t]
+              getListTerms t = pprPanic "getListTerms" (ppr t)
+   ppr_list _ _ = panic "doList"
 
 
 repPrim :: TyCon -> [Word] -> String
@@ -566,6 +585,11 @@ liftTcM = id
 newVar :: Kind -> TR TcType
 newVar = liftTcM . newFlexiTyVarTy
 
+instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars = liftTcM . tcInstTyVars
+
 type RttiInstantiation = [(TcTyVar, TyVar)]
    -- Associates the typechecker-world meta type variables 
    -- (which are mutable and may be refined), to their 
@@ -658,7 +682,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             text "Type obtained: " <> ppr (termType term))
    return term
     where 
+
   go :: Int -> Type -> Type -> HValue -> TcM Term
+   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
   go max_depth _ _ _ | seq max_depth False = undefined
   go 0 my_ty _old_ty a = do
     traceTR (text "Gave up reconstructing a term after" <>
@@ -704,7 +731,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
         traceTR (text "entering a constructor " <>
                       if monomorphic
                         then parens (text "already monomorphic: " <> ppr my_ty)
-                        else Outputable.empty)
+                        else Ppr.empty)
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
         case mb_dc of
@@ -713,59 +740,34 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         -- In such case, we return a best approximation:
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
+		       traceTR (text "Nothing" <+> ppr dcname)
                        let tag = showSDoc (ppr dcname)
                        vars     <- replicateM (length$ elems$ ptrs clos) 
-                                              (newVar (liftedTypeKind))
+                                              (newVar liftedTypeKind)
                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i 
                                               | (i, tv) <- zip [0..] vars]
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
-            let subTtypes  = matchSubTypes dc old_ty
-            subTermTvs    <- mapMif (not . isMonomorphic)
-                                    (\t -> newVar (typeKind t))
-                                    subTtypes
-            let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
-                                                             || isRefType ty)
-                                                    (zip subTtypes subTermTvs)
-                (subTtypesP,   subTermTvsP ) = unzip subTermsP
-                (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
-
-            -- When we already have all the information, avoid solving
-            -- unnecessary constraints. Propagation of type information
-            -- to subterms is already being done via matching.
-            when (not monomorphic) $ do
-               let myType = mkFunTys subTermTvs my_ty
-               (signatureType,_) <- instScheme (mydataConType dc)
-            -- It is vital for newtype reconstruction that the unification step
-            -- is done right here, _before_ the subterms are RTTI reconstructed
-               addConstraint myType signatureType
+            traceTR (text "Just" <+> ppr dc)
+            subTtypes <- getDataConArgTys dc my_ty
+            let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
             subTermsP <- sequence
-                  [ appArr (go (pred max_depth) tv t) (ptrs clos) i
-                   | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
+                  [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
+                  | (i,ty) <- zip [0..] subTtypesP]
             let unboxeds   = extractUnboxed subTtypesNP clos
-                subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+                subTermsNP = zipWith Prim subTtypesNP unboxeds
                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
             return (Term my_ty (Right dc) a subTerms)
+
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
       tipe_clos ->
          return (Suspension tipe_clos my_ty a Nothing)
 
-  matchSubTypes dc ty
-    | ty' <- repType ty     -- look through newtypes
-    , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
-    , dc `elem` tyConDataCons tc
-      -- It is necessary to check that dc is actually a constructor for tycon tc,
-      -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
-      -- has not removed it. In that case, we happily give up and don't match
-    = myDataConInstArgTys dc ty_args
-    | otherwise = dataConRepArgTys dc
-
   -- put together pointed and nonpointed subterms in the
   --  correct order.
   reOrderTerms _ _ [] = []
   reOrderTerms pointed unpointed (ty:tys) 
-   | isLifted ty || isRefType ty
-                  = ASSERT2(not(null pointed)
+   | isPtrType ty = ASSERT2(not(null pointed)
                             , ptext (sLit "reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
@@ -835,6 +837,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    -- returns unification tasks,since we are going to want a breadth-first search
   go :: Type -> HValue -> TR [(Type, HValue)]
   go my_ty a = do
+    traceTR (text "go" <+> ppr my_ty)
     clos <- trIO $ getClosureData a
     case tipe clos of
       Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
@@ -847,6 +850,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
          return [(tv', contents)]
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
+        traceTR (text "Constr1" <+> ppr dcname)
         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
@@ -856,17 +860,10 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 
           Just dc -> do
-            subTtypes <- mapMif (not . isMonomorphic)
-                                (\t -> newVar (typeKind t))
-                                (dataConRepArgTys dc)
-
-            -- It is vital for newtype reconstruction that the unification step
-            -- is done right here, _before_ the subterms are RTTI reconstructed
-            let myType         = mkFunTys subTtypes my_ty
-            (signatureType,_) <- instScheme (mydataConType dc)
-            addConstraint myType signatureType
-            return $ [ appArr (\e->(t,e)) (ptrs clos) i
-                       | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
+            arg_tys <- getDataConArgTys dc my_ty
+	    traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+            return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
+                     | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
       _ -> return []
 
 -- Compute the difference between a base type and the type found by RTTI
@@ -877,36 +874,36 @@ improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
 improveRTTIType _ base_ty new_ty
   = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
 
-myDataConInstArgTys :: DataCon -> [Type] -> [Type]
-myDataConInstArgTys dc args
-    | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
-    | otherwise = dataConRepArgTys dc
-
-mydataConType :: DataCon -> QuantifiedType
--- ^ Custom version of DataCon.dataConUserType where we
---    - remove the equality constraints
---    - use the representation types for arguments, including dictionaries
---    - keep the original result type
-mydataConType  dc
-  = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
-    , mkFunTys arg_tys res_ty )
-  where univ_tvs   = dataConUnivTyVars dc
-        ex_tvs     = dataConExTyVars dc
-        eq_spec    = dataConEqSpec dc
-        arg_tys    = [case a of
-                        PredTy p -> predTypeRep p
-                        _        -> a
-                     | a <- dataConRepArgTys dc]
-        res_ty     = dataConOrigResTy dc
-
-isRefType :: Type -> Bool
-isRefType ty
-   | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
-   | otherwise = False
-  where ty'= repType ty
-
-isRefTyCon :: TyCon -> Bool
-isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty) 
+-- return the types of the arguments.  This is RTTI-land, so 'ty' might
+-- not be fully known.  Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+getDataConArgTys dc con_app_ty
+  = do { (_, ex_tys, _) <- instTyVars ex_tvs
+       ; let rep_con_app_ty = repType con_app_ty
+       ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
+                       Just (tc, ty_args) | dataConTyCon dc == tc
+		       	   -> ASSERT( univ_tvs `equalLength` ty_args) 
+                              return ty_args
+ 		       _   -> do { (_, ty_args, subst) <- instTyVars univ_tvs
+		       	         ; let res_ty = substTy subst (dataConOrigResTy dc)
+                                 ; addConstraint rep_con_app_ty res_ty
+                                 ; return ty_args }
+		-- It is necessary to check dataConTyCon dc == tc
+      		-- because it may be the case that tc is a recursive
+      		-- newtype and tcSplitTyConApp has not removed it. In
+      		-- that case, we happily give up and don't match
+       ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+       ; return (substTys subst (dataConRepArgTys dc)) }
+  where
+    univ_tvs = dataConUnivTyVars dc
+    ex_tvs   = dataConExTyVars dc
+
+isPtrType :: Type -> Bool
+isPtrType ty = case typePrimRep ty of
+                 PtrRep -> True
+                 _      -> False
 
 -- Soundness checks
 --------------------
@@ -1103,7 +1100,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
             | otherwise = do
                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
                         text " in presence of newtype evidence " <> ppr new_tycon)
-               vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+               (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
                _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
@@ -1183,12 +1180,6 @@ quantifyType :: Type -> QuantifiedType
 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
 
-mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
-mapMif pred f xx = sequence $ mapMif_ pred f xx
-  where
-   mapMif_ _ _ []     = []
-   mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
-
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM condM acc = condM >>= \c -> unless c acc
 
@@ -1205,24 +1196,10 @@ amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
     where g (I# i#) = case indexArray# arr# i# of
                           (# e #) -> f e
 
-
-isLifted :: Type -> Bool
-isLifted =  not . isUnLiftedType
-
 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 extractUnboxed tt clos = go tt (nonPtrs clos)
-   where sizeofType t
-           | Just (tycon,_) <- tcSplitTyConApp_maybe t
-           = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
-           | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
+   where sizeofType t = primRepSizeW (typePrimRep t)
          go [] _ = []
          go (t:tt) xx 
            | (x, rest) <- splitAt (sizeofType t) xx
            = x : go tt rest
-
-sizeofTyCon :: TyCon -> Int -- in *words*
-sizeofTyCon = primRepSizeW . tyConPrimRep
-
-
-(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
-(f |.| g) x = f x || g x
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b5e6c41..492f255 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts
   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
   | otherwise
   = do	{ stmts' <- cvtStmts stmts
-	; body <- case last stmts' of
-		    L _ (ExprStmt body _ _) -> return body
-                    stmt' -> failWith (bad_last stmt')
-	; return $ HsDo do_or_lc (init stmts') body void }
+        ; let Just (stmts'', last') = snocView stmts'
+        
+	; last'' <- case last' of
+		      L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
+                      _ -> failWith (bad_last last')
+
+	; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
   where
-    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
+    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
 			 , ptext (sLit "(It should be an expression.)") ]
 		
@@ -539,7 +542,7 @@ cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
                             ; returnL $ LetStmt ds' }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
 		       where
 			 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 
@@ -565,7 +568,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)  
   = do { force i; return $ mkHsIntegral i placeHolderType}
 cvtOverLit (RationalL r) 
-  = do { force r; return $ mkHsFractional r placeHolderType}
+  = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
 cvtOverLit (StringL s)   
   = do { let { s' = mkFastString s }
        ; force s'
@@ -599,8 +602,8 @@ allCharLs xs
 cvtLit :: Lit -> CvtM HsLit
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
-cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
-cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
+cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
        		       	    ; force s'      
@@ -765,6 +768,9 @@ overloadedLit _             = False
 void :: Type.Type
 void = placeHolderType
 
+cvtFractionalLit :: Rational -> FractionalLit
+cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
+
 --------------------------------------------------------------------
 --	Turning Name back into RdrName
 --------------------------------------------------------------------
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 675afa2..5871914 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -69,23 +69,23 @@ data HsLocalBindsLR idL idR	-- Bindings in a 'let' expression
 type HsValBinds id = HsValBindsLR id id
 
 data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
-  = ValBindsIn             -- Before renaming
+  = ValBindsIn             -- Before renaming RHS; idR is always RdrName
 	(LHsBindsLR idL idR) [LSig idR]	-- Not dependency analysed
 					-- Recursive by default
 
-  | ValBindsOut		   -- After renaming
+  | ValBindsOut		   -- After renaming RHS; idR can be Name or Id
 	[(RecFlag, LHsBinds idL)]	-- Dependency analysed, later bindings 
                                         -- in the list may depend on earlier
                                         -- ones.
 	[LSig Name]
   deriving (Data, Typeable)
 
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind  id = Located (HsBind id)
-type HsBind id   = HsBindLR id id
+type LHsBind  id = LHsBindLR  id id
+type LHsBinds id = LHsBindsLR id id
+type HsBind   id = HsBindLR   id id
 
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
+type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 
 data HsBindLR idL idR
   = -- | FunBind is used for both functions   @f x = e@
@@ -357,7 +357,7 @@ data IPBind id
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
-			$$ ifPprDebug (ppr ds)
+                        $$ ifPprDebug (ppr ds)
 
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -457,7 +457,7 @@ data EvTerm
   deriving( Data, Typeable)
 
 evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
             | otherwise = EvId v
 \end{code}
 
@@ -546,7 +546,7 @@ pprHsWrapper doc wrap
     help it WpHole             = it
     help it (WpCompose f1 f2)  = help (help it f2) f1
     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") 
-                                                 <+> pprParendType co)]
+                                              <+> pprParendCo co)]
     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
     help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
     help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
@@ -572,8 +572,8 @@ instance Outputable EvBind where
 
 instance Outputable EvTerm where
   ppr (EvId v)        	 = ppr v
-  ppr (EvCast v co)   	 = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
-  ppr (EvCoercion co)    = ppr co
+  ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
+  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
   ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
 \end{code}
@@ -597,6 +597,10 @@ data Sig name	-- Signatures and pragmas
 	-- f :: Num a => a -> a
     TypeSig (Located name) (LHsType name)
 
+        -- A type signature for a default method inside a class
+        -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
+  | GenericSig (Located name) (LHsType name)
+
 	-- A type signature in generated code, notably the code
 	-- generated for record selectors.  We simply record
 	-- the desired Id itself, replete with its name, type
@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool
 okBindSig _ = True
 
 okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig  _ _) = True
-okHsBootSig (FixSig _) 	   = True
-okHsBootSig _              = False
+okHsBootSig (TypeSig  _ _)    = True
+okHsBootSig (GenericSig  _ _) = False
+okHsBootSig (FixSig _) 	      = True
+okHsBootSig _                 = False
 
 okClsDclSig :: Sig a -> Bool
 okClsDclSig (SpecInstSig _) = False
 okClsDclSig _               = True        -- All others OK
 
 okInstDclSig :: Sig a -> Bool
-okInstDclSig (TypeSig _ _)   = False
-okInstDclSig (FixSig _)      = False
-okInstDclSig _ 	             = True
+okInstDclSig (TypeSig _ _)    = False
+okInstDclSig (GenericSig _ _) = False
+okInstDclSig (FixSig _)       = False
+okInstDclSig _ 	              = True
 
 sigName :: LSig name -> Maybe name
 -- Used only in Haddock
@@ -702,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True
 isVanillaLSig _                 = False
 
 isTypeLSig :: LSig name -> Bool	 -- Type signatures
-isTypeLSig (L _(TypeSig {})) = True
-isTypeLSig (L _(IdSig {}))   = True
-isTypeLSig _                 = False
+isTypeLSig (L _(TypeSig {}))    = True
+isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(IdSig {}))      = True
+isTypeLSig _                    = False
 
 isSpecLSig :: LSig name -> Bool
 isSpecLSig (L _(SpecSig {})) = True
@@ -727,6 +734,7 @@ isInlineLSig _                    = False
 
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {}) 		= ptext (sLit "type signature")
+hsSigDoc (GenericSig {})	= ptext (sLit "default type signature")
 hsSigDoc (IdSig {}) 		= ptext (sLit "id signature")
 hsSigDoc (SpecSig {})	 	= ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
@@ -741,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 eqHsSig (L _ (IdSig n1))         	(L _ (IdSig n2))                = n1 == n2
 eqHsSig (L _ (TypeSig n1 _))         	(L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
+eqHsSig (L _ (GenericSig n1 _))        	(L _ (GenericSig n2 _))         = unLoc n1 == unLoc n2
 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
  	-- For specialisations, we don't have equality over
 	-- HsType, so it's not convenient to spot duplicate 
@@ -754,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 ppr_sig (TypeSig var ty)	  = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (GenericSig var ty)	  = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
 ppr_sig (IdSig id)	          = pprVarSig id (ppr (varType id))
 ppr_sig (FixSig fix_sig) 	  = ppr fix_sig
 ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var (ppr ty) inl)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 345ec32..c05f26a 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -3,15 +3,7 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
-
-
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
 {-# LANGUAGE DeriveDataTypeable #-}
 
 -- | Abstract syntax of global declarations.
@@ -630,15 +622,15 @@ instance OutputableBndr name
                   (ppr new_or_data <+> 
 		   (if isJust typats then ptext (sLit "instance") else empty) <+>
 		   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
-		   ppr_sig mb_sig)
+		   ppr_sigx mb_sig)
 		  (pp_condecls condecls)
 		  derivings
       where
-	ppr_sig Nothing = empty
-	ppr_sig (Just kind) = dcolon <+> pprKind kind
+	ppr_sigx Nothing     = empty
+	ppr_sigx (Just kind) = dcolon <+> pprKind kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
-		    tcdFDs = fds, 
+		    tcdFDs  = fds, 
 		    tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
       | null sigs && null ats  -- No "where" part
       = top_matter
@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
+  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
-    ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
-    ppr_details con (RecCon fields)  = ppr con <+> pprConDeclFields fields
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
+    ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = PrefixCon arg_tys
@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
 
 %************************************************************************
 %*									*
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
 %*									*
 %************************************************************************
 
@@ -835,14 +827,14 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
 
 %************************************************************************
 %*									*
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
 %*									*
 %************************************************************************
 
 \begin{code}
 type LDerivDecl name = Located (DerivDecl name)
 
-data DerivDecl name = DerivDecl (LHsType name)
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
   deriving (Data, Typeable)
 
 instance (OutputableBndr name) => Outputable (DerivDecl name) where
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index b7fe6fc..c3c372d 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -23,6 +23,8 @@ import Name
 import BasicTypes
 import DataCon
 import SrcLoc
+import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
 import Outputable
 import FastString
 
@@ -146,8 +148,6 @@ data HsExpr id
                                      -- because in this context we never use
                                      -- the PatGuard or ParStmt variant
                 [LStmt id]           -- "do":one or more stmts
-                (LHsExpr id)         -- The body; the last expression in the
-                                     -- 'do' of [ body | ... ] in a list comp
                 PostTcType           -- Type of the whole expression
 
   | ExplicitList                -- syntactic list
@@ -449,7 +449,7 @@ ppr_expr (HsLet binds expr)
   = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
          hang (ptext (sLit "in"))  2 (ppr expr)]
 
-ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
+ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
 
 ppr_expr (ExplicitList _ exprs)
   = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
@@ -585,7 +585,7 @@ pprParendExpr expr
       HsPar {}          -> pp_as_was
       HsBracket {}      -> pp_as_was
       HsBracketOut _ [] -> pp_as_was
-      HsDo sc _ _ _
+      HsDo sc _ _
        | isListCompExpr sc -> pp_as_was
       _                    -> parens pp_as_was
 
@@ -840,51 +840,59 @@ type LStmtLR idL idR = Located (StmtLR idL idR)
 
 type Stmt id = StmtLR id id
 
--- The SyntaxExprs in here are used *only* for do-notation, which
--- has rebindable syntax.  Otherwise they are unused.
+-- The SyntaxExprs in here are used *only* for do-notation and monad
+-- comprehensions, which have rebindable syntax. Otherwise they are unused.
 data StmtLR idL idR
-  = BindStmt (LPat idL)
+  = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp, 
+    	      -- and (after the renamer) DoExpr, MDoExpr
+              -- Not used for GhciStmt, PatGuard, which scope over other stuff
+               (LHsExpr idR)
+               (SyntaxExpr idR)   -- The return operator, used only for MonadComp
+	       		   	  -- For ListComp, PArrComp, we use the baked-in 'return'
+				  -- For DoExpr, MDoExpr, we don't appply a 'return' at all
+	       		   	  -- See Note [Monad Comprehensions]
+  | BindStmt (LPat idL)
              (LHsExpr idR)
-             (SyntaxExpr idR) -- The (>>=) operator
+             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
              (SyntaxExpr idR) -- The fail operator
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
   | ExprStmt (LHsExpr idR)     -- See Note [ExprStmt]
              (SyntaxExpr idR) -- The (>>) operator
+             (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
+                              -- See notes [Monad Comprehensions]
              PostTcType       -- Element type of the RHS (used for arrows)
 
   | LetStmt  (HsLocalBindsLR idL idR)
 
-  -- ParStmts only occur in a list comprehension
+  -- ParStmts only occur in a list/monad comprehension
   | ParStmt  [([LStmt idL], [idR])]
-  -- After renaming, the ids are the binders bound by the stmts and used
-  -- after them
-
-  -- "qs, then f by e" ==> TransformStmt qs binders f (Just e)
-  -- "qs, then f"      ==> TransformStmt qs binders f Nothing
-  | TransformStmt 
-         [LStmt idL]	-- Stmts are the ones to the left of the 'then'
-
-         [idR] 		-- After renaming, the IDs are the binders occurring 
-		        -- within this transform statement that are used after it
-
-         (LHsExpr idR)		-- "then f"
-
-         (Maybe (LHsExpr idR))	-- "by e" (optional)
-
-  | GroupStmt 
-         [LStmt idL]      -- Stmts to the *left* of the 'group'
-	 	       	  -- which generates the tuples to be grouped
-
-         [(idR, idR)]	  -- See Note [GroupStmt binder map]
+             (SyntaxExpr idR)           -- Polymorphic `mzip` for monad comprehensions
+             (SyntaxExpr idR)           -- The `>>=` operator
+             (SyntaxExpr idR)           -- Polymorphic `return` operator
+	     		 		-- with type (forall a. a -> m a)
+                                        -- See notes [Monad Comprehensions]
+  	    -- After renaming, the ids are the binders 
+  	    -- bound by the stmts and used after themp
+
+  | TransStmt {
+      trS_form  :: TransForm,
+      trS_stmts :: [LStmt idL],      -- Stmts to the *left* of the 'group'
+	            	              -- which generates the tuples to be grouped
+
+      trS_bndrs :: [(idR, idR)],     -- See Note [TransStmt binder map]
 				
-         (Maybe (LHsExpr idR)) 	-- "by e" (optional)
+      trS_using :: LHsExpr idR,
+      trS_by :: Maybe (LHsExpr idR), 	-- "by e" (optional)
+	-- Invariant: if trS_form = GroupBy, then grp_by = Just e
 
-         (Either		-- "using f"
-             (LHsExpr idR)	--   Left f  => explicit "using f"
-             (SyntaxExpr idR))	--   Right f => implicit; filled in with 'groupWith'
-							
+      trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for 
+                                       -- the inner monad comprehensions
+      trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator
+      trS_fmap :: SyntaxExpr idR      -- The polymorphic 'fmap' function for desugaring
+      		   	      	       -- Only for 'group' forms
+    }                                  -- See Note [Monad Comprehensions]
 
   -- Recursive statement (see Note [How RecStmt works] below)
   | RecStmt
@@ -915,20 +923,44 @@ data StmtLR idL idR
                                      -- because the Id may be *polymorphic*, but
                                      -- the returned thing has to be *monomorphic*, 
 				     -- so they may be type applications
+
+      , recS_ret_ty :: PostTcType    -- The type of of do { stmts; return (a,b,c) }
+      		       		     -- With rebindable syntax the type might not
+				     -- be quite as simple as (m (tya, tyb, tyc)).
       }
   deriving (Data, Typeable)
+
+data TransForm		-- The 'f' below is the 'using' function, 'e' is the by function
+  = ThenForm		-- then f          or    then f by e
+  | GroupFormU		-- group using f   or    group using f by e
+  | GroupFormB    	-- group by e  
+      -- In the GroupByFormB, trS_using is filled in with
+      --    'groupWith' (list comprehensions) or 
+      --    'groupM' (monad comprehensions)
+  deriving (Data, Typeable)
 \end{code}
 
-Note [GroupStmt binder map]
+Note [The type of bind in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Stmts, notably BindStmt, keep the (>>=) bind operator.  
+We do NOT assume that it has type  
+    (>>=) :: m a -> (a -> m b) -> m b
+In some cases (see Trac #303, #1537) it might have a more 
+exotic type, such as
+    (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+So we must be careful not to make assumptions about the type.
+In particular, the monad may not be uniform throughout.
+
+Note [TransStmt binder map]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The [(idR,idR)] in a GroupStmt behaves as follows:
+The [(idR,idR)] in a TransStmt behaves as follows:
 
   * Before renaming: []
 
   * After renaming: 
     	  [ (x27,x27), ..., (z35,z35) ]
     These are the variables 
-        bound by the stmts to the left of the 'group'
+       bound by the stmts to the left of the 'group'
        and used either in the 'by' clause, 
                 or     in the stmts following the 'group'
     Each item is a pair of identical variables.
@@ -962,7 +994,13 @@ depends on the context.  Consider the following contexts:
                 E :: Bool
           Translation: if E then fail else ...
 
-Array comprehensions are handled like list comprehensions -=chak
+        A monad comprehension of type (m res_ty)
+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        * ExprStmt E Bool:   [ .. | .... E ]
+                E :: Bool
+          Translation: guard E >> ...
+
+Array comprehensions are handled like list comprehensions.
 
 Note [How RecStmt works]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1003,23 +1041,60 @@ A (RecStmt stmts) types as if you had written
 where v1..vn are the later_ids
       r1..rm are the rec_ids
 
+Note [Monad Comprehensions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Monad comprehensions require separate functions like 'return' and
+'>>=' for desugaring. These functions are stored in the statements
+used in monad comprehensions. For example, the 'return' of the 'LastStmt'
+expression is used to lift the body of the monad comprehension:
+
+  [ body | stmts ]
+   =>
+  stmts >>= \bndrs -> return body
+
+In transform and grouping statements ('then ..' and 'then group ..') the
+'return' function is required for nested monad comprehensions, for example:
+
+  [ body | stmts, then f, rest ]
+   =>
+  f [ env | stmts ] >>= \bndrs -> [ body | rest ]
+
+ExprStmts require the 'Control.Monad.guard' function for boolean
+expressions:
+
+  [ body | exp, stmts ]
+   =>
+  guard exp >> [ body | stmts ]
+
+Grouping/parallel statements require the 'Control.Monad.Group.groupM' and
+'Control.Monad.Zip.mzip' functions:
+
+  [ body | stmts, then group by e, rest]
+   =>
+  groupM [ body | stmts ] >>= \bndrs -> [ body | rest ]
+
+  [ body | stmts1 | stmts2 | .. ]
+   =>
+  mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body
+
+In any other context than 'MonadComp', the fields for most of these
+'SyntaxExpr's stay bottom.
+
 
 \begin{code}
 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
     ppr stmt = pprStmt stmt
 
 pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
+pprStmt (LastStmt expr _)         = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
 pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
 pprStmt (LetStmt binds)           = hsep [ptext (sLit "let"), pprBinds binds]
-pprStmt (ExprStmt expr _ _)       = ppr expr
-pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
+pprStmt (ExprStmt expr _ _ _)     = ppr expr
+pprStmt (ParStmt stmtss _ _ _)    = hsep (map doStmts stmtss)
   where doStmts stmts = ptext (sLit "| ") <> ppr stmts
 
-pprStmt (TransformStmt stmts bndrs using by)
-  = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
-
-pprStmt (GroupStmt stmts _ by using) 
-  = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+  = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form])
 
 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
                  , recS_later_ids = later_ids })
@@ -1034,40 +1109,47 @@ pprTransformStmt bndrs using by
         , nest 2 (ppr using)
         , nest 2 (pprBy by)]
 
-pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
-                                  -> Either (LHsExpr id) (SyntaxExpr is)
+pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id)
+                                  -> LHsExpr id -> TransForm
 				  -> SDoc
-pprGroupStmt by using 
-  = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
-  where
-    ppr_using (Right _) = empty
-    ppr_using (Left e)  = ptext (sLit "using") <+> ppr e
+pprTransStmt by using ThenForm
+  = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
+pprTransStmt by _ GroupFormB
+  = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ]
+pprTransStmt by using GroupFormU
+  = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
 
 pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
 pprBy Nothing  = empty
 pprBy (Just e) = ptext (sLit "by") <+> ppr e
 
-pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr      stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
-pprDo GhciStmt    stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
-pprDo MDoExpr     stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
-pprDo ListComp    stmts body = brackets    $ pprComp stmts body
-pprDo PArrComp    stmts body = pa_brackets $ pprComp stmts body
-pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
-
-ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
+pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
+pprDo DoExpr      stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
+pprDo GhciStmt    stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
+pprDo ArrowExpr   stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
+pprDo MDoExpr     stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
+pprDo ListComp    stmts = brackets    $ pprComp stmts
+pprDo PArrComp    stmts = pa_brackets $ pprComp stmts
+pprDo MonadComp   stmts = brackets    $ pprComp stmts
+pprDo _           _     = panic "pprDo" -- PatGuard, ParStmtCxt
+
+ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc
 -- Print a bunch of do stmts, with explicit braces and semicolons,
 -- so that we are not vulnerable to layout bugs
-ppr_do_stmts stmts body
-  = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body])
+ppr_do_stmts stmts 
+  = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
            <+> rbrace
 
 ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
 ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
 
-pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-pprComp quals body	  -- Prints:  body | qual1, ..., qualn 
-  = hang (ppr body <+> char '|') 2 (interpp'SP quals)
+pprComp :: OutputableBndr id => [LStmt id] -> SDoc
+pprComp quals	  -- Prints:  body | qual1, ..., qualn 
+  | not (null quals)
+  , L _ (LastStmt body _) <- last quals
+  = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals))
+  | otherwise
+  = pprPanic "pprComp" (interpp'SP quals)
 \end{code}
 
 %************************************************************************
@@ -1185,26 +1267,35 @@ data HsMatchContext id  -- Context of a Match
 
 data HsStmtContext id
   = ListComp
-  | DoExpr
-  | GhciStmt				 -- A command-line Stmt in GHCi pat <- rhs
-  | MDoExpr                              -- Recursive do-expression
+  | MonadComp
   | PArrComp                             -- Parallel array comprehension
+
+  | DoExpr				 -- do { ... }
+  | MDoExpr                              -- mdo { ... }  ie recursive do-expression 
+  | ArrowExpr				 -- do-notation in an arrow-command context
+
+  | GhciStmt				 -- A command-line Stmt in GHCi pat <- rhs
   | PatGuard (HsMatchContext id)         -- Pattern guard for specified thing
   | ParStmtCtxt (HsStmtContext id)       -- A branch of a parallel stmt
-  | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
+  | TransStmtCtxt (HsStmtContext id)     -- A branch of a transform stmt
   deriving (Data, Typeable)
 \end{code}
 
 \begin{code}
-isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr  = True
-isDoExpr MDoExpr = True
-isDoExpr _       = False
-
 isListCompExpr :: HsStmtContext id -> Bool
-isListCompExpr ListComp = True
-isListCompExpr PArrComp = True
-isListCompExpr _        = False
+-- Uses syntax [ e | quals ]
+isListCompExpr ListComp  	 = True
+isListCompExpr PArrComp  	 = True
+isListCompExpr MonadComp 	 = True  
+isListCompExpr (ParStmtCtxt c)   = isListCompExpr c
+isListCompExpr (TransStmtCtxt c) = isListCompExpr c
+isListCompExpr _                 = False
+
+isMonadCompExpr :: HsStmtContext id -> Bool
+isMonadCompExpr MonadComp            = True
+isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr _                    = False
 \end{code}
 
 \begin{code}
@@ -1241,33 +1332,41 @@ pprMatchContextNoun ProcExpr        = ptext (sLit "arrow abstraction")
 pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
                                       $$ pprStmtContext ctxt
 
-pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+-----------------
+pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+pprAStmtContext ctxt = article <+> pprStmtContext ctxt
+  where
+    pp_an = ptext (sLit "an")
+    pp_a  = ptext (sLit "a")
+    article = case ctxt of
+                  MDoExpr  -> pp_an
+                  PArrComp -> pp_an
+		  GhciStmt -> pp_an
+                  _        -> pp_a
+
+
+-----------------
+pprStmtContext GhciStmt        = ptext (sLit "interactive GHCi command")
+pprStmtContext DoExpr          = ptext (sLit "'do' block")
+pprStmtContext MDoExpr         = ptext (sLit "'mdo' block")
+pprStmtContext ArrowExpr       = ptext (sLit "'do' block in an arrow command")
+pprStmtContext ListComp        = ptext (sLit "list comprehension")
+pprStmtContext MonadComp       = ptext (sLit "monad comprehension")
+pprStmtContext PArrComp        = ptext (sLit "array comprehension")
+pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt
+
+-- Drop the inner contexts when reporting errors, else we get
+--     Unexpected transform statement
+--     in a transformed branch of
+--          transformed branch of
+--          transformed branch of monad comprehension
 pprStmtContext (ParStmtCtxt c)
- = sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
-pprStmtContext (TransformStmtCtxt c)
- = sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
-pprStmtContext (PatGuard ctxt)
- = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
-pprStmtContext GhciStmt        = ptext (sLit "an interactive GHCi command")
-pprStmtContext DoExpr          = ptext (sLit "a 'do' expression")
-pprStmtContext MDoExpr         = ptext (sLit "an 'mdo' expression")
-pprStmtContext ListComp        = ptext (sLit "a list comprehension")
-pprStmtContext PArrComp        = ptext (sLit "an array comprehension")
-
-{-
-pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt      = ptext (sLit "the body of a case alternative")
-pprMatchRhsContext PatBindRhs   = ptext (sLit "the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr   = ptext (sLit "the body of a lambda")
-pprMatchRhsContext ProcExpr     = ptext (sLit "the body of a proc")
-pprMatchRhsContext other        = panic "pprMatchRhsContext"    -- RecUpd, StmtCtxt
-
--- Used for the result statement of comprehension
--- e.g. the 'e' in      [ e | ... ]
---      or the 'r' in   f x = r
-pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
-pprStmtResultContext other           = ptext (sLit "the result of") <+> pprStmtContext other
--}
+ | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
+ | otherwise          = pprStmtContext c
+pprStmtContext (TransStmtCtxt c)
+ | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
+ | otherwise          = pprStmtContext c
+
 
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
@@ -1278,14 +1377,16 @@ matchContextErrString RecUpd                     = ptext (sLit "record update")
 matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
 matchContextErrString ProcExpr                   = ptext (sLit "proc")
 matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime
-matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (PatGuard _))    = ptext (sLit "pattern guard")
-matchContextErrString (StmtCtxt GhciStmt)        = ptext (sLit "interactive GHCi command")
-matchContextErrString (StmtCtxt DoExpr)          = ptext (sLit "'do' expression")
-matchContextErrString (StmtCtxt MDoExpr)         = ptext (sLit "'mdo' expression")
-matchContextErrString (StmtCtxt ListComp)        = ptext (sLit "list comprehension")
-matchContextErrString (StmtCtxt PArrComp)        = ptext (sLit "array comprehension")
+matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _))      = ptext (sLit "pattern guard")
+matchContextErrString (StmtCtxt GhciStmt)          = ptext (sLit "interactive GHCi command")
+matchContextErrString (StmtCtxt DoExpr)            = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt ArrowExpr)         = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt MDoExpr)           = ptext (sLit "'mdo' block")
+matchContextErrString (StmtCtxt ListComp)          = ptext (sLit "list comprehension")
+matchContextErrString (StmtCtxt MonadComp)         = ptext (sLit "monad comprehension")
+matchContextErrString (StmtCtxt PArrComp)          = ptext (sLit "array comprehension")
 \end{code}
 
 \begin{code}
@@ -1296,11 +1397,16 @@ pprMatchInCtxt ctxt match  = hang (ptext (sLit "In") <+> pprMatchContext ctxt <>
 
 pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
    	       => HsStmtContext idL -> StmtLR idL idR -> SDoc
-pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
-		    	  4 (ppr_stmt stmt)
+pprStmtInCtxt ctxt (LastStmt e _)
+  | isListCompExpr ctxt      -- For [ e | .. ], do not mutter about "stmts"
+  = hang (ptext (sLit "In the expression:")) 2 (ppr e)
+
+pprStmtInCtxt ctxt stmt 
+  = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon)
+       2 (ppr_stmt stmt)
   where
     -- For Group and Transform Stmts, don't print the nested stmts!
-    ppr_stmt (GroupStmt _ _ by using)         = pprGroupStmt by using
-    ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by
-    ppr_stmt stmt                             = pprStmt stmt
+    ppr_stmt (TransStmt { trS_by = by, trS_using = using
+                        , trS_form = form }) = pprTransStmt by using form
+    ppr_stmt stmt = pprStmt stmt
 \end{code}
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index dd24aed..5015999 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -6,12 +6,6 @@
 HsImpExp: Abstract syntax: imports, exports, interfaces
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module HsImpExp where
@@ -103,6 +97,7 @@ ieName (IEVar n) 	 = n
 ieName (IEThingAbs  n)   = n
 ieName (IEThingWith n _) = n
 ieName (IEThingAll  n)   = n
+ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE a -> [a]
 ieNames (IEVar            n   ) = [n]
@@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where
     ppr (IEThingAll	thing)	= hcat [ppr thing, text "(..)"]
     ppr (IEThingWith thing withs)
 	= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
-    ppr (IEModuleContents mod)
-	= ptext (sLit "module") <+> ppr mod
+    ppr (IEModuleContents mod')
+	= ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
     ppr (IEDoc doc)             = ppr doc
     ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index 0874dda..2cda103 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -12,7 +12,8 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import HsTypes (PostTcType)
+import BasicTypes ( FractionalLit(..) )
+import HsTypes  ( PostTcType )
 import Type	( Type )
 import Outputable
 import FastString
@@ -40,10 +41,10 @@ data HsLit
   | HsWordPrim	    Integer		-- Unboxed Word
   | HsInteger	    Integer  Type	-- Genuinely an integer; arises only from TRANSLATION
 					-- 	(overloaded literals are done with HsOverLit)
-  | HsRat	    Rational Type	-- Genuinely a rational; arises only from TRANSLATION
+  | HsRat	    FractionalLit Type	-- Genuinely a rational; arises only from TRANSLATION
 					-- 	(overloaded literals are done with HsOverLit)
-  | HsFloatPrim	    Rational		-- Unboxed Float
-  | HsDoublePrim    Rational		-- Unboxed Double
+  | HsFloatPrim	    FractionalLit	-- Unboxed Float
+  | HsDoublePrim    FractionalLit	-- Unboxed Double
   deriving (Data, Typeable)
 
 instance Eq HsLit where
@@ -63,15 +64,14 @@ instance Eq HsLit where
 data HsOverLit id 	-- An overloaded literal
   = OverLit {
 	ol_val :: OverLitVal, 
-	ol_rebindable :: Bool,		-- True <=> rebindable syntax
-					-- False <=> standard syntax
+	ol_rebindable :: Bool,		-- Note [ol_rebindable]
 	ol_witness :: SyntaxExpr id,	-- Note [Overloaded literal witnesses]
 	ol_type :: PostTcType }
   deriving (Data, Typeable)
 
 data OverLitVal
   = HsIntegral   !Integer   	-- Integer-looking literals;
-  | HsFractional !Rational   	-- Frac-looking literals
+  | HsFractional !FractionalLit	-- Frac-looking literals
   | HsIsString   !FastString 	-- String-looking literals
   deriving (Data, Typeable)
 
@@ -79,6 +79,19 @@ overLitType :: HsOverLit a -> Type
 overLitType = ol_type
 \end{code}
 
+Note [ol_rebindable]
+~~~~~~~~~~~~~~~~~~~~
+The ol_rebindable field is True if this literal is actually 
+using rebindable syntax.  Specifically:
+
+  False iff ol_witness is the standard one
+  True  iff ol_witness is non-standard
+
+Equivalently it's True if
+  a) RebindableSyntax is on
+  b) the witness for fromInteger/fromRational/fromString
+     that happens to be in scope isn't the standard one
+
 Note [Overloaded literal witnesses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 *Before* type checking, the SyntaxExpr in an HsOverLit is the
@@ -89,7 +102,7 @@ This witness should replace the literal.
 
 This dual role is unusual, because we're replacing 'fromInteger' with 
 a call to fromInteger.  Reason: it allows commoning up of the fromInteger
-calls, which wouldn't be possible if the desguarar made the application
+calls, which wouldn't be possible if the desguarar made the application.
 
 The PostTcType in each branch records the type the overload literal is
 found to have.
@@ -130,9 +143,9 @@ instance Outputable HsLit where
     ppr (HsStringPrim s) = pprHsString s <> char '#'
     ppr (HsInt i)	 = integer i
     ppr (HsInteger i _)	 = integer i
-    ppr (HsRat f _)	 = rational f
-    ppr (HsFloatPrim f)	 = rational f <> char '#'
-    ppr (HsDoublePrim d) = rational d <> text "##"
+    ppr (HsRat f _)	 = ppr f
+    ppr (HsFloatPrim f)	 = ppr f <> char '#'
+    ppr (HsDoublePrim d) = ppr d <> text "##"
     ppr (HsIntPrim i)	 = integer i  <> char '#'
     ppr (HsWordPrim w)	 = integer w  <> text "##"
 
@@ -143,6 +156,6 @@ instance OutputableBndr id => Outputable (HsOverLit id) where
 
 instance Outputable OverLitVal where
   ppr (HsIntegral i)   = integer i 
-  ppr (HsFractional f) = rational f
+  ppr (HsFractional f) = ppr f
   ppr (HsIsString s)   = pprHsString s
 \end{code}
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 78b5887..7fb5f72 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -24,7 +24,7 @@ module HsPat (
 
         isBangHsBind, isLiftedPatBind,
         isBangLPat, hsPatNeedsParens,
-	isIrrefutableHsPat,
+        isIrrefutableHsPat,
 
 	pprParendLPat
     ) where
@@ -65,7 +65,7 @@ data Pat id
 	-- support hsPatType :: Pat Id -> Type
 
   | VarPat	id			-- Variable
-  | LazyPat	(LPat id)		-- Lazy pattern
+  | LazyPat     (LPat id)               -- Lazy pattern
   | AsPat	(Located id) (LPat id)  -- As pattern
   | ParPat      (LPat id)		-- Parenthesised pattern
   | BangPat	(LPat id)		-- Bang pattern
@@ -122,7 +122,9 @@ data Pat id
   | LitPat	    HsLit		-- Used for *non-overloaded* literal patterns:
 					-- Int#, Char#, Int, Char, String, etc.
 
-  | NPat	    (HsOverLit id)		-- ALWAYS positive
+  | NPat		-- Used for all overloaded literals, 
+    			-- including overloaded strings with -XOverloadedStrings
+                    (HsOverLit id)		-- ALWAYS positive
 		    (Maybe (SyntaxExpr id))	-- Just (Name of 'negate') for negative
 						-- patterns, Nothing otherwise
 		    (SyntaxExpr id)		-- Equality checker, of type t->t->Bool
@@ -132,12 +134,6 @@ data Pat id
 		    (SyntaxExpr id)	-- (>=) function, of type t->t->Bool
 		    (SyntaxExpr id)	-- Name of '-' (see RnEnv.lookupSyntaxName)
 
-	------------ Generics ---------------
-  | TypePat	    (LHsType id)	-- Type pattern for generic definitions
-                                        -- e.g  f{| a+b |} = ...
-                                        -- These show up only in class declarations,
-                                        -- and should be a top-level pattern
-
 	------------ Pattern type signatures ---------------
   | SigPatIn	    (LPat id)		-- Pattern with a type signature
 		    (LHsType id)
@@ -281,7 +277,6 @@ pprPat (NPat l Nothing  _)  = ppr l
 pprPat (NPat l (Just _) _)  = char '-' <> ppr l
 pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
 pprPat (QuasiQuotePat qq)   = ppr qq
-pprPat (TypePat ty)	    = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
 pprPat (CoPat co pat _)	    = pprHsWrapper (ppr pat) co
 pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
 pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
@@ -439,7 +434,6 @@ isIrrefutableHsPat pat
 
     go1 (QuasiQuotePat {}) = urk pat	-- Gotten rid of by renamer, before
 					-- isIrrefutablePat is called
-    go1 (TypePat {})       = urk pat
 
     urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
 
@@ -463,7 +457,6 @@ hsPatNeedsParens (LitPat {})   	     = False
 hsPatNeedsParens (NPat {})	     = False
 hsPatNeedsParens (NPlusKPat {})      = True
 hsPatNeedsParens (QuasiQuotePat {})  = True
-hsPatNeedsParens (TypePat {})        = False
 
 conPatNeedsParens :: HsConDetails a b -> Bool
 conPatNeedsParens (PrefixCon args) = not (null args)
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index def44c5..7159540 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -170,8 +170,6 @@ data HsType name
 	-- interface files smaller), so when printing a HsType we may need to
 	-- add parens.  
 
-  | HsNumTy             Integer		-- Generics only
-
   | HsPredTy		(HsPred name)	-- Only used in the type of an instance
 					-- declaration, eg.  Eq [a] -> Eq a
 					--			       ^^^^
@@ -443,7 +441,6 @@ ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)	     = pabrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
-ppr_mono_ty _    (HsNumTy n)         = integer n  -- generics only
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 13f3cd7..cc57e05 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -19,15 +19,15 @@ module HsUtils(
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
-  mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
-  coiToHsWrapper, mkHsLams, mkHsDictLet,
-  mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
+  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
+  coToHsWrapper, mkHsDictLet, mkHsLams,
+  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
 
-  -- Bindigns
+  -- Bindings
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, 
 
   -- Literals
@@ -42,8 +42,8 @@ module HsUtils(
   nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, 
 
   -- Stmts
-  mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
-  mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, 
+  mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
+  emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, 
   emptyRecStmt, mkRecStmt, 
 
   -- Template Haskell
@@ -77,14 +77,13 @@ import HsLit
 import RdrName
 import Var
 import Coercion
-import Type
+import TypeRep
 import DataCon
 import Name
 import NameSet
 import BasicTypes
 import SrcLoc
 import FastString
-import Outputable
 import Util
 import Bag
 
@@ -137,25 +136,25 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 		 | otherwise	       = HsWrap co_fn e
 
-mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI (IdCo _) e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo (Refl _) e = e
+mkHsWrapCo co       e = mkHsWrap (WpCast co) e
 
-mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
-mkLHsWrapCoI (IdCo _) e         = e
-mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo (Refl _) e         = e
+mkLHsWrapCo co       (L loc e) = L loc (mkHsWrap (WpCast co) e)
 
-coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper (IdCo _) = idHsWrapper
-coiToHsWrapper (ACo co) = WpCast co
+coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper (Refl _) = idHsWrapper
+coToHsWrapper co       = WpCast co
 
 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
 		       | otherwise	     = CoPat co_fn p ty
 
-mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkHsWrapPatCoI (IdCo _) pat _  = pat
-mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo (Refl _) pat _  = pat
+mkHsWrapPatCo co       pat ty = CoPat (WpCast co) pat ty
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
@@ -188,16 +187,15 @@ mkSimpleHsAlt pat expr
 -- See RnEnv.lookupSyntaxName
 
 mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
-mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
 mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
-mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
+mkHsDo         :: HsStmtContext Name -> [LStmt id] -> HsExpr id
+mkHsComp       :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
 
 mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
 mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
 
-mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
-mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
-
+mkLastStmt :: LHsExpr idR -> StmtLR idL idR
 mkExprStmt :: LHsExpr idR -> StmtLR idL idR
 mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
 
@@ -212,7 +210,10 @@ mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
 noRebindableInfo :: Bool
 noRebindableInfo = error "noRebindableInfo" 	-- Just another placeholder; 
 
-mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
+mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
+  where
+    last_stmt = L (getLoc expr) $ mkLastStmt expr
 
 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
@@ -220,24 +221,32 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
 mkNPat lit neg     = NPat lit neg noSyntaxExpr
 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 
-mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
-mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
-
+mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
+mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
 mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 
-mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)    
-mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
-mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)    
-
-mkExprStmt expr	    = ExprStmt expr noSyntaxExpr placeHolderType
+emptyTransStmt :: StmtLR idL idR
+emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] 
+                           , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
+                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
+                           , trS_fmap = noSyntaxExpr }
+mkTransformStmt   ss u    = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
+mkTransformByStmt ss u b  = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
+mkGroupByStmt      ss b   = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b }
+mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u }
+mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss
+                                           , trS_by = Just b, trS_using = u }
+
+mkLastStmt expr	    = LastStmt expr noSyntaxExpr
+mkExprStmt expr	    = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 
 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 		       , recS_bind_fn = noSyntaxExpr
-                       , recS_rec_rets = [] }
+                       , recS_rec_rets = [], recS_ret_ty = placeHolderType }
 
 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 
@@ -327,8 +336,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 nlWildPat :: LPat id
 nlWildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
 
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
-nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 
 nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
@@ -496,12 +505,12 @@ collectStmtBinders :: StmtLR idL idR -> [idL]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _)     = []
-collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
+collectStmtBinders (ExprStmt {})        = []
+collectStmtBinders (LastStmt {})        = []
+collectStmtBinders (ParStmt xs _ _ _)   = collectLStmtsBinders
                                         $ concatMap fst xs
-collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
 
 
 ----------------- Patterns --------------------------
@@ -538,7 +547,6 @@ collect_lpat (L _ pat) bndrs
     go (SigPatIn pat _)	 	  = collect_lpat pat bndrs
     go (SigPatOut pat _)	  = collect_lpat pat bndrs
     go (QuasiQuotePat _)          = bndrs
-    go (TypePat _)                = bndrs
     go (CoPat _ pat _)            = go pat
 \end{code}
 
@@ -642,12 +650,12 @@ lStmtsImplicits = hs_lstmts
     
     hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
     hs_stmt (LetStmt binds)      = hs_local_binds binds
-    hs_stmt (ExprStmt _ _ _)     = emptyNameSet
-    hs_stmt (ParStmt xs)         = hs_lstmts $ concatMap fst xs
+    hs_stmt (ExprStmt {})        = emptyNameSet
+    hs_stmt (LastStmt {})        = emptyNameSet
+    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts $ concatMap fst xs
     
-    hs_stmt (TransformStmt stmts _ _ _)   = hs_lstmts stmts
-    hs_stmt (GroupStmt     stmts _ _ _)   = hs_lstmts stmts
-    hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
+    hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
     
     hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
     hs_local_binds (HsIPBinds _)         = emptyNameSet
@@ -655,11 +663,15 @@ lStmtsImplicits = hs_lstmts
 
 hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
 hsValBindsImplicits (ValBindsOut binds _)
-  = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+  = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
+hsValBindsImplicits (ValBindsIn binds _) 
+  = lhsBindsImplicits binds
+
+lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
+lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
   where
-    hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
-    hs_bind _ = emptyNameSet
-hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+    lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
+    lhs_bind _ = emptyNameSet
 
 lPatImplicits :: LPat Name -> NameSet
 lPatImplicits = hs_lpat
@@ -714,7 +726,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
 
 collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
 collect_sig_pat (SigPatIn pat ty)  	acc = collect_sig_lpat pat (ty:acc)
-collect_sig_pat (TypePat ty)       	acc = ty:acc
 
 collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
 collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index ac21632..b3de3f4 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,4 +1,3 @@
-
 {-# OPTIONS_GHC -O #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -903,10 +902,11 @@ instance Binary IfaceType where
     put_ bh (IfaceTyConApp (IfaceAnyTc k) []) 	       = do { putByte bh 17; put_ bh k }
 
 	-- Generic cases
-
     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
     put_ bh (IfaceTyConApp tc tys) 	     = do { putByte bh 19; put_ bh tc; put_ bh tys }
 
+    put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
+
     get bh = do
 	    h <- getByte bh
 	    case h of
@@ -939,11 +939,11 @@ instance Binary IfaceType where
               17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
 
 	      18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
-	      _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+	      19  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+	      _  -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
 
 instance Binary IfaceTyCon where
 	-- Int,Char,Bool can't show up here because they can't not be saturated
-
    put_ bh IfaceIntTc  	      = putByte bh 1
    put_ bh IfaceBoolTc 	      = putByte bh 2
    put_ bh IfaceCharTc 	      = putByte bh 3
@@ -954,9 +954,9 @@ instance Binary IfaceTyCon where
    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
    put_ bh IfaceArgTypeKindTc      = putByte bh 10
-   put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
-   put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
-   put_ bh (IfaceAnyTc k)     = do { putByte bh 13; put_ bh k }
+   put_ bh (IfaceTupTc bx ar)  = do { putByte bh 11; put_ bh bx; put_ bh ar }
+   put_ bh (IfaceTc ext)       = do { putByte bh 12; put_ bh ext }
+   put_ bh (IfaceAnyTc k)      = do { putByte bh 13; put_ bh k }
 
    get bh = do
 	h <- getByte bh
@@ -973,7 +973,27 @@ instance Binary IfaceTyCon where
           10 -> return IfaceArgTypeKindTc
 	  11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 	  12 -> do { ext <- get bh; return (IfaceTc ext) }
-	  _  -> do { k <- get bh; return (IfaceAnyTc k) }
+	  _ -> do { k <- get bh; return (IfaceAnyTc k) }
+
+instance Binary IfaceCoCon where
+   put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
+   put_ bh IfaceReflCo         = putByte bh 1
+   put_ bh IfaceUnsafeCo       = putByte bh 2
+   put_ bh IfaceSymCo          = putByte bh 3
+   put_ bh IfaceTransCo        = putByte bh 4
+   put_ bh IfaceInstCo         = putByte bh 5
+   put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
+  
+   get bh = do
+	h <- getByte bh
+	case h of
+          0 -> do { n <- get bh; return (IfaceCoAx n) }
+	  1 -> return IfaceReflCo 
+	  2 -> return IfaceUnsafeCo
+	  3 -> return IfaceSymCo
+	  4 -> return IfaceTransCo
+	  5 -> return IfaceInstCo
+          _ -> do { d <- get bh; return (IfaceNthCo d) }
 
 instance Binary IfacePredType where
     put_ bh (IfaceClassP aa ab) = do
@@ -1013,50 +1033,50 @@ instance Binary IfaceExpr where
     put_ bh (IfaceType ab) = do
 	    putByte bh 1
 	    put_ bh ab
-    put_ bh (IfaceTuple ac ad) = do
+    put_ bh (IfaceCo ab) = do
 	    putByte bh 2
+	    put_ bh ab
+    put_ bh (IfaceTuple ac ad) = do
+	    putByte bh 3
 	    put_ bh ac
 	    put_ bh ad
     put_ bh (IfaceLam ae af) = do
-	    putByte bh 3
+	    putByte bh 4
 	    put_ bh ae
 	    put_ bh af
     put_ bh (IfaceApp ag ah) = do
-	    putByte bh 4
+	    putByte bh 5
 	    put_ bh ag
 	    put_ bh ah
--- gaw 2004
-    put_ bh (IfaceCase ai aj al ak) = do
-	    putByte bh 5
+    put_ bh (IfaceCase ai aj ak) = do
+	    putByte bh 6
 	    put_ bh ai
 	    put_ bh aj
--- gaw 2004
-            put_ bh al
 	    put_ bh ak
     put_ bh (IfaceLet al am) = do
-	    putByte bh 6
+	    putByte bh 7
 	    put_ bh al
 	    put_ bh am
     put_ bh (IfaceNote an ao) = do
-	    putByte bh 7
+	    putByte bh 8
 	    put_ bh an
 	    put_ bh ao
     put_ bh (IfaceLit ap) = do
-	    putByte bh 8
+	    putByte bh 9
 	    put_ bh ap
     put_ bh (IfaceFCall as at) = do
-	    putByte bh 9
+	    putByte bh 10
 	    put_ bh as
 	    put_ bh at
     put_ bh (IfaceExt aa) = do
-	    putByte bh 10
+	    putByte bh 11
 	    put_ bh aa
     put_ bh (IfaceCast ie ico) = do
-            putByte bh 11
+            putByte bh 12
             put_ bh ie
             put_ bh ico
     put_ bh (IfaceTick m ix) = do
-            putByte bh 12
+            putByte bh 13
             put_ bh m
             put_ bh ix
     get bh = do
@@ -1066,39 +1086,38 @@ instance Binary IfaceExpr where
 		      return (IfaceLcl aa)
 	      1 -> do ab <- get bh
 		      return (IfaceType ab)
-	      2 -> do ac <- get bh
+	      2 -> do ab <- get bh
+		      return (IfaceCo ab)
+	      3 -> do ac <- get bh
 		      ad <- get bh
 		      return (IfaceTuple ac ad)
-	      3 -> do ae <- get bh
+	      4 -> do ae <- get bh
 		      af <- get bh
 		      return (IfaceLam ae af)
-	      4 -> do ag <- get bh
+	      5 -> do ag <- get bh
 		      ah <- get bh
 		      return (IfaceApp ag ah)
-	      5 -> do ai <- get bh
+	      6 -> do ai <- get bh
 		      aj <- get bh
--- gaw 2004
-                      al <- get bh                   
 		      ak <- get bh
--- gaw 2004
-		      return (IfaceCase ai aj al ak)
-	      6 -> do al <- get bh
+		      return (IfaceCase ai aj ak)
+	      7 -> do al <- get bh
 		      am <- get bh
 		      return (IfaceLet al am)
-	      7 -> do an <- get bh
+	      8 -> do an <- get bh
 		      ao <- get bh
 		      return (IfaceNote an ao)
-	      8 -> do ap <- get bh
+	      9 -> do ap <- get bh
 		      return (IfaceLit ap)
-	      9 -> do as <- get bh
-		      at <- get bh
-		      return (IfaceFCall as at)
-	      10 -> do aa <- get bh
+	      10 -> do as <- get bh
+		       at <- get bh
+		       return (IfaceFCall as at)
+	      11 -> do aa <- get bh
 		       return (IfaceExt aa)
-              11 -> do ie <- get bh
+              12 -> do ie <- get bh
                        ico <- get bh
                        return (IfaceCast ie ico)
-              12 -> do m <- get bh
+              13 -> do m <- get bh
                        ix <- get bh
                        return (IfaceTick m ix)
               _ -> panic ("get IfaceExpr " ++ show h)
@@ -1295,7 +1314,7 @@ instance Binary IfaceDecl where
 	    put_ bh idinfo
     put_ _ (IfaceForeign _ _) = 
 	error "Binary.put_(IfaceDecl): IfaceForeign"
-    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
 	    putByte bh 2
 	    put_ bh (occNameFS a1)
 	    put_ bh a2
@@ -1304,7 +1323,6 @@ instance Binary IfaceDecl where
 	    put_ bh a5
 	    put_ bh a6
 	    put_ bh a7
-	    put_ bh a8
     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
 	    putByte bh 3
 	    put_ bh (occNameFS a1)
@@ -1340,9 +1358,8 @@ instance Binary IfaceDecl where
 		    a5 <- get bh
 		    a6 <- get bh
 		    a7 <- get bh
-		    a8 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-		    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+		    return (IfaceData occ a2 a3 a4 a5 a6 a7)
 	      3 -> do
 		    a1 <- get bh
 		    a2 <- get bh
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e71eefe..eabe8c4 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -10,7 +10,8 @@ module BuildTyCl (
         buildDataCon,
 	TcMethInfo, buildClass,
 	mkAbstractTyConRhs, 
-	mkNewTyConRhs, mkDataTyConRhs
+	mkNewTyConRhs, mkDataTyConRhs, 
+        newImplicitBinder
     ) where
 
 #include "HsVersions.h"
@@ -59,13 +60,12 @@ buildAlgTyCon :: Name -> [TyVar]
 	      -> ThetaType		-- ^ Stupid theta
 	      -> AlgTyConRhs
 	      -> RecFlag
-	      -> Bool			-- ^ True <=> want generics functions
 	      -> Bool			-- ^ True <=> was declared in GADT syntax
               -> TyConParent
 	      -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
 	      -> TcRnIf m n TyCon
 
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
 	      parent mb_family
   | Just fam_inst_info <- mb_family
   = -- We need to tie a knot as the coercion of a data instance depends
@@ -74,11 +74,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
     fixM $ \ tycon_rec -> do 
     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
     ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
-		         fam_parent is_rec want_generics gadt_syn) }
+		         fam_parent is_rec gadt_syn) }
 
   | otherwise
   = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
-	               parent is_rec want_generics gadt_syn)
+	               parent is_rec gadt_syn)
   where
     kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 
@@ -100,8 +100,8 @@ mkFamInstParentInfo :: Name -> [TyVar]
 mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
   = do { -- Create the coercion
        ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-       ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
-                                        family instTys rep_tycon
+       ; let co_tycon = mkFamInstCo co_tycon_name tvs
+                                    family instTys rep_tycon
        ; return $ FamInstTyCon family instTys co_tycon }
     
 ------------------------------------------------------
@@ -127,23 +127,15 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 --   because the latter is part of a knot, whereas the former is not.
 mkNewTyConRhs tycon_name tycon con 
   = do	{ co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
-              cocon_maybe | all_coercions || isRecursiveTyCon tycon 
-		          = Just co_tycon
-                	  | otherwise              
-                	  = Nothing
-	; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
+	; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
+	; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
 	; return (NewTyCon { data_con    = con, 
 		       	     nt_rhs      = rhs_ty,
 		       	     nt_etad_rhs = (etad_tvs, etad_rhs),
- 		       	     nt_co 	 = cocon_maybe } ) }
+ 		       	     nt_co 	 = co_tycon } ) }
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
   where
-        -- If all_coercions is True then we use coercions for all newtypes
-        -- otherwise we use coercions for recursive newtypes and look through
-        -- non-recursive newtypes
-    all_coercions = True
     tvs    = tyConTyVars tycon
     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
@@ -156,7 +148,7 @@ mkNewTyConRhs tycon_name tycon con
   	-- has a single argument (Foo a) that is a *type class*, so
 	-- dataConInstOrigArgTys returns [].
 
-    etad_tvs :: [TyVar]	-- Matched lazily, so that mkNewTypeCoercion can
+    etad_tvs :: [TyVar]	-- Matched lazily, so that mkNewTypeCo can
     etad_rhs :: Type	-- return a TyCon without pulling on rhs_ty
 			-- See Note [Tricky iface loop] in LoadIface
     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
@@ -229,8 +221,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 \begin{code}
-type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
-					     -- between tcClassSigs and buildClass
+type TcMethInfo = (Name, DefMethSpec, Type)  
+        -- A temporary intermediate, to communicate between 
+        -- tcClassSigs and buildClass.
 
 buildClass :: Bool		-- True <=> do not include unfoldings 
 				--	    on dict selectors
@@ -332,7 +325,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
     mk_op_item rec_clas (op_name, dm_spec, _) 
       = do { dm_info <- case dm_spec of
                           NoDM      -> return NoDefMeth
-                          GenericDM -> return GenDefMeth
+                          GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
+			  	          ; return (GenDefMeth dm_name) }
                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
 			  	          ; return (DefMeth dm_name) }
            ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 3eae7a3..49fded9 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -5,34 +5,34 @@
 
 \begin{code}
 module IfaceSyn (
-	module IfaceType,		-- Re-export all this
+        module IfaceType,
 
-	IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
-	IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
-	IfaceBinding(..), IfaceConAlt(..), 
-	IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
-	IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
-	IfaceInst(..), IfaceFamInst(..),
+        IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
+        IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
+        IfaceBinding(..), IfaceConAlt(..),
+        IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
+        IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+        IfaceInst(..), IfaceFamInst(..),
 
-	-- Misc
+        -- Misc
         ifaceDeclSubBndrs, visibleIfConDecls,
 
         -- Free Names
         freeNamesIfDecl, freeNamesIfRule,
 
-	-- Pretty printing
-	pprIfaceExpr, pprIfaceDeclHead 
+        -- Pretty printing
+        pprIfaceExpr, pprIfaceDeclHead
     ) where
 
 #include "HsVersions.h"
 
 import IfaceType
 import CoreSyn( DFunArg, dfunArgExprs )
-import PprCore()            -- Printing DFunArgs
+import PprCore()     -- Printing DFunArgs
 import Demand
 import Annotations
 import Class
-import NameSet 
+import NameSet
 import Name
 import CostCentre
 import Literal
@@ -48,74 +48,67 @@ infixl 3 &&&
 
 
 %************************************************************************
-%*									*
-		Data type declarations
-%*									*
+%*                                                                      *
+    Data type declarations
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-data IfaceDecl 
-  = IfaceId { ifName   	  :: OccName,
-	      ifType   	  :: IfaceType, 
-	      ifIdDetails :: IfaceIdDetails,
-	      ifIdInfo    :: IfaceIdInfo }
-
-  | IfaceData { ifName       :: OccName,	-- Type constructor
-		ifTyVars     :: [IfaceTvBndr],	-- Type variables
-		ifCtxt	     :: IfaceContext,	-- The "stupid theta"
-		ifCons	     :: IfaceConDecls,	-- Includes new/data info
-	        ifRec	     :: RecFlag,	-- Recursive or not?
-		ifGadtSyntax :: Bool,		-- True <=> declared using
-						-- GADT syntax 
-		ifGeneric    :: Bool,		-- True <=> generic converter
-						--          functions available
-    						-- We need this for imported
-    						-- data decls, since the
-    						-- imported modules may have
-    						-- been compiled with
-    						-- different flags to the
-    						-- current compilation unit 
+data IfaceDecl
+  = IfaceId { ifName      :: OccName,
+              ifType      :: IfaceType,
+              ifIdDetails :: IfaceIdDetails,
+              ifIdInfo    :: IfaceIdInfo }
+
+  | IfaceData { ifName       :: OccName,        -- Type constructor
+                ifTyVars     :: [IfaceTvBndr],  -- Type variables
+                ifCtxt       :: IfaceContext,   -- The "stupid theta"
+                ifCons       :: IfaceConDecls,  -- Includes new/data info
+                ifRec        :: RecFlag,        -- Recursive or not?
+                ifGadtSyntax :: Bool,           -- True <=> declared using
+                                                -- GADT syntax
                 ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
                                                 -- Just <=> instance of family
-                                                -- Invariant: 
+                                                -- Invariant:
                                                 --   ifCons /= IfOpenDataTyCon
                                                 --   for family instances
     }
 
-  | IfaceSyn  {	ifName    :: OccName,		-- Type constructor
-		ifTyVars  :: [IfaceTvBndr],	-- Type variables
-		ifSynKind :: IfaceKind,		-- Kind of the *rhs* (not of the tycon)
-		ifSynRhs  :: Maybe IfaceType,	-- Just rhs for an ordinary synonyn
-						-- Nothing for an open family
+  | IfaceSyn  { ifName    :: OccName,           -- Type constructor
+                ifTyVars  :: [IfaceTvBndr],     -- Type variables
+                ifSynKind :: IfaceKind,         -- Kind of the *rhs* (not of the tycon)
+                ifSynRhs  :: Maybe IfaceType,   -- Just rhs for an ordinary synonyn
+                                                -- Nothing for an open family
                 ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
                                                 -- Just <=> instance of family
                                                 -- Invariant: ifOpenSyn == False
                                                 --   for family instances
     }
 
-  | IfaceClass { ifCtxt    :: IfaceContext, 	-- Context...
-		 ifName    :: OccName,		-- Name of the class
-		 ifTyVars  :: [IfaceTvBndr],	-- Type variables
-		 ifFDs     :: [FunDep FastString], -- Functional dependencies
-		 ifATs	   :: [IfaceDecl],	-- Associated type families
-		 ifSigs    :: [IfaceClassOp],	-- Method signatures
-	         ifRec	   :: RecFlag		-- Is newtype/datatype associated with the class recursive?
+  | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
+                 ifName    :: OccName,          -- Name of the class
+                 ifTyVars  :: [IfaceTvBndr],    -- Type variables
+                 ifFDs     :: [FunDep FastString], -- Functional dependencies
+                 ifATs     :: [IfaceDecl],      -- Associated type families
+                 ifSigs    :: [IfaceClassOp],   -- Method signatures
+                 ifRec     :: RecFlag           -- Is newtype/datatype associated
+                                                --   with the class recursive?
     }
 
   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
                                                 -- beyond .NET
-		   ifExtName :: Maybe FastString }
+                   ifExtName :: Maybe FastString }
 
 data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-	-- Nothing    => no default method
-	-- Just False => ordinary polymorphic default method
-	-- Just True  => generic default method
+        -- Nothing    => no default method
+        -- Just False => ordinary polymorphic default method
+        -- Just True  => generic default method
 
 data IfaceConDecls
-  = IfAbstractTyCon		-- No info
-  | IfOpenDataTyCon		-- Open data family
-  | IfDataTyCon [IfaceConDecl]	-- data type decls
-  | IfNewTyCon  IfaceConDecl	-- newtype decls
+  = IfAbstractTyCon             -- No info
+  | IfOpenDataTyCon             -- Open data family
+  | IfDataTyCon [IfaceConDecl]  -- data type decls
+  | IfNewTyCon  IfaceConDecl    -- newtype decls
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls IfAbstractTyCon  = []
@@ -123,49 +116,49 @@ visibleIfConDecls IfOpenDataTyCon  = []
 visibleIfConDecls (IfDataTyCon cs) = cs
 visibleIfConDecls (IfNewTyCon c)   = [c]
 
-data IfaceConDecl 
+data IfaceConDecl
   = IfCon {
-	ifConOcc     :: OccName,   		-- Constructor name
-	ifConWrapper :: Bool,			-- True <=> has a wrapper
-	ifConInfix   :: Bool,			-- True <=> declared infix
-	ifConUnivTvs :: [IfaceTvBndr],		-- Universal tyvars
-	ifConExTvs   :: [IfaceTvBndr],		-- Existential tyvars
-	ifConEqSpec  :: [(OccName,IfaceType)],	-- Equality contraints
-	ifConCtxt    :: IfaceContext,		-- Non-stupid context
-	ifConArgTys  :: [IfaceType],		-- Arg types
-	ifConFields  :: [OccName],		-- ...ditto... (field labels)
-	ifConStricts :: [HsBang]}		-- Empty (meaning all lazy),
-						-- or 1-1 corresp with arg tys
-
-data IfaceInst 
-  = IfaceInst { ifInstCls  :: IfExtName,     		-- See comments with
-		ifInstTys  :: [Maybe IfaceTyCon],	-- the defn of Instance
-		ifDFun     :: IfExtName,     		-- The dfun
-		ifOFlag    :: OverlapFlag,		-- Overlap flag
-		ifInstOrph :: Maybe OccName }		-- See Note [Orphans]
-	-- There's always a separate IfaceDecl for the DFun, which gives 
-	-- its IdInfo with its full type and version number.
-	-- The instance declarations taken together have a version number,
-	-- and we don't want that to wobble gratuitously
-	-- If this instance decl is *used*, we'll record a usage on the dfun;
-	-- and if the head does not change it won't be used if it wasn't before
+        ifConOcc     :: OccName,                -- Constructor name
+        ifConWrapper :: Bool,                   -- True <=> has a wrapper
+        ifConInfix   :: Bool,                   -- True <=> declared infix
+        ifConUnivTvs :: [IfaceTvBndr],          -- Universal tyvars
+        ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
+        ifConEqSpec  :: [(OccName,IfaceType)],  -- Equality contraints
+        ifConCtxt    :: IfaceContext,           -- Non-stupid context
+        ifConArgTys  :: [IfaceType],            -- Arg types
+        ifConFields  :: [OccName],              -- ...ditto... (field labels)
+        ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
+                                                -- or 1-1 corresp with arg tys
+
+data IfaceInst
+  = IfaceInst { ifInstCls  :: IfExtName,                -- See comments with
+                ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
+                ifDFun     :: IfExtName,                -- The dfun
+                ifOFlag    :: OverlapFlag,              -- Overlap flag
+                ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
+        -- There's always a separate IfaceDecl for the DFun, which gives
+        -- its IdInfo with its full type and version number.
+        -- The instance declarations taken together have a version number,
+        -- and we don't want that to wobble gratuitously
+        -- If this instance decl is *used*, we'll record a usage on the dfun;
+        -- and if the head does not change it won't be used if it wasn't before
 
 data IfaceFamInst
   = IfaceFamInst { ifFamInstFam   :: IfExtName                -- Family tycon
-		 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
-		 , ifFamInstTyCon :: IfaceTyCon		 -- Instance decl
-		 }
+                 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
+                 , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
+                 }
 
 data IfaceRule
-  = IfaceRule { 
-	ifRuleName   :: RuleName,
-	ifActivation :: Activation,
-	ifRuleBndrs  :: [IfaceBndr],	-- Tyvars and term vars
-	ifRuleHead   :: IfExtName,   	-- Head of lhs
-	ifRuleArgs   :: [IfaceExpr],	-- Args of LHS
-	ifRuleRhs    :: IfaceExpr,
-	ifRuleAuto   :: Bool,
-	ifRuleOrph   :: Maybe OccName	-- Just like IfaceInst
+  = IfaceRule {
+        ifRuleName   :: RuleName,
+        ifActivation :: Activation,
+        ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
+        ifRuleHead   :: IfExtName,      -- Head of lhs
+        ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
+        ifRuleRhs    :: IfaceExpr,
+        ifRuleAuto   :: Bool,
+        ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
     }
 
 data IfaceAnnotation
@@ -187,80 +180,81 @@ data IfaceIdDetails
   | IfDFunId Int          -- Number of silent args
 
 data IfaceIdInfo
-  = NoInfo			-- When writing interface file without -O
-  | HasInfo [IfaceInfoItem]	-- Has info, and here it is
+  = NoInfo                      -- When writing interface file without -O
+  | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 
 -- Here's a tricky case:
 --   * Compile with -O module A, and B which imports A.f
 --   * Change function f in A, and recompile without -O
 --   * When we read in old A.hi we read in its IdInfo (as a thunk)
---	(In earlier GHCs we used to drop IdInfo immediately on reading,
---	 but we do not do that now.  Instead it's discarded when the
---	 ModIface is read into the various decl pools.)
+--      (In earlier GHCs we used to drop IdInfo immediately on reading,
+--       but we do not do that now.  Instead it's discarded when the
+--       ModIface is read into the various decl pools.)
 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
---	and so gives a new version.
+--      and so gives a new version.
 
 data IfaceInfoItem
-  = HsArity	 Arity
+  = HsArity      Arity
   | HsStrictness StrictSig
   | HsInline     InlinePragma
-  | HsUnfold	 Bool		  -- True <=> isNonRuleLoopBreaker is true
-		 IfaceUnfolding   -- See Note [Expose recursive functions] 
+  | HsUnfold     Bool             -- True <=> isNonRuleLoopBreaker is true
+                 IfaceUnfolding   -- See Note [Expose recursive functions]
   | HsNoCafRefs
 
 -- NB: Specialisations and rules come in separately and are
 -- only later attached to the Id.  Partial reason: some are orphans.
 
-data IfaceUnfolding 
+data IfaceUnfolding
   = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
                                 -- Possibly could eliminate the Bool here, the information
                                 -- is also in the InlinePragma.
 
-  | IfCompulsory IfaceExpr	-- Only used for default methods, in fact
+  | IfCompulsory IfaceExpr      -- Only used for default methods, in fact
 
   | IfInlineRule Arity          -- INLINE pragmas
-                 Bool		-- OK to inline even if *un*-saturated
-		 Bool		-- OK to inline even if context is boring
-                 IfaceExpr 
+                 Bool           -- OK to inline even if *un*-saturated
+                 Bool           -- OK to inline even if context is boring
+                 IfaceExpr
 
-  | IfExtWrapper Arity IfExtName  -- NB: sometimes we need a IfExtName (not just IfLclName) 
-  | IfLclWrapper Arity IfLclName  --     because the worker can simplify to a function in 
-    		       		  --     another module.
+  | IfExtWrapper Arity IfExtName  -- NB: sometimes we need a IfExtName (not just IfLclName)
+  | IfLclWrapper Arity IfLclName  --     because the worker can simplify to a function in
+                                  --     another module.
 
   | IfDFunUnfold [DFunArg IfaceExpr]
 
 --------------------------------
 data IfaceExpr
-  = IfaceLcl 	IfLclName
+  = IfaceLcl    IfLclName
   | IfaceExt    IfExtName
   | IfaceType   IfaceType
-  | IfaceTuple 	Boxity [IfaceExpr]		-- Saturated; type arguments omitted
+  | IfaceCo     IfaceType		-- We re-use IfaceType for coercions
+  | IfaceTuple 	Boxity [IfaceExpr]	-- Saturated; type arguments omitted
   | IfaceLam 	IfaceBndr IfaceExpr
   | IfaceApp 	IfaceExpr IfaceExpr
-  | IfaceCase	IfaceExpr IfLclName IfaceType [IfaceAlt]
+  | IfaceCase	IfaceExpr IfLclName [IfaceAlt]
   | IfaceLet	IfaceBinding  IfaceExpr
   | IfaceNote	IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
-  | IfaceLit	Literal
-  | IfaceFCall	ForeignCall IfaceType
+  | IfaceLit    Literal
+  | IfaceFCall  ForeignCall IfaceType
   | IfaceTick   Module Int
 
 data IfaceNote = IfaceSCC CostCentre
                | IfaceCoreNote String
 
 type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
-	-- Note: IfLclName, not IfaceBndr (and same with the case binder)
-	-- We reconstruct the kind/type of the thing from the context
-	-- thus saving bulk in interface files
+        -- Note: IfLclName, not IfaceBndr (and same with the case binder)
+        -- We reconstruct the kind/type of the thing from the context
+        -- thus saving bulk in interface files
 
 data IfaceConAlt = IfaceDefault
- 		 | IfaceDataAlt IfExtName
-		 | IfaceTupleAlt Boxity
-		 | IfaceLitAlt Literal
+                 | IfaceDataAlt IfExtName
+                 | IfaceTupleAlt Boxity
+                 | IfaceLitAlt Literal
 
 data IfaceBinding
-  = IfaceNonRec	IfaceLetBndr IfaceExpr
-  | IfaceRec 	[(IfaceLetBndr, IfaceExpr)]
+  = IfaceNonRec IfaceLetBndr IfaceExpr
+  | IfaceRec    [(IfaceLetBndr, IfaceExpr)]
 
 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
 -- It's used for *non-top-level* let/rec binders
@@ -299,9 +293,9 @@ complicate the situation though. Consider
 and suppose we are compiling module X:
 
   module X where
-	import M
-	data T = ...
-	instance C Int T where ...
+        import M
+        data T = ...
+        instance C Int T where ...
 
 This instance is an orphan, because when compiling a third module Y we
 might get a constraint (C Int v), and we'd want to improve v to T.  So
@@ -315,7 +309,7 @@ More precisely, an instance is an orphan iff
 
   If there are fundeps, then for every fundep, at least one of the
   names free in a *non-determined* part of the instance head is
-  defined in this module.  
+  defined in this module.
 
 (Note that these conditions hold trivially if the class is locally
 defined.)
@@ -342,10 +336,10 @@ a functionally-dependent part of the instance decl.  E.g.
 and suppose we are compiling module X:
 
   module X where
-	import M
-	data S  = ...
-	data T = ...
-	instance C S T where ...
+        import M
+        data S  = ...
+        data T = ...
+        instance C S T where ...
 
 If we base the instance verion on T, I'm worried that changing S to S'
 would change T's version, but not S or S'.  But an importing module might
@@ -356,8 +350,8 @@ and it seems deeply obscure, so I'm going to leave it for now.
 
 Note [Versioning of rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
-A rule that is not an orphan has an ifRuleOrph field of (Just n), where
-n appears on the LHS of the rule; any change in the rule changes the version of n.
+A rule that is not an orphan has an ifRuleOrph field of (Just n), where n
+appears on the LHS of the rule; any change in the rule changes the version of n.
 
 
 \begin{code}
@@ -380,7 +374,7 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}  = []
 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
                               ifCons = IfNewTyCon (
                                         IfCon { ifConOcc = con_occ }),
-                              ifFamInst = famInst}) 
+                              ifFamInst = famInst})
   =   -- implicit coerion and (possibly) family instance coercion
     (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
       -- data constructor and worker (newtypes don't have a wrapper)
@@ -388,8 +382,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 
 
 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
-			      ifCons = IfDataTyCon cons, 
-			      ifFamInst = famInst})
+                              ifCons = IfDataTyCon cons,
+                              ifFamInst = famInst})
   =   -- (possibly) family instance coercion;
       -- there is no implicit coercion for non-newtypes
     famInstCo famInst tc_occ
@@ -398,20 +392,20 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
     ++ concatMap dc_occs cons
   where
     dc_occs con_decl
-	| has_wrapper = [con_occ, work_occ, wrap_occ]
-	| otherwise   = [con_occ, work_occ]
-	where
-	  con_occ  = ifConOcc con_decl			-- DataCon namespace
-	  wrap_occ = mkDataConWrapperOcc con_occ	-- Id namespace
-	  work_occ = mkDataConWorkerOcc con_occ		-- Id namespace
-	  has_wrapper = ifConWrapper con_decl		-- This is the reason for
-	  	      		     			-- having the ifConWrapper field!
-
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, 
-			       ifSigs = sigs, ifATs = ats })
+        | has_wrapper = [con_occ, work_occ, wrap_occ]
+        | otherwise   = [con_occ, work_occ]
+        where
+          con_occ  = ifConOcc con_decl            -- DataCon namespace
+          wrap_occ = mkDataConWrapperOcc con_occ  -- Id namespace
+          work_occ = mkDataConWorkerOcc con_occ   -- Id namespace
+          has_wrapper = ifConWrapper con_decl     -- This is the reason for
+                                                  -- having the ifConWrapper field!
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+                               ifSigs = sigs, ifATs = ats })
   = -- dictionary datatype:
     --   type constructor
-    tc_occ : 
+    tc_occ :
     --   (possibly) newtype coercion
     co_occs ++
     --    data constructor (DataCon namespace)
@@ -428,14 +422,14 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
     n_ctxt = length sc_ctxt
     n_sigs = length sigs
     tc_occ  = mkClassTyConOcc cls_occ
-    dc_occ  = mkClassDataConOcc cls_occ	
+    dc_occ  = mkClassDataConOcc cls_occ
     co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
-	    | otherwise  = []
+            | otherwise  = []
     dcww_occ = mkDataConWorkerOcc dc_occ
-    is_newtype = n_sigs + n_ctxt == 1			-- Sigh 
+    is_newtype = n_sigs + n_ctxt == 1 -- Sigh
 
 ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
-			     ifFamInst = famInst})
+                             ifFamInst = famInst})
   = famInstCo famInst tc_occ
 
 ifaceDeclSubBndrs _ = []
@@ -451,54 +445,50 @@ instance Outputable IfaceDecl where
   ppr = pprIfaceDecl
 
 pprIfaceDecl :: IfaceDecl -> SDoc
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty, 
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
                        ifIdDetails = details, ifIdInfo = info})
-  = sep [ ppr var <+> dcolon <+> ppr ty, 
-    	  nest 2 (ppr details),
-	  nest 2 (ppr info) ]
+  = sep [ ppr var <+> dcolon <+> ppr ty,
+          nest 2 (ppr details),
+          nest 2 (ppr info) ]
 
 pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
 
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
-		        ifSynRhs = Just mono_ty, 
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+                        ifSynRhs = Just mono_ty,
                         ifFamInst = mbFamInst})
   = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
 
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
-		        ifSynRhs = Nothing, ifSynKind = kind })
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+                        ifSynRhs = Nothing, ifSynKind = kind })
   = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (dcolon <+> ppr kind)
 
-pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
-			 ifTyVars = tyvars, ifCons = condecls, 
-			 ifRec = isrec, ifFamInst = mbFamInst})
+pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
+                         ifTyVars = tyvars, ifCons = condecls,
+                         ifRec = isrec, ifFamInst = mbFamInst})
   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
-       4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
-	        pprFamily mbFamInst])
+       4 (vcat [pprRec isrec, pp_condecls tycon condecls,
+                pprFamily mbFamInst])
   where
     pp_nd = case condecls of
-		IfAbstractTyCon -> ptext (sLit "data")
-		IfOpenDataTyCon -> ptext (sLit "data family")
-		IfDataTyCon _   -> ptext (sLit "data")
-		IfNewTyCon _  	-> ptext (sLit "newtype")
-
-pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
-			  ifFDs = fds, ifATs = ats, ifSigs = sigs, 
-			  ifRec = isrec})
+                IfAbstractTyCon -> ptext (sLit "data")
+                IfOpenDataTyCon -> ptext (sLit "data family")
+                IfDataTyCon _   -> ptext (sLit "data")
+                IfNewTyCon _    -> ptext (sLit "newtype")
+
+pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
+                          ifFDs = fds, ifATs = ats, ifSigs = sigs,
+                          ifRec = isrec})
   = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
        4 (vcat [pprRec isrec,
-	        sep (map ppr ats),
-		sep (map ppr sigs)])
+                sep (map ppr ats),
+                sep (map ppr sigs)])
 
 pprRec :: RecFlag -> SDoc
 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
 
-pprGen :: Bool -> SDoc
-pprGen True  = ptext (sLit "Generics: yes")
-pprGen False = ptext (sLit "Generics: no")
-
 pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
 pprFamily Nothing        = ptext (sLit "FamilyInstance: none")
 pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
@@ -508,68 +498,68 @@ instance Outputable IfaceClassOp where
 
 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 pprIfaceDeclHead context thing tyvars
-  = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), 
-	  pprIfaceTvBndrs tyvars]
+  = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+          pprIfaceTvBndrs tyvars]
 
 pp_condecls :: OccName -> IfaceConDecls -> SDoc
 pp_condecls _  IfAbstractTyCon  = ptext (sLit "{- abstract -}")
 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 pp_condecls _  IfOpenDataTyCon  = empty
 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
-							     (map (pprIfaceConDecl tc) cs))
+                                                            (map (pprIfaceConDecl tc) cs))
 
 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
 pprIfaceConDecl tc
-	(IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
-		 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, 
-		 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, 
-		 ifConStricts = strs, ifConFields = fields })
+        (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
+                 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+                 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
+                 ifConStricts = strs, ifConFields = fields })
   = sep [main_payload,
-	 if is_infix then ptext (sLit "Infix") else empty,
-	 if has_wrap then ptext (sLit "HasWrapper") else empty,
-	 ppUnless (null strs) $
-	    nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
-	 ppUnless (null fields) $
-	    nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+         if is_infix then ptext (sLit "Infix") else empty,
+         if has_wrap then ptext (sLit "HasWrapper") else empty,
+         ppUnless (null strs) $
+            nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
+         ppUnless (null fields) $
+            nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
-    ppr_bang HsNoBang = char '_'	-- Want to see these
+    ppr_bang HsNoBang = char '_'        -- Want to see these
     ppr_bang bang     = ppr bang
-        
-    main_payload = ppr name <+> dcolon <+> 
-		   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 
-    eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) 
-	      | (tv,ty) <- eq_spec] 
+    main_payload = ppr name <+> dcolon <+>
+                   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
+
+    eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
+              | (tv,ty) <- eq_spec]
 
-	-- A bit gruesome this, but we can't form the full con_tau, and ppr it,
-	-- because we don't have a Name for the tycon, only an OccName
+        -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
+        -- because we don't have a Name for the tycon, only an OccName
     pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
-		(t:ts) -> fsep (t : map (arrow <+>) ts)
-		[]     -> panic "pp_con_taus"
+                (t:ts) -> fsep (t : map (arrow <+>) ts)
+                []     -> panic "pp_con_taus"
 
     pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
 
 instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
-		   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) 
+                   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
     = sep [hsep [doubleQuotes (ftext name), ppr act,
-		 ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
-	   nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
-		        ptext (sLit "=") <+> ppr rhs])
+                 ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
+           nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
+                        ptext (sLit "=") <+> ppr rhs])
       ]
 
 instance Outputable IfaceInst where
-  ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, 
-		  ifInstCls = cls, ifInstTys = mb_tcs})
-    = hang (ptext (sLit "instance") <+> ppr flag 
-		<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
+  ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
+                  ifInstCls = cls, ifInstTys = mb_tcs})
+    = hang (ptext (sLit "instance") <+> ppr flag
+                <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
          2 (equals <+> ppr dfun_id)
 
 instance Outputable IfaceFamInst where
   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
-		     ifFamInstTyCon = tycon_id})
-    = hang (ptext (sLit "family instance") <+> 
-	    ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+                     ifFamInstTyCon = tycon_id})
+    = hang (ptext (sLit "family instance") <+>
+            ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
          2 (equals <+> ppr tycon_id)
 
 ppr_rough :: Maybe IfaceTyCon -> SDoc
@@ -587,9 +577,11 @@ instance Outputable IfaceExpr where
 pprParendIfaceExpr :: IfaceExpr -> SDoc
 pprParendIfaceExpr = pprIfaceExpr parens
 
+-- | Pretty Print an IfaceExpre
+--
+-- The first argument should be a function that adds parens in context that need
+-- an atomic value (e.g. function args)
 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
-	-- The function adds parens in context that need
-	-- an atomic value (e.g. function args)
 
 pprIfaceExpr _       (IfaceLcl v)       = ppr v
 pprIfaceExpr _       (IfaceExt v)       = ppr v
@@ -597,104 +589,112 @@ pprIfaceExpr _       (IfaceLit l)       = ppr l
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _       (IfaceCo co)       = text "@~" <+> pprParendIfaceType co
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 
-pprIfaceExpr add_par e@(IfaceLam _ _)   
+pprIfaceExpr add_par i@(IfaceLam _ _)
   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
-		  pprIfaceExpr noParens body])
-  where 
-    (bndrs,body) = collect [] e
+                  pprIfaceExpr noParens body])
+  where
+    (bndrs,body) = collect [] i
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+  = add_par (sep [ptext (sLit "case") 
 			<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
 			<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
   		  pprIfaceExpr noParens rhs <+> char '}'])
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+  = add_par (sep [ptext (sLit "case") 
 		 	<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
 			<+> ppr bndr <+> char '{',
   		  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 
 pprIfaceExpr _       (IfaceCast expr co)
   = sep [pprParendIfaceExpr expr,
-	 nest 2 (ptext (sLit "`cast`")),
-	 pprParendIfaceType co]
+         nest 2 (ptext (sLit "`cast`")),
+         pprParendIfaceType co]
 
 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
-  = add_par (sep [ptext (sLit "let {"), 
-		  nest 2 (ppr_bind (b, rhs)),
-		  ptext (sLit "} in"), 
-		  pprIfaceExpr noParens body])
+  = add_par (sep [ptext (sLit "let {"),
+                  nest 2 (ppr_bind (b, rhs)),
+                  ptext (sLit "} in"),
+                  pprIfaceExpr noParens body])
 
 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
   = add_par (sep [ptext (sLit "letrec {"),
-		  nest 2 (sep (map ppr_bind pairs)), 
-		  ptext (sLit "} in"),
-		  pprIfaceExpr noParens body])
+                  nest 2 (sep (map ppr_bind pairs)),
+                  ptext (sLit "} in"),
+                  pprIfaceExpr noParens body])
 
-pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
+pprIfaceExpr add_par (IfaceNote note body) = add_par $ ppr note
+                                                <+> pprParendIfaceExpr body
 
 ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
-ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 
-			      arrow <+> pprIfaceExpr noParens rhs]
+ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
+                         arrow <+> pprIfaceExpr noParens rhs]
 
 ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
-ppr_con_bs con bs		      = ppr con <+> hsep (map ppr bs)
-  
+ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
+
 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
-ppr_bind (IfLetBndr b ty info, rhs) 
+ppr_bind (IfLetBndr b ty info, rhs)
   = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
-	 equals <+> pprIfaceExpr noParens rhs]
+         equals <+> pprIfaceExpr noParens rhs]
 
 ------------------
 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args)
-pprIfaceApp fun	 	       args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+                                          nest 2 (pprParendIfaceExpr arg) : args
+pprIfaceApp fun                args = sep (pprParendIfaceExpr fun : args)
 
 ------------------
 instance Outputable IfaceNote where
     ppr (IfaceSCC cc)     = pprCostCentreCore cc
-    ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
+    ppr (IfaceCoreNote s) = ptext (sLit "__core_note")
+                            <+> pprHsString (mkFastString s)
 
 
 instance Outputable IfaceConAlt where
     ppr IfaceDefault      = text "DEFAULT"
     ppr (IfaceLitAlt l)   = ppr l
     ppr (IfaceDataAlt d)  = ppr d
-    ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" 
+    ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
     -- IfaceTupleAlt is handled by the case-alternative printer
 
 ------------------
 instance Outputable IfaceIdDetails where
-  ppr IfVanillaId    = empty
+  ppr IfVanillaId       = empty
   ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
-      		          <+> if b then ptext (sLit "<naughty>") else empty
+                          <+> if b then ptext (sLit "<naughty>") else empty
   ppr (IfDFunId ns)     = ptext (sLit "DFunId") <> brackets (int ns)
 
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = empty
-  ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
+  ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is
+                     <+> ptext (sLit "-}")
 
 instance Outputable IfaceInfoItem where
-  ppr (HsUnfold lb unf)  = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) 
+  ppr (HsUnfold lb unf)  = ptext (sLit "Unfolding")
+                           <> ppWhen lb (ptext (sLit "(loop-breaker)"))
                            <> colon <+> ppr unf
   ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
-  ppr HsNoCafRefs	 = ptext (sLit "HasNoCafRefs")
+  ppr HsNoCafRefs        = ptext (sLit "HasNoCafRefs")
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
-  ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
-      		           	        pprParendIfaceExpr e]
+  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty)
+                              <+> parens (ppr e)
+  ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule")
+                                            <+> ppr (a,uok,bok),
+                                        pprParendIfaceExpr e]
   ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
                              <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
@@ -703,7 +703,7 @@ instance Outputable IfaceUnfolding where
                              <+> brackets (pprWithCommas ppr ns)
 
 -- -----------------------------------------------------------------------------
--- Finding the Names in IfaceSyn
+-- | Finding the Names in IfaceSyn
 
 -- This is used for dependency analysis in MkIface, so that we
 -- fingerprint a declaration before the things that depend on it.  It
@@ -713,11 +713,11 @@ instance Outputable IfaceUnfolding where
 -- fingerprinting the instance, so DFuns are not dependencies.
 
 freeNamesIfDecl :: IfaceDecl -> NameSet
-freeNamesIfDecl (IfaceId _s t d i) = 
+freeNamesIfDecl (IfaceId _s t d i) =
   freeNamesIfType t &&&
   freeNamesIfIdInfo i &&&
   freeNamesIfIdDetails d
-freeNamesIfDecl IfaceForeign{} = 
+freeNamesIfDecl IfaceForeign{} =
   emptyNameSet
 freeNamesIfDecl d@IfaceData{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
@@ -744,7 +744,7 @@ freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
 freeNamesIfSynRhs Nothing   = emptyNameSet
 
 freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
-freeNamesIfTcFam (Just (tc,tys)) = 
+freeNamesIfTcFam (Just (tc,tys)) =
   freeNamesIfTc tc &&& fnList freeNamesIfType tys
 freeNamesIfTcFam Nothing =
   emptyNameSet
@@ -764,15 +764,15 @@ freeNamesIfConDecls (IfNewTyCon c)  = freeNamesIfConDecl c
 freeNamesIfConDecls _               = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
-freeNamesIfConDecl c = 
+freeNamesIfConDecl c =
   freeNamesIfTvBndrs (ifConUnivTvs c) &&&
   freeNamesIfTvBndrs (ifConExTvs c) &&&
-  freeNamesIfContext (ifConCtxt c) &&& 
+  freeNamesIfContext (ifConCtxt c) &&&
   fnList freeNamesIfType (ifConArgTys c) &&&
   fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
 
 freeNamesIfPredType :: IfacePredType -> NameSet
-freeNamesIfPredType (IfaceClassP cl tys) = 
+freeNamesIfPredType (IfaceClassP cl tys) =
    unitNameSet cl &&& fnList freeNamesIfType tys
 freeNamesIfPredType (IfaceIParam _n ty) =
    freeNamesIfType ty
@@ -783,11 +783,13 @@ freeNamesIfType :: IfaceType -> NameSet
 freeNamesIfType (IfaceTyVar _)        = emptyNameSet
 freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
 freeNamesIfType (IfacePredTy st)      = freeNamesIfPredType st
-freeNamesIfType (IfaceTyConApp tc ts) = 
+freeNamesIfType (IfaceTyConApp tc ts) =
    freeNamesIfTc tc &&& fnList freeNamesIfType ts
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) = 
+   freeNamesIfCo tc &&& fnList freeNamesIfType ts
 
 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -798,7 +800,7 @@ freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
 
 freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
 -- Remember IfaceLetBndr is used only for *nested* bindings
--- The IdInfo can contain an unfolding (in the case of 
+-- The IdInfo can contain an unfolding (in the case of
 -- local INLINE pragmas), so look there too
 freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
                                              &&& freeNamesIfIdInfo info
@@ -811,7 +813,7 @@ freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
 freeNamesIfIdBndr = freeNamesIfTvBndr
 
 freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
-freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo NoInfo      = emptyNameSet
 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
 
 freeNamesItem :: IfaceInfoItem -> NameSet
@@ -827,28 +829,28 @@ freeNamesIfUnfold (IfLclWrapper {})      = emptyNameSet
 freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr (dfunArgExprs vs)
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
-freeNamesIfExpr (IfaceExt v)	  = unitNameSet v
+freeNamesIfExpr (IfaceExt v)      = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co)      = freeNamesIfType co
 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
 freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
-freeNamesIfExpr (IfaceNote _n r)   = freeNamesIfExpr r
+freeNamesIfExpr (IfaceNote _n r)  = freeNamesIfExpr r
 
-freeNamesIfExpr (IfaceCase s _ ty alts)
+freeNamesIfExpr (IfaceCase s _ alts)
   = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
-    &&& freeNamesIfType ty
   where
     fn_alt (_con,_bs,r) = freeNamesIfExpr r
 
     -- Depend on the data constructors.  Just one will do!
     -- Note [Tracking data constructors]
-    fn_cons []                              = emptyNameSet
-    fn_cons ((IfaceDefault    ,_,_) : alts) = fn_cons alts
-    fn_cons ((IfaceDataAlt con,_,_) : _   ) = unitNameSet con    
-    fn_cons (_                      : _   ) = emptyNameSet
+    fn_cons []                            = emptyNameSet
+    fn_cons ((IfaceDefault    ,_,_) : xs) = fn_cons xs
+    fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+    fn_cons (_                      : _ ) = emptyNameSet
 
 freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
   = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
@@ -865,6 +867,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 freeNamesIfTc _ = emptyNameSet
 
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
 freeNamesIfRule :: IfaceRule -> NameSet
 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
                            , ifRuleArgs = es, ifRuleRhs = rhs })
@@ -883,18 +889,18 @@ fnList f = foldr (&&&) emptyNameSet . map f
 
 Note [Tracking data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a case expression 
+In a case expression
    case e of { C a -> ...; ... }
 You might think that we don't need to include the datacon C
-in the free names, because its type will probably show up in 
+in the free names, because its type will probably show up in
 the free names of 'e'.  But in rare circumstances this may
 not happen.   Here's the one that bit me:
 
-   module DynFlags where 
+   module DynFlags where
      import {-# SOURCE #-} Packages( PackageState )
      data DynFlags = DF ... PackageState ...
 
-   module Packages where 
+   module Packages where
      import DynFlags
      data PackageState = PS ...
      lookupModule (df :: DynFlags)
@@ -905,3 +911,4 @@ not happen.   Here's the one that bit me:
 Now, lookupModule depends on DynFlags, but the transitive dependency
 on the *locally-defined* type PackageState is not visible. We need
 to take account of the use of the data constructor PS in the pattern match.
+
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index c97e16e..7817b42 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -9,15 +9,18 @@ This module defines interface types and binders
 module IfaceType (
 	IfExtName, IfLclName,
 
-        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..),
 	IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
 	ifaceTyConName,
 
 	-- Conversion from Type -> IfaceType
-	toIfaceType, toIfacePred, toIfaceContext, 
+        toIfaceType, toIfaceContext,
 	toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, 
 	toIfaceTyCon, toIfaceTyCon_name,
 
+        -- Conversion from Coercion -> IfaceType
+        coToIfaceType,
+
 	-- Printing
 	pprIfaceType, pprParendIfaceType, pprIfaceContext, 
 	pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
@@ -25,11 +28,13 @@ module IfaceType (
 
     ) where
 
-import TypeRep
+import Coercion
+import TypeRep hiding( maybeParen )
 import TyCon
 import Id
 import Var
 import TysWiredIn
+import TysPrim
 import Name
 import BasicTypes
 import Outputable
@@ -59,14 +64,15 @@ type IfaceTvBndr  = (IfLclName, IfaceKind)
 type IfaceKind     = IfaceType
 type IfaceCoercion = IfaceType
 
-data IfaceType
-  = IfaceTyVar    IfLclName			-- Type variable only, not tycon
+data IfaceType	   -- A kind of universal type, used for types, kinds, and coercions
+  = IfaceTyVar    IfLclName			-- Type/coercion variable only, not tycon
   | IfaceAppTy    IfaceType IfaceType
+  | IfaceFunTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType
-  | IfaceTyConApp IfaceTyCon [IfaceType]	-- Not necessarily saturated
-						-- Includes newtypes, synonyms, tuples
-  | IfaceFunTy  IfaceType IfaceType
+  | IfaceTyConApp IfaceTyCon [IfaceType]  -- Not necessarily saturated
+					  -- Includes newtypes, synonyms, tuples
+  | IfaceCoConApp IfaceCoCon [IfaceType]  -- Always saturated
 
 data IfacePredType 	-- NewTypes are handled as ordinary TyConApps
   = IfaceClassP IfExtName [IfaceType]
@@ -75,18 +81,28 @@ data IfacePredType 	-- NewTypes are handled as ordinary TyConApps
 
 type IfaceContext = [IfacePredType]
 
-data IfaceTyCon 	-- Abbreviations for common tycons with known names
+data IfaceTyCon 	-- Encodes type consructors, kind constructors
+     			-- coercion constructors, the lot
   = IfaceTc IfExtName	-- The common case
   | IfaceIntTc | IfaceBoolTc | IfaceCharTc
   | IfaceListTc | IfacePArrTc
   | IfaceTupTc Boxity Arity 
   | IfaceAnyTc IfaceKind     -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
     	       		     -- other than 'Any :: *' itself
+ 
+  -- Kind constructors
   | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
   | IfaceUbxTupleKindTc | IfaceArgTypeKindTc 
 
-ifaceTyConName :: IfaceTyCon -> IfExtName
-ifaceTyConName IfaceIntTc  	       = intTyConName
+  -- Coercion constructors
+data IfaceCoCon
+  = IfaceCoAx IfExtName
+  | IfaceReflCo    | IfaceUnsafeCo  | IfaceSymCo
+  | IfaceTransCo   | IfaceInstCo
+  | IfaceNthCo Int
+
+ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc              = intTyConName
 ifaceTyConName IfaceBoolTc 	       = boolTyConName
 ifaceTyConName IfaceCharTc 	       = charTyConName
 ifaceTyConName IfaceListTc 	       = listTyConName
@@ -208,6 +224,10 @@ ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
 ppr_ty _         (IfacePredTy st)       = ppr st
 
+ppr_ty ctxt_prec (IfaceCoConApp tc tys) 
+  = maybeParen ctxt_prec tYCON_PREC 
+	       (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+
 	-- Function types
 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
@@ -268,6 +288,15 @@ instance Outputable IfaceTyCon where
 			     -- so we fake it.  It's only for debug printing!
   ppr other_tc       = ppr (ifaceTyConName other_tc)
 
+instance Outputable IfaceCoCon where
+  ppr (IfaceCoAx n)  = ppr n
+  ppr IfaceReflCo    = ptext (sLit "Refl")
+  ppr IfaceUnsafeCo  = ptext (sLit "Unsafe")
+  ppr IfaceSymCo     = ptext (sLit "Sym")
+  ppr IfaceTransCo   = ptext (sLit "Trans")
+  ppr IfaceInstCo    = ptext (sLit "Inst")
+  ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
+
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
@@ -309,18 +338,15 @@ toIfaceKind = toIfaceType
 ---------------------
 toIfaceType :: Type -> IfaceType
 -- Synonyms are retained in the interface type
-toIfaceType (TyVarTy tv) =
-  IfaceTyVar (occNameFS (getOccName tv))
-toIfaceType (AppTy t1 t2) =
-  IfaceAppTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (FunTy t1 t2) =
-  IfaceFunTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (TyConApp tc tys) =
-  IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
-toIfaceType (ForAllTy tv t) =
-  IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (PredTy st) =
-  IfacePredTy (toIfacePred st)
+toIfaceType (TyVarTy tv)      = IfaceTyVar (toIfaceTyCoVar tv)
+toIfaceType (AppTy t1 t2)     = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (FunTy t1 t2)     = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (ForAllTy tv t)   = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
+toIfaceType (PredTy st)       = IfacePredTy (toIfacePred toIfaceType st)
+
+toIfaceTyCoVar :: TyCoVar -> FastString
+toIfaceTyCoVar = occNameFS . getOccName
 
 ----------------
 -- A little bit of (perhaps optional) trickiness here.  When
@@ -364,16 +390,39 @@ toIfaceTypes :: [Type] -> [IfaceType]
 toIfaceTypes ts = map toIfaceType ts
 
 ----------------
-toIfacePred :: PredType -> IfacePredType
-toIfacePred (ClassP cls ts) = 
-  IfaceClassP (getName cls) (toIfaceTypes ts)
-toIfacePred (IParam ip t) = 
-  IfaceIParam (mapIPName getOccName ip) (toIfaceType t)
-toIfacePred (EqPred ty1 ty2) =
-  IfaceEqPred (toIfaceType ty1) (toIfaceType ty2)
+toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType
+toIfacePred to (ClassP cls ts)  = IfaceClassP (getName cls) (map to ts)
+toIfacePred to (IParam ip t)    = IfaceIParam (mapIPName getOccName ip) (to t)
+toIfacePred to (EqPred ty1 ty2) =  IfaceEqPred (to ty1) (to ty2)
 
 ----------------
 toIfaceContext :: ThetaType -> IfaceContext
-toIfaceContext cs = map toIfacePred cs
+toIfaceContext cs = map (toIfacePred toIfaceType) cs
+
+----------------
+coToIfaceType :: Coercion -> IfaceType
+coToIfaceType (Refl ty)             = IfaceCoConApp IfaceReflCo [toIfaceType ty]
+coToIfaceType (TyConAppCo tc cos)   = IfaceTyConApp (toIfaceTyCon tc) 
+                                                    (map coToIfaceType cos)
+coToIfaceType (AppCo co1 co2)       = IfaceAppTy    (coToIfaceType co1) 
+                                                    (coToIfaceType co2)
+coToIfaceType (ForAllCo v co)       = IfaceForAllTy (toIfaceTvBndr v) 
+                                                    (coToIfaceType co)
+coToIfaceType (CoVarCo cv)          = IfaceTyVar  (toIfaceTyCoVar cv)
+coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con))
+                                                    (map coToIfaceType cos)
+coToIfaceType (UnsafeCo ty1 ty2)    = IfaceCoConApp IfaceUnsafeCo 
+                                                    [ toIfaceType ty1
+                                                    , toIfaceType ty2 ]
+coToIfaceType (SymCo co)            = IfaceCoConApp IfaceSymCo 
+                                                    [ coToIfaceType co ]
+coToIfaceType (TransCo co1 co2)     = IfaceCoConApp IfaceTransCo
+                                                    [ coToIfaceType co1
+                                                    , coToIfaceType co2 ]
+coToIfaceType (NthCo d co)          = IfaceCoConApp (IfaceNthCo d)
+                                                    [ coToIfaceType co ]
+coToIfaceType (InstCo co ty)        = IfaceCoConApp IfaceInstCo 
+                                                    [ coToIfaceType co
+                                                    , toIfaceType ty ]
 \end{code}
 
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b940cb1..5c58a80 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -59,10 +59,10 @@ import Annotations
 import CoreSyn
 import CoreFVs
 import Class
+import Kind
 import TyCon
 import DataCon
 import Type
-import Coercion
 import TcType
 import InstEnv
 import FamInstEnv
@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
 	finsts_mod   = mi_finsts    iface
         hash_env     = mi_hash_fn   iface
         mod_hash     = mi_mod_hash  iface
-        export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
-    		    | otherwise 	    = Nothing
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+    		    | otherwise         = Nothing
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
                 Just r  -> r
 
-        depend_on_exports mod = 
-           case lookupModuleEnv direct_imports mod of
-    	        Just _ -> True
-                  -- Even if we used 'import M ()', we have to register a
-                  -- usage on the export list because we are sensitive to
-                  -- changes in orphan instances/rules.
-	    	Nothing -> False
-                  -- In GHC 6.8.x the above line read "True", and in
-                  -- fact it recorded a dependency on *all* the
-                  -- modules underneath in the dependency tree.  This
-                  -- happens to make orphans work right, but is too
-                  -- expensive: it'll read too many interface files.
-                  -- The 'isNothing maybe_iface' check above saved us
-                  -- from generating many of these usages (at least in
-                  -- one-shot mode), but that's even more bogus!
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
 \end{code}
 
 \begin{code}
@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
 	  (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
 	  op_ty		       = funResultTy rho_ty
 
-    toDmSpec NoDefMeth   = NoDM
-    toDmSpec GenDefMeth  = GenericDM
-    toDmSpec (DefMeth _) = VanillaDM
+    toDmSpec NoDefMeth      = NoDM
+    toDmSpec (GenDefMeth _) = GenericDM
+    toDmSpec (DefMeth _)    = VanillaDM
 
     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
 
@@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon)
 		ifCons    = ifaceConDecls (algTyConRhs tycon),
 	  	ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
 		ifGadtSyntax = isGadtSyntaxTyCon tycon,
-		ifGeneric = tyConHasGenerics tycon,
 		ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
 
   | isForeignTyCon tycon
@@ -1387,14 +1386,16 @@ tyThingToIfaceDecl (ATyCon tycon)
 	= IfCon   { ifConOcc   	 = getOccName (dataConName data_con),
 		    ifConInfix 	 = dataConIsInfix data_con,
 		    ifConWrapper = isJust (dataConWrapId_maybe data_con),
-		    ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
-		    ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
-		    ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
-		    ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
-		    ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
+		    ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+		    ifConExTvs   = toIfaceTvBndrs ex_tvs,
+		    ifConEqSpec  = to_eq_spec eq_spec,
+		    ifConCtxt    = toIfaceContext theta,
+		    ifConArgTys  = map toIfaceType arg_tys,
 		    ifConFields  = map getOccName 
 				       (dataConFieldLabels data_con),
 		    ifConStricts = dataConStrictMarks data_con }
+        where
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
 
@@ -1402,6 +1403,8 @@ tyThingToIfaceDecl (ATyCon tycon)
     famInstToIface (Just (famTyCon, instTys)) = 
       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
 
+tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+
 tyThingToIfaceDecl (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)	-- Should be trimmed out earlier
 
@@ -1566,6 +1569,8 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
 	-- construct the same ru_rough field as we have right now;
 	-- see tcIfaceRule
     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+    do_arg (Coercion co) = IfaceType (coToIfaceType co)
+                           
     do_arg arg       = toIfaceExpr arg
 
 	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
@@ -1585,15 +1590,16 @@ bogusIfaceRule id_name
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr
-toIfaceExpr (Var v)       = toIfaceVar v
-toIfaceExpr (Lit l)       = IfaceLit l
-toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
-toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
-toIfaceExpr (App f a)     = toIfaceApp f [a]
-toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
-toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
-toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
+toIfaceExpr (Var v)         = toIfaceVar v
+toIfaceExpr (Lit l)         = IfaceLit l
+toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
+toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
+toIfaceExpr (App f a)       = toIfaceApp f [a]
+toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
+toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Note n e)      = IfaceNote (toIfaceNote n) (toIfaceExpr e)
 
 ---------------------
 toIfaceNote :: Note -> IfaceNote
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 3a274a0..f29bf85 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -21,6 +21,7 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
+import Coercion
 import TypeRep
 import HscTypes
 import Annotations
@@ -39,7 +40,6 @@ import TyCon
 import DataCon
 import TysWiredIn
 import TysPrim		( anyTyConOfKind )
-import Var              ( Var, TyVar )
 import BasicTypes	( Arity, nonRuleLoopBreaker )
 import qualified Var
 import VarEnv
@@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
 			  ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
 			  ifCons = rdr_cons, 
 			  ifRec = is_rec, 
-			  ifGeneric = want_generic,
 			  ifFamInst = mb_family })
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
@@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
 	    ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
 	    ; mb_fam_inst  <- tcFamInst mb_family
 	    ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
-			    want_generic gadt_syn parent mb_fam_inst
+			    gadt_syn parent mb_fam_inst
 	    })
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
@@ -791,20 +790,56 @@ tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
 
 tcIfaceTypes :: [IfaceType] -> IfL [Type]
 tcIfaceTypes tys = mapM tcIfaceType tys
 
 -----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2)  = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+  = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+  = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+  = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
 
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%*									*
+			Coercions
+%*									*
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n)        = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2)    = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2)    = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
+                                  mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co)      = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _)      = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo    [t]     = Refl         <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n)  ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo  [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo     [t]     = SymCo        <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo   [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo    [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t]     = NthCo d      <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
 \end{code}
 
 
@@ -819,6 +854,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
 tcIfaceExpr (IfaceType ty)
   = Type <$> tcIfaceType ty
 
+tcIfaceExpr (IfaceCo co)
+  = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
 tcIfaceExpr (IfaceLcl name)
   = Var <$> tcIfaceLclId name
 
@@ -853,7 +894,7 @@ tcIfaceExpr (IfaceLam bndr body)
 tcIfaceExpr (IfaceApp fun arg)
   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
+tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
     let
@@ -868,8 +909,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
 
     extendIfaceIdEnv [case_bndr'] $ do
      alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
-     ty' <- tcIfaceType ty
-     return (Case scrut' case_bndr' ty' alts')
+     return (Case scrut' case_bndr' (coreAltsType alts') alts')
 
 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
   = do	{ name 	  <- newIfaceName (mkVarOccFS fs)
@@ -898,11 +938,6 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
                                 (idName id) (idType id) info
           ; return (setIdInfo id id_info, rhs') }
 
-tcIfaceExpr (IfaceCast expr co) = do
-    expr' <- tcIfaceExpr expr
-    co' <- tcIfaceType co
-    return (Cast expr' co')
-
 tcIfaceExpr (IfaceNote note expr) = do
     expr' <- tcIfaceExpr expr
     case note of
@@ -942,14 +977,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
 tcIfaceDataAlt con inst_tys arg_strs rhs
   = do	{ us <- newUniqueSupply
 	; let uniqs = uniqsFromSupply us
-	; let (ex_tvs, co_tvs, arg_ids)
+	; let (ex_tvs, arg_ids)
 	              = dataConRepFSInstPat arg_strs uniqs con inst_tys
-              all_tvs = ex_tvs ++ co_tvs
 
-	; rhs' <- extendIfaceTyVarEnv all_tvs	$
+	; rhs' <- extendIfaceTyVarEnv ex_tvs	$
 		  extendIfaceIdEnv arg_ids	$
 		  tcIfaceExpr rhs
-	; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+	; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
 \end{code}
 
 
@@ -1217,6 +1251,10 @@ tcIfaceClass :: Name -> IfL Class
 tcIfaceClass name = do { thing <- tcIfaceGlobal name
 		       ; return (tyThingClass thing) }
 
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+		         ; return (tyThingCoAxiom thing) }
+
 tcIfaceDataCon :: Name -> IfL DataCon
 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
 		 	 ; case thing of
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 911592b..9f25c08 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -122,34 +122,25 @@ pprInfoTable env count lbl stat
           then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
           else (pprLlvmData ([ldata'], ltypes), llvmUsed)
 
+
 -- | We generate labels for info tables by converting them to the same label
 -- as for the entry code but adding this string as a suffix.
 iTableSuf :: String
 iTableSuf = "_itable"
 
 
--- | Create an appropriate section declaration for subsection <n> of text
--- WARNING: This technique could fail as gas documentation says it only
--- supports up to 8192 subsections per section. Inspection of the source
--- code and some test programs seem to suggest it supports more than this
--- so we are hoping it does.
+-- | Create a specially crafted section declaration that encodes the order this
+-- section should be in the final object code.
+-- 
+-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses
+-- this section declaration to do its processing.
 mkLayoutSection :: Int -> LMSection
 mkLayoutSection n
-  -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which
-  -- doesn't support subsections. So we post process the assembly code, this
-  -- section specifier will be replaced with '.text' by the mangler.
-  = Just (fsLit $ infoSection ++ show n
-#if darwin_TARGET_OS
-      )
-#else
-      ++ "#")
-#endif
+  = Just (fsLit $ infoSection ++ show n)
 
--- | The section we are putting info tables and their entry code into
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
 infoSection :: String
-#if darwin_TARGET_OS
-infoSection = "__STRIP,__me"
-#else
-infoSection = ".text; .text "
-#endif
+infoSection = "X98A__STRIP,__me"
 
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index 7b38ed8..591ef81 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -1,17 +1,21 @@
+{-# OPTIONS -fno-warn-unused-binds #-}
 -- -----------------------------------------------------------------------------
 -- | GHC LLVM Mangler
 --
 -- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function. We also
--- use it to fix up the stack alignment, which needs to be 16 byte aligned
--- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
--- starting value in the RTS.
+-- so that an info table appears before its corresponding function.
 --
--- We only need this for Mac OS X, other targets don't use it.
+-- On OSX we also use it to fix up the stack alignment, which needs to be 16
+-- byte aligned but always ends up off by word bytes because GHC sets it to
+-- the 'wrong' starting value in the RTS.
 --
 
 module LlvmMangler ( llvmFixupAsm ) where
 
+#include "HsVersions.h"
+
+import LlvmCodeGen.Ppr ( infoSection )
+
 import Control.Exception
 import qualified Data.ByteString.Char8 as B
 import Data.Char
@@ -19,17 +23,24 @@ import qualified Data.IntMap as I
 import System.IO
 
 -- Magic Strings
-infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
-infoSec    = B.pack "\t.section\t__STRIP,__me"
+secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
+secStmt    = B.pack "\t.section\t"
+infoSec    = B.pack infoSection
 newInfoSec = B.pack "\n\t.text"
 newLine    = B.pack "\n"
-spInst     = B.pack ", %esp\n"
 jmpInst    = B.pack "\n\tjmp"
 
-infoLen, spFix, labelStart :: Int
-infoLen = B.length infoSec
-spFix   = 4
-labelStart = B.length jmpInst + 1
+infoLen, labelStart, spFix :: Int
+infoLen    = B.length infoSec
+labelStart = B.length jmpInst
+
+#if x86_64_TARGET_ARCH
+spInst     = B.pack ", %rsp\n"
+spFix      = 8
+#else
+spInst     = B.pack ", %esp\n"
+spFix      = 4
+#endif
 
 -- Search Predicates
 eolPred, dollarPred, commaPred :: Char -> Bool
@@ -50,25 +61,30 @@ llvmFixupAsm f1 f2 = do
 
 {- |
     Here we process the assembly file one function and data
-    defenition at a time. When a function is encountered that
+    definition at a time. When a function is encountered that
     should have a info table we store it in a map. Otherwise
     we print it. When an info table is found we retrieve its
     function from the map and print them both.
 
     For all functions we fix up the stack alignment. We also
-    fix up the section defenition for functions and info tables.
+    fix up the section definition for functions and info tables.
 -}
 fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
 fixTables r w m = do
     f <- getFun r B.empty
     if B.null f
        then return ()
-       else let fun   = fixupStack f B.empty
-                (a,b) = B.breakSubstring infoSec fun
-                (x,c) = B.break eolPred b
-                fun'  = a `B.append` newInfoSec `B.append` c
-                n     = readInt $ B.drop infoLen x
-                (bs, m') | B.null b  = ([fun], m)
+       else let fun    = fixupStack f B.empty
+                (a,b)  = B.breakSubstring infoSec fun
+                (a',s) = B.breakEnd eolPred a
+                -- We search for the section header in two parts as it makes
+                -- us portable across OS types and LLVM version types since
+                -- section names are wrapped differently.
+                secHdr = secStmt `B.isPrefixOf` s
+                (x,c)  = B.break eolPred b
+                fun'   = a' `B.append` newInfoSec `B.append` c
+                n      = readInt $ B.takeWhile isDigit $ B.drop infoLen x
+                (bs, m') | B.null b || not secHdr = ([fun], m)
                          | even n    = ([], I.insert n fun' m)
                          | otherwise = case I.lookup (n+1) m of
                                Just xf' -> ([fun',xf'], m)
@@ -88,7 +104,7 @@ getFun r f = do
     Mac OS X requires that the stack be 16 byte aligned when making a function
     call (only really required though when making a call that will pass through
     the dynamic linker). The alignment isn't correctly generated by LLVM as
-    LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
+    LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
     (since the function call was 16 byte aligned and the return address should
     have been pushed, so sub 4). GHC though since it always uses jumps keeps
     the stack 16 byte aligned on both function calls and function entry.
@@ -96,6 +112,11 @@ getFun r f = do
     We correct the alignment here.
 -}
 fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
+
+#if !darwin_TARGET_OS
+fixupStack = const
+
+#else
 fixupStack f f' | B.null f' =
     let -- fixup sub op
         (a, c) = B.breakSubstring spInst f
@@ -114,18 +135,21 @@ fixupStack f f' =
         (a', n) = B.breakEnd dollarPred a
         (n', x) = B.break commaPred n
         num     = B.pack $ show $ readInt n' + spFix
+        -- We need to avoid processing jumps to labels, they are of the form:
+        -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L...
+        targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
+                B.drop labelStart c
     in if B.null c
           then f' `B.append` f
-          -- We need to avoid processing jumps to labels, they are of the form:
-          -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
-          else if B.index c labelStart == 'L'
+          else if B.head targ == 'L'
                 then fixupStack b $ f' `B.append` a `B.append` l
                 else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
                                     x `B.append` l
+#endif
 
--- | read an int or error
+-- | Read an int or error
 readInt :: B.ByteString -> Int
 readInt str | B.all isDigit str = (read . B.unpack) str
-            | otherwise = error $ "LLvmMangler Cannot read" ++ show str
-                                ++ "as it's not an Int"
+            | otherwise = error $ "LLvmMangler Cannot read " ++ show str
+                                ++ " as it's not an Int"
 
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 67515e5..372bd35 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -233,5 +233,5 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
 errorsToGhcException :: [Located String] -> GhcException
 errorsToGhcException errs =
    let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
-   in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
+   in UsageError (renderWithStyle errors cmdlineParserStyle)
 
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index f503077..f5e3394 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -8,9 +8,7 @@ module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
 
-#ifndef OMIT_NATIVE_CODEGEN
-import AsmCodeGen	( nativeCodeGen )
-#endif
+import AsmCodeGen ( nativeCodeGen )
 import LlvmCodeGen ( llvmCodeGen )
 
 import UniqSupply	( mkSplitUniqSupply )
@@ -149,24 +147,16 @@ outputC dflags filenm flat_absC packages
 
 \begin{code}
 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-
-#ifndef OMIT_NATIVE_CODEGEN
-
 outputAsm dflags filenm flat_absC
+ | cGhcWithNativeCodeGen == "YES"
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
        {-# SCC "OutputAsm" #-} doOutput filenm $
-	   \f -> {-# SCC "NativeCodeGen" #-}
-	         nativeCodeGen dflags f ncg_uniqs flat_absC
-  where
+           \f -> {-# SCC "NativeCodeGen" #-}
+                 nativeCodeGen dflags f ncg_uniqs flat_absC
 
-#else /* OMIT_NATIVE_CODEGEN */
-
-outputAsm _ _ _
-  = pprPanic "This compiler was built without a native code generator"
-	     (text "Use -fvia-C instead")
-
-#endif
+ | otherwise
+  = panic "This compiler was built without a native code generator"
 \end{code}
 
 
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index e430c6e..1694aba 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,7 +16,6 @@ module DriverMkDepend (
 #include "HsVersions.h"
 
 import qualified GHC
--- import GHC              ( ModSummary(..), GhcMonad )
 import GhcMonad
 import HsSyn            ( ImportDecl(..) )
 import DynFlags
@@ -35,7 +34,6 @@ import FastString
 
 import Exception
 import ErrUtils
--- import MonadUtils       ( liftIO )
 
 import System.Directory
 import System.FilePath
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index f6a9738..4702682 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -143,11 +143,7 @@ nextPhase (Hsc   _)     = HCc
 nextPhase SplitMangle   = As
 nextPhase As            = SplitAs
 nextPhase LlvmOpt       = LlvmLlc
-#if darwin_TARGET_OS
 nextPhase LlvmLlc       = LlvmMangle
-#else
-nextPhase LlvmLlc       = As
-#endif
 nextPhase LlvmMangle    = As
 nextPhase SplitAs       = MergeStub
 nextPhase Ccpp          = As
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index c23f674..2719470 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -51,11 +51,10 @@ import SrcLoc
 import FastString
 import LlvmCodeGen      ( llvmFixupAsm )
 import MonadUtils
+import Platform
 
--- import Data.Either
 import Exception
 import Data.IORef       ( readIORef )
--- import GHC.Exts              ( Int(..) )
 import System.Directory
 import System.FilePath
 import System.IO
@@ -269,11 +268,11 @@ link :: GhcLink                 -- interactive or batch
 -- exports main, i.e., we have good reason to believe that linking
 -- will succeed.
 
-#ifdef GHCI
 link LinkInMemory _ _ _
-    = do -- Not Linking...(demand linker will do the job)
-         return Succeeded
-#endif
+    = if cGhcWithInterpreter == "YES"
+      then -- Not Linking...(demand linker will do the job)
+           return Succeeded
+      else panicBadLink LinkInMemory
 
 link NoLink _ _ _
    = return Succeeded
@@ -284,11 +283,6 @@ link LinkBinary dflags batch_attempt_linking hpt
 link LinkDynLib dflags batch_attempt_linking hpt
    = link' dflags batch_attempt_linking hpt
 
-#ifndef GHCI
--- warning suppression
-link other _ _ _ = panicBadLink other
-#endif
-
 panicBadLink :: GhcLink -> a
 panicBadLink other = panic ("link: GHC not built to link this way: " ++
                             show other)
@@ -779,9 +773,9 @@ runPhase (Cpp sf) input_fn dflags0
             src_opts <- io $ getOptionsFromFile dflags0 output_fn
             (dflags2, unhandled_flags, warns)
                 <- io $ parseDynamicNoPackageFlags dflags0 src_opts
+            io $ checkProcessArgsResult unhandled_flags
             unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
             -- the HsPp pass below will emit warnings
-            io $ checkProcessArgsResult unhandled_flags
 
             setDynFlags dflags2
 
@@ -814,8 +808,8 @@ runPhase (HsPp sf) input_fn dflags
             (dflags1, unhandled_flags, warns)
                 <- io $ parseDynamicNoPackageFlags dflags src_opts
             setDynFlags dflags1
-            io $ handleFlagWarnings dflags1 warns
             io $ checkProcessArgsResult unhandled_flags
+            io $ handleFlagWarnings dflags1 warns
 
             return (Hsc sf, output_fn)
 
@@ -1027,7 +1021,6 @@ runPhase cc_phase input_fn dflags
         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
                               (cmdline_include_paths ++ pkg_include_dirs)
 
-        let md_c_flags = machdepCCOpts dflags
         let gcc_extra_viac_flags = extraGccViaCFlags dflags
         let pic_c_flags = picCCOpts dflags
 
@@ -1062,15 +1055,14 @@ runPhase cc_phase input_fn dflags
 
         let
           more_hcc_opts =
-#if i386_TARGET_ARCH
                 -- on x86 the floating point regs have greater precision
                 -- than a double, which leads to unpredictable results.
                 -- By default, we turn this off with -ffloat-store unless
                 -- the user specified -fexcess-precision.
-                (if dopt Opt_ExcessPrecision dflags
-                        then []
-                        else [ "-ffloat-store" ]) ++
-#endif
+                (if platformArch (targetPlatform dflags) == ArchX86 &&
+                    not (dopt Opt_ExcessPrecision dflags)
+                        then [ "-ffloat-store" ]
+                        else []) ++
 
                 -- gcc's -fstrict-aliasing allows two accesses to memory
                 -- to be considered non-aliasing if they have different types.
@@ -1092,29 +1084,28 @@ runPhase cc_phase input_fn dflags
                         , SysTools.FileOption "" output_fn
                         ]
                        ++ map SysTools.Option (
-                          md_c_flags
-                       ++ pic_c_flags
+                          pic_c_flags
 
-#if    defined(mingw32_TARGET_OS)
                 -- Stub files generated for foreign exports references the runIO_closure
                 -- and runNonIO_closure symbols, which are defined in the base package.
                 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
                 -- way we do the import depends on whether we're currently compiling
                 -- the base package or not.
-                       ++ (if thisPackage dflags == basePackageId
+                       ++ (if platformOS (targetPlatform dflags) == OSMinGW32 &&
+                              thisPackage dflags == basePackageId
                                 then [ "-DCOMPILING_BASE_PACKAGE" ]
                                 else [])
-#endif
 
-#ifdef sparc_TARGET_ARCH
         -- We only support SparcV9 and better because V8 lacks an atomic CAS
         -- instruction. Note that the user can still override this
         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
         -- regardless of the ordering.
         --
         -- This is a temporary hack.
-                       ++ ["-mcpu=v9"]
-#endif
+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then ["-mcpu=v9"]
+                           else [])
+
                        ++ (if hcc
                              then gcc_extra_viac_flags ++ more_hcc_opts
                              else [])
@@ -1178,11 +1169,10 @@ runPhase As input_fn dflags
         -- might be a hierarchical module.
         io $ createDirectoryHierarchy (takeDirectory output_fn)
 
-        let md_c_flags = machdepCCOpts dflags
         io $ SysTools.runAs dflags
                        (map SysTools.Option as_opts
                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
-#ifdef sparc_TARGET_ARCH
+
         -- We only support SparcV9 and better because V8 lacks an atomic CAS
         -- instruction so we have to make sure that the assembler accepts the
         -- instruction set. Note that the user can still override this
@@ -1190,14 +1180,15 @@ runPhase As input_fn dflags
         -- regardless of the ordering.
         --
         -- This is a temporary hack.
-                       ++ [ SysTools.Option "-mcpu=v9" ]
-#endif
+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then [SysTools.Option "-mcpu=v9"]
+                           else [])
+
                        ++ [ SysTools.Option "-c"
                           , SysTools.FileOption "" input_fn
                           , SysTools.Option "-o"
                           , SysTools.FileOption "" output_fn
-                          ]
-                       ++ map SysTools.Option md_c_flags)
+                          ])
 
         return (next_phase, output_fn)
 
@@ -1233,11 +1224,10 @@ runPhase SplitAs _input_fn dflags
             split_obj n = split_odir </>
                           takeFileName base_o ++ "__" ++ show n <.> osuf
 
-        let md_c_flags = machdepCCOpts dflags
         let assemble_file n
               = SysTools.runAs dflags
                          (map SysTools.Option as_opts ++
-#ifdef sparc_TARGET_ARCH
+
         -- We only support SparcV9 and better because V8 lacks an atomic CAS
         -- instruction so we have to make sure that the assembler accepts the
         -- instruction set. Note that the user can still override this
@@ -1245,14 +1235,15 @@ runPhase SplitAs _input_fn dflags
         -- regardless of the ordering.
         --
         -- This is a temporary hack.
-                          [ SysTools.Option "-mcpu=v9" ] ++
-#endif
+                          (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then [SysTools.Option "-mcpu=v9"]
+                           else []) ++
+
                           [ SysTools.Option "-c"
                           , SysTools.Option "-o"
                           , SysTools.FileOption "" (split_obj n)
                           , SysTools.FileOption "" (split_s n)
-                          ]
-                       ++ map SysTools.Option md_c_flags)
+                          ])
 
         io $ mapM_ assemble_file [1..n]
 
@@ -1314,24 +1305,18 @@ runPhase LlvmOpt input_fn dflags
         -- fix up some pretty big deficiencies in the code we generate
         llvmOpts = ["-mem2reg", "-O1", "-O2"]
 
-
 -----------------------------------------------------------------------------
 -- LlvmLlc phase
 
 runPhase LlvmLlc input_fn dflags
   = do
     let lc_opts = getOpts dflags opt_lc
-    let opt_lvl = max 0 (min 2 $ optLevel dflags)
-#if darwin_TARGET_OS
-    let nphase = LlvmMangle
-#else
-    let nphase = As
-#endif
-    let rmodel | opt_PIC        = "pic"
+        opt_lvl = max 0 (min 2 $ optLevel dflags)
+        rmodel | opt_PIC        = "pic"
                | not opt_Static = "dynamic-no-pic"
                | otherwise      = "static"
 
-    output_fn <- phaseOutputFilename nphase
+    output_fn <- phaseOutputFilename LlvmMangle
 
     io $ SysTools.runLlvmLlc dflags
                 ([ SysTools.Option (llvmOpts !! opt_lvl),
@@ -1340,14 +1325,12 @@ runPhase LlvmLlc input_fn dflags
                     SysTools.Option "-o", SysTools.FileOption "" output_fn]
                 ++ map SysTools.Option lc_opts)
 
-    return (nphase, output_fn)
+    return (LlvmMangle, output_fn)
   where
-#if darwin_TARGET_OS
-        llvmOpts = ["-O1", "-O2", "-O2"]
-#else
-        llvmOpts = ["-O1", "-O2", "-O3"]
-#endif
-
+        -- Bug in LLVM at O3 on OSX.
+        llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
+                   then ["-O1", "-O2", "-O2"]
+                   else ["-O1", "-O2", "-O3"]
 
 -----------------------------------------------------------------------------
 -- LlvmMangle phase
@@ -1419,14 +1402,12 @@ mkExtraCObj dflags xs
       oFile <- newTempName dflags "o"
       writeFile cFile xs
       let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
-          md_c_flags = machdepCCOpts dflags
       SysTools.runCc dflags
                      ([Option        "-c",
                        FileOption "" cFile,
                        Option        "-o",
                        FileOption "" oFile] ++
-                      map (FileOption "-I") (includeDirs rtsDetails) ++
-                      map Option md_c_flags)
+                      map (FileOption "-I") (includeDirs rtsDetails))
       return oFile
 
 mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
@@ -1654,20 +1635,20 @@ linkBinary dflags o_files dep_packages = do
 
     rc_objs <- maybeCreateManifest dflags output_fn
 
-    let md_c_flags = machdepCCOpts dflags
     SysTools.runLink dflags (
                        map SysTools.Option verbFlags
                       ++ [ SysTools.Option "-o"
                          , SysTools.FileOption "" output_fn
                          ]
                       ++ map SysTools.Option (
-                         md_c_flags
+                         []
 
-#ifdef mingw32_TARGET_OS
                       -- Permit the linker to auto link _symbol to _imp_symbol.
                       -- This lets us link against DLLs without needing an "import library".
-                      ++ ["-Wl,--enable-auto-import"]
-#endif
+                      ++ (if platformOS (targetPlatform dflags) == OSMinGW32
+                          then ["-Wl,--enable-auto-import"]
+                          else [])
+
                       ++ o_files
                       ++ extra_ld_inputs
                       ++ lib_path_opts
@@ -1698,19 +1679,15 @@ linkBinary dflags o_files dep_packages = do
 exeFileName :: DynFlags -> FilePath
 exeFileName dflags
   | Just s <- outputFile dflags =
-#if defined(mingw32_HOST_OS)
-      if null (takeExtension s)
-        then s <.> "exe"
-        else s
-#else
-      s
-#endif
+      if platformOS (targetPlatform dflags) == OSMinGW32
+      then if null (takeExtension s)
+           then s <.> "exe"
+           else s
+      else s
   | otherwise =
-#if defined(mingw32_HOST_OS)
-        "main.exe"
-#else
-        "a.out"
-#endif
+      if platformOS (targetPlatform dflags) == OSMinGW32
+      then "main.exe"
+      else "a.out"
 
 maybeCreateManifest
    :: DynFlags
@@ -1806,7 +1783,6 @@ linkDynLib dflags o_files dep_packages = do
         -- probably _stub.o files
     extra_ld_inputs <- readIORef v_Ld_inputs
 
-    let md_c_flags = machdepCCOpts dflags
     let extra_ld_opts = getOpts dflags opt_l
 
     extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
@@ -1828,11 +1804,10 @@ linkDynLib dflags o_files dep_packages = do
             ]
          ++ map (SysTools.FileOption "") o_files
          ++ map SysTools.Option (
-            md_c_flags
 
          -- Permit the linker to auto link _symbol to _imp_symbol
          -- This lets us link against DLLs without needing an "import library"
-         ++ ["-Wl,--enable-auto-import"]
+            ["-Wl,--enable-auto-import"]
 
          ++ extra_ld_inputs
          ++ lib_path_opts
@@ -1884,8 +1859,7 @@ linkDynLib dflags o_files dep_packages = do
             , SysTools.FileOption "" output_fn
             ]
          ++ map SysTools.Option (
-            md_c_flags
-         ++ o_files
+            o_files
          ++ [ "-undefined", "dynamic_lookup", "-single_module",
 #if !defined(x86_64_TARGET_ARCH)
               "-Wl,-read_only_relocs,suppress",
@@ -1919,8 +1893,7 @@ linkDynLib dflags o_files dep_packages = do
             , SysTools.FileOption "" output_fn
             ]
          ++ map SysTools.Option (
-            md_c_flags
-         ++ o_files
+            o_files
          ++ [ "-shared" ]
          ++ bsymbolicFlag
             -- Set the library soname. We use -h rather than -soname as
@@ -1949,11 +1922,8 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
     let verbFlags = getVerbFlags dflags
 
     let cc_opts
-          | not include_cc_opts = []
-          | otherwise           = (optc ++ md_c_flags)
-                where
-                      optc = getOpts dflags opt_c
-                      md_c_flags = machdepCCOpts dflags
+          | include_cc_opts = getOpts dflags opt_c
+          | otherwise       = []
 
     let cpp_prog args | raw       = SysTools.runCpp dflags args
                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
@@ -2005,7 +1975,6 @@ joinObjectFiles dflags o_files output_fn = do
                             SysTools.Option ld_x_flag,
                             SysTools.Option "-o",
                             SysTools.FileOption "" output_fn ]
-                         ++ map SysTools.Option md_c_flags
                          ++ args)
 
       ld_x_flag | null cLD_X = ""
@@ -2017,8 +1986,6 @@ joinObjectFiles dflags o_files output_fn = do
       ld_build_id | cLdHasBuildId == "YES"  = "-Wl,--build-id=none"
                   | otherwise               = ""
 
-      md_c_flags = machdepCCOpts dflags
-  
   if cLdIsGNULd == "YES"
      then do
           script <- newTempName dflags "ldscript"
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6fe6708..7e5dff0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -60,7 +60,7 @@ module DynFlags (
         supportedLanguagesAndExtensions,
 
         -- ** DynFlag C compiler options
-        machdepCCOpts, picCCOpts,
+        picCCOpts,
 
         -- * Configuration of the stg-to-stg passes
         StgToDo(..),
@@ -77,9 +77,7 @@ module DynFlags (
 
 #include "HsVersions.h"
 
-#ifndef OMIT_NATIVE_CODEGEN
 import Platform
-#endif
 import Module
 import PackageConfig
 import PrelNames        ( mAIN )
@@ -110,7 +108,8 @@ import Data.Char
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
--- import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 
@@ -125,6 +124,21 @@ data DynFlag
    | Opt_D_dump_raw_cmm
    | Opt_D_dump_cmmz
    | Opt_D_dump_cmmz_pretty
+   -- All of the cmmz subflags (there are a lot!)  Automatically
+   -- enabled if you run -ddump-cmmz
+   | Opt_D_dump_cmmz_cbe
+   | Opt_D_dump_cmmz_proc
+   | Opt_D_dump_cmmz_spills
+   | Opt_D_dump_cmmz_rewrite
+   | Opt_D_dump_cmmz_dead
+   | Opt_D_dump_cmmz_stub
+   | Opt_D_dump_cmmz_sp
+   | Opt_D_dump_cmmz_procmap
+   | Opt_D_dump_cmmz_split
+   | Opt_D_dump_cmmz_lower
+   | Opt_D_dump_cmmz_info
+   | Opt_D_dump_cmmz_cafs
+   -- end cmmz subflags
    | Opt_D_dump_cps_cmm
    | Opt_D_dump_cvt_cmm
    | Opt_D_dump_asm
@@ -267,7 +281,6 @@ data DynFlag
    -- misc opts
    | Opt_Pp
    | Opt_ForceRecomp
-   | Opt_DryRun
    | Opt_ExcessPrecision
    | Opt_EagerBlackHoling
    | Opt_ReadUserPackageConf
@@ -331,7 +344,6 @@ data ExtensionFlag
    | Opt_TemplateHaskell
    | Opt_QuasiQuotes
    | Opt_ImplicitParams
-   | Opt_Generics			-- "Derivable type classes"
    | Opt_ImplicitPrelude
    | Opt_ScopedTypeVariables
    | Opt_UnboxedTuples
@@ -353,6 +365,9 @@ data ExtensionFlag
    | Opt_DeriveFunctor
    | Opt_DeriveTraversable
    | Opt_DeriveFoldable
+   | Opt_DeriveGeneric            -- Allow deriving Generic/1
+   | Opt_DefaultSignatures        -- Allow extra signatures for defmeths
+   | Opt_Generics                 -- Old generic classes, now deprecated
 
    | Opt_TypeSynonymInstances
    | Opt_FlexibleContexts
@@ -368,6 +383,7 @@ data ExtensionFlag
    | Opt_KindSignatures
    | Opt_ParallelListComp
    | Opt_TransformListComp
+   | Opt_MonadComprehensions
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_DoRec
@@ -410,9 +426,7 @@ data DynFlags = DynFlags {
   floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating
   			   	 	--   See CoreMonad.FloatOutSwitches
 
-#ifndef OMIT_NATIVE_CODEGEN
-  targetPlatform	:: Platform,	-- ^ The platform we're compiling for. Used by the NCG.
-#endif
+  targetPlatform        :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG.
   cmdlineHcIncludes     :: [String],    -- ^ @\-\#includes@
   importPaths           :: [FilePath],
   mainModIs             :: Module,
@@ -491,6 +505,11 @@ data DynFlags = DynFlags {
   filesToClean          :: IORef [FilePath],
   dirsToClean           :: IORef (Map FilePath FilePath),
 
+  -- Names of files which were generated from -ddump-to-file; used to
+  -- track which ones we need to truncate because it's our first run
+  -- through
+  generatedDumps        :: IORef (Set FilePath),
+
   -- hsc dynamic flags
   flags                 :: [DynFlag],
   -- Don't change this without updating extensionFlags:
@@ -638,6 +657,14 @@ data HscTarget
   | HscNothing     -- ^ Don't generate any code.  See notes above.
   deriving (Eq, Show)
 
+showHscTargetFlag :: HscTarget -> String
+showHscTargetFlag HscC           = "-fvia-c"
+showHscTargetFlag HscAsm         = "-fasm"
+showHscTargetFlag HscLlvm        = "-fllvm"
+showHscTargetFlag HscJava        = panic "No flag for HscJava"
+showHscTargetFlag HscInterpreted = "-fbyte-code"
+showHscTargetFlag HscNothing     = "-fno-code"
+
 -- | Will this target result in an object file on the disk?
 isObjectTarget :: HscTarget -> Bool
 isObjectTarget HscC     = True
@@ -700,8 +727,9 @@ defaultHscTarget = defaultObjectTarget
 -- object files on the current platform.
 defaultObjectTarget :: HscTarget
 defaultObjectTarget
+  | cGhcUnregisterised    == "YES"      =  HscC
   | cGhcWithNativeCodeGen == "YES"      =  HscAsm
-  | otherwise                           =  HscC
+  | otherwise                           =  HscLlvm
 
 data DynLibLoader
   = Deployable
@@ -718,12 +746,14 @@ initDynFlags dflags = do
  ways <- readIORef v_Ways
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
+ refGeneratedDumps <- newIORef Set.empty
  return dflags{
         ways            = ways,
         buildTag        = mkBuildTag (filter (not . wayRTSOnly) ways),
         rtsBuildTag     = mkBuildTag ways,
         filesToClean    = refFilesToClean,
-        dirsToClean     = refDirsToClean
+        dirsToClean     = refDirsToClean,
+        generatedDumps   = refGeneratedDumps
         }
 
 -- | The normal 'DynFlags'. Note that they is not suitable for use in this form
@@ -742,15 +772,13 @@ defaultDynFlags mySettings =
         maxSimplIterations      = 4,
         shouldDumpSimplPhase    = Nothing,
         ruleCheck               = Nothing,
-        specConstrThreshold     = Just 200,
+        specConstrThreshold     = Just 2000,
         specConstrCount         = Just 3,
-        liberateCaseThreshold   = Just 200,
+        liberateCaseThreshold   = Just 2000,
         floatLamArgs            = Just 0,	-- Default: float only if no fvs
         strictnessBefore        = [],
 
-#ifndef OMIT_NATIVE_CODEGEN
         targetPlatform          = defaultTargetPlatform,
-#endif
         cmdlineHcIncludes       = [],
         importPaths             = ["."],
         mainModIs               = mAIN,
@@ -801,6 +829,7 @@ defaultDynFlags mySettings =
         -- end of ghc -M values
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
+        generatedDumps = panic "defaultDynFlags: No generatedDumps",
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,
@@ -809,12 +838,12 @@ defaultDynFlags mySettings =
 
         log_action = \severity srcSpan style msg ->
                         case severity of
-                          SevOutput -> printOutput (msg style)
-                          SevInfo   -> printErrs (msg style)
-                          SevFatal  -> printErrs (msg style)
+                          SevOutput -> printSDoc msg style
+                          SevInfo   -> printErrs msg style
+                          SevFatal  -> printErrs msg style
                           _         -> do 
                                 hPutChar stderr '\n'
-                                printErrs ((mkLocMessage srcSpan msg) style)
+                                printErrs (mkLocMessage srcSpan msg) style
                      -- careful (#2302): printErrs prints in UTF-8, whereas
                      -- converting to string first and using hPutStr would
                      -- just emit the low 8 bits of each unicode char.
@@ -854,7 +883,11 @@ languageExtensions Nothing
       -- But NB it's implied by GADTs etc
       -- SLPJ September 2010
     : Opt_NondecreasingIndentation -- This has been on by default for some time
-    : languageExtensions (Just Haskell2010)
+    : delete Opt_DatatypeContexts  -- The Haskell' committee decided to
+                                   -- remove datatype contexts from the
+                                   -- language:
+   -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
+      (languageExtensions (Just Haskell2010))
 
 languageExtensions (Just Haskell98)
     = [Opt_ImplicitPrelude,
@@ -1106,16 +1139,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do
           = runCmdLine (processArgs flag_spec args') dflags0
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
-  let (pic_warns, dflags2)
-#if !(x86_64_TARGET_ARCH && linux_TARGET_OS)
-        | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm
-        = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -"
-                ++ "dynamic on this platform;\n              ignoring -fllvm"],
-                dflags1{ hscTarget = HscAsm })
-#endif
-        | otherwise = ([], dflags1)
-
-  return (dflags2, leftover, pic_warns ++ warns)
+  return (dflags1, leftover, warns)
 
 
 {- **********************************************************************
@@ -1139,7 +1163,7 @@ allFlags = map ('-':) $
 --------------- The main flags themselves ------------------
 dynamic_flags :: [Flag (CmdLineP DynFlags)]
 dynamic_flags = [
-    Flag "n"        (NoArg (setDynFlag Opt_DryRun))
+    Flag "n"        (NoArg (addWarn "The -n flag is deprecated and no longer has any effect"))
   , Flag "cpp"      (NoArg (setExtensionFlag Opt_Cpp)) 
   , Flag "F"        (NoArg (setDynFlag Opt_Pp)) 
   , Flag "#include" 
@@ -1199,8 +1223,8 @@ dynamic_flags = [
   , Flag "dylib-install-name" (hasArg setDylibInstallName)
 
         ------- Libraries ---------------------------------------------------
-  , Flag "L"   (Prefix    addLibraryPath)
-  , Flag "l"   (AnySuffix (upd . addOptl))
+  , Flag "L"   (Prefix addLibraryPath)
+  , Flag "l"   (hasArg (addOptl . ("-l" ++)))
 
         ------- Frameworks --------------------------------------------------
         -- -framework-path should really be -F ...
@@ -1268,6 +1292,18 @@ dynamic_flags = [
   , Flag "ddump-raw-cmm"           (setDumpFlag Opt_D_dump_raw_cmm)
   , Flag "ddump-cmmz"              (setDumpFlag Opt_D_dump_cmmz)
   , Flag "ddump-cmmz-pretty"       (setDumpFlag Opt_D_dump_cmmz_pretty)
+  , Flag "ddump-cmmz-cbe"          (setDumpFlag Opt_D_dump_cmmz_cbe)
+  , Flag "ddump-cmmz-spills"       (setDumpFlag Opt_D_dump_cmmz_spills)
+  , Flag "ddump-cmmz-proc"         (setDumpFlag Opt_D_dump_cmmz_proc)
+  , Flag "ddump-cmmz-rewrite"      (setDumpFlag Opt_D_dump_cmmz_rewrite)
+  , Flag "ddump-cmmz-dead"         (setDumpFlag Opt_D_dump_cmmz_dead)
+  , Flag "ddump-cmmz-stub"         (setDumpFlag Opt_D_dump_cmmz_stub)
+  , Flag "ddump-cmmz-sp"           (setDumpFlag Opt_D_dump_cmmz_sp)
+  , Flag "ddump-cmmz-procmap"      (setDumpFlag Opt_D_dump_cmmz_procmap)
+  , Flag "ddump-cmmz-split"        (setDumpFlag Opt_D_dump_cmmz_split)
+  , Flag "ddump-cmmz-lower"        (setDumpFlag Opt_D_dump_cmmz_lower)
+  , Flag "ddump-cmmz-info"         (setDumpFlag Opt_D_dump_cmmz_info)
+  , Flag "ddump-cmmz-cafs"         (setDumpFlag Opt_D_dump_cmmz_cafs)
   , Flag "ddump-core-stats"        (setDumpFlag Opt_D_dump_core_stats)
   , Flag "ddump-cps-cmm"           (setDumpFlag Opt_D_dump_cps_cmm)
   , Flag "ddump-cvt-cmm"           (setDumpFlag Opt_D_dump_cvt_cmm)
@@ -1361,10 +1397,11 @@ dynamic_flags = [
   , Flag "w"      (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
 
         ------ Optimisation flags ------------------------------------------
-  , Flag "O"      (noArg (setOptLevel 1))
-  , Flag "Onot"   (noArgDF (setOptLevel 0) "Use -O0 instead")
-  , Flag "Odph"   (noArg setDPHOpt)
-  , Flag "O"      (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
+  , Flag "O"      (noArgM (setOptLevel 1))
+  , Flag "Onot"   (noArgM (\dflags -> do deprecate "Use -O0 instead"
+                                         setOptLevel 0 dflags))
+  , Flag "Odph"   (noArgM setDPHOpt)
+  , Flag "O"      (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1)))
                 -- If the number is missing, use 1
 
   , Flag "fsimplifier-phases"          (intSuffix (\n d -> d{ simplPhases = n }))
@@ -1631,6 +1668,7 @@ xFlags = [
   ( "EmptyDataDecls",                   Opt_EmptyDataDecls, nop ),
   ( "ParallelListComp",                 Opt_ParallelListComp, nop ),
   ( "TransformListComp",                Opt_TransformListComp, nop ),
+  ( "MonadComprehensions",              Opt_MonadComprehensions, nop),
   ( "ForeignFunctionInterface",         Opt_ForeignFunctionInterface, nop ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes, nop ),
   ( "GHCForeignImportPrim",             Opt_GHCForeignImportPrim, nop ),
@@ -1639,15 +1677,16 @@ xFlags = [
   ( "RankNTypes",                       Opt_RankNTypes, nop ),
   ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop), 
   ( "TypeOperators",                    Opt_TypeOperators, nop ),
-  ( "RecursiveDo",                      Opt_RecursiveDo,
+  ( "RecursiveDo",                      Opt_RecursiveDo,     -- Enables 'mdo'
     deprecatedForExtension "DoRec"),
-  ( "DoRec",                            Opt_DoRec, nop ),
+  ( "DoRec",                            Opt_DoRec, nop ),    -- Enables 'rec' keyword 
   ( "Arrows",                           Opt_Arrows, nop ),
   ( "ModalTypes",			Opt_ModalTypes, nop ),
   ( "ParallelArrays",                   Opt_ParallelArrays, nop ),
   ( "TemplateHaskell",                  Opt_TemplateHaskell, checkTemplateHaskellOk ),
   ( "QuasiQuotes",                      Opt_QuasiQuotes, nop ),
-  ( "Generics",                         Opt_Generics, nop ),
+  ( "Generics",                         Opt_Generics,
+    \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ),
   ( "ImplicitPrelude",                  Opt_ImplicitPrelude, nop ),
   ( "RecordWildCards",                  Opt_RecordWildCards, nop ),
   ( "NamedFieldPuns",                   Opt_RecordPuns, nop ),
@@ -1689,6 +1728,8 @@ xFlags = [
   ( "DeriveFunctor",                    Opt_DeriveFunctor, nop ),
   ( "DeriveTraversable",                Opt_DeriveTraversable, nop ),
   ( "DeriveFoldable",                   Opt_DeriveFoldable, nop ),
+  ( "DeriveGeneric",                    Opt_DeriveGeneric, nop ),
+  ( "DefaultSignatures",                Opt_DefaultSignatures, nop ),
   ( "TypeSynonymInstances",             Opt_TypeSynonymInstances, nop ),
   ( "FlexibleContexts",                 Opt_FlexibleContexts, nop ),
   ( "FlexibleInstances",                Opt_FlexibleInstances, nop ),
@@ -1874,6 +1915,7 @@ glasgowExtsFlags = [
            , Opt_DeriveFunctor
            , Opt_DeriveFoldable
            , Opt_DeriveTraversable
+           , Opt_DeriveGeneric
            , Opt_FlexibleContexts
            , Opt_FlexibleInstances
            , Opt_ConstrainedClassMethods
@@ -1926,13 +1968,21 @@ checkTemplateHaskellOk _ = return ()
 type DynP = EwM (CmdLineP DynFlags)
 
 upd :: (DynFlags -> DynFlags) -> DynP ()
-upd f = liftEwM (do { dfs <- getCmdLineState
-                    ; putCmdLineState $! (f dfs) })
+upd f = liftEwM (do dflags <- getCmdLineState
+                    putCmdLineState $! f dflags)
+
+updM :: (DynFlags -> DynP DynFlags) -> DynP ()
+updM f = do dflags <- liftEwM getCmdLineState
+            dflags' <- f dflags
+            liftEwM $ putCmdLineState $! dflags'
 
 --------------- Constructor functions for OptKind -----------------
 noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
 noArg fn = NoArg (upd fn)
 
+noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
+noArgM fn = NoArg (updM fn)
+
 noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags)
 noArgDF fn deprec = NoArg (upd fn >> deprecate deprec)
 
@@ -1946,6 +1996,10 @@ hasArgDF fn deprec = HasArg (\s -> do { upd (fn s)
 intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
 intSuffix fn = IntSuffix (\n -> upd (fn n))
 
+optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)
+              -> OptKind (CmdLineP DynFlags)
+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
+
 setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags)
 setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
 
@@ -1993,14 +2047,13 @@ forceRecompile :: DynP ()
 -- recompiled which probably isn't what you want
 forceRecompile = do { dfs <- liftEwM getCmdLineState
 	       	    ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) }
-	where
+        where
 	  force_recomp dfs = isOneShot (ghcMode dfs)
 
 setVerboseCore2Core :: DynP ()
 setVerboseCore2Core = do forceRecompile
                          setDynFlag Opt_D_verbose_core2core 
                          upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
-		         
 
 setDumpSimplPhases :: String -> DynP ()
 setDumpSimplPhases s = do forceRecompile
@@ -2044,20 +2097,43 @@ setTarget l = upd set
 -- not from bytecode to object-code.  The idea is that -fasm/-fllvm
 -- can be safely used in an OPTIONS_GHC pragma.
 setObjTarget :: HscTarget -> DynP ()
-setObjTarget l = upd set
+setObjTarget l = updM set
   where
-   set dfs
-     | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
-     | otherwise = dfs
-
-setOptLevel :: Int -> DynFlags -> DynFlags
+   set dflags
+     | isObjectTarget (hscTarget dflags)
+       = case l of
+         HscC
+          | cGhcUnregisterised /= "YES" ->
+             do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
+                return dflags
+         HscAsm
+          | cGhcWithNativeCodeGen /= "YES" ->
+             do addWarn ("Compiler has no native codegen, so ignoring " ++
+                         flag)
+                return dflags
+         HscLlvm
+          | cGhcUnregisterised == "YES" ->
+             do addWarn ("Compiler unregisterised, so ignoring " ++ flag)
+                return dflags
+          | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
+            (not opt_Static || opt_PIC)
+            ->
+             do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
+                return dflags
+         _ -> return $ dflags { hscTarget = l }
+     | otherwise = return dflags
+     where platform = targetPlatform dflags
+           arch = platformArch platform
+           os   = platformOS   platform
+           flag = showHscTargetFlag l
+
+setOptLevel :: Int -> DynFlags -> DynP DynFlags
 setOptLevel n dflags
    | hscTarget dflags == HscInterpreted && n > 0
-        = dflags
-            -- not in IO any more, oh well:
-            -- putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+        = do addWarn "-O conflicts with --interactive; -O ignored."
+             return dflags
    | otherwise
-        = updOptLevel n dflags
+        = return (updOptLevel n dflags)
 
 
 -- -Odph is equivalent to
@@ -2066,7 +2142,7 @@ setOptLevel n dflags
 --    -fmax-simplifier-iterations20     this is necessary sometimes
 --    -fsimplifier-phases=3             we use an additional simplifier phase for fusion
 --
-setDPHOpt :: DynFlags -> DynFlags
+setDPHOpt :: DynFlags -> DynP DynFlags
 setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
                                          , simplPhases         = 3
                                          })
@@ -2118,7 +2194,6 @@ addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> D
 addImportPath "" = upd (\s -> s{importPaths = []})
 addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
 
-
 addLibraryPath p =
   upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
 
@@ -2222,37 +2297,6 @@ setOptHpcDir arg  = upd $ \ d -> d{hpcDir = arg}
 -- The options below are not dependent on the version of gcc, only the
 -- platform.
 
-machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations
-machdepCCOpts _ = cCcOpts ++ machdepCCOpts'
-
-machdepCCOpts' :: [String] -- flags for all C compilations
-machdepCCOpts'
-#if alpha_TARGET_ARCH
-        =       ["-w", "-mieee"
-#ifdef HAVE_THREADED_RTS_SUPPORT
-                    , "-D_REENTRANT"
-#endif
-                   ]
-        -- For now, to suppress the gcc warning "call-clobbered
-        -- register used for global register variable", we simply
-        -- disable all warnings altogether using the -w flag. Oh well.
-
-#elif hppa_TARGET_ARCH
-        -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
-        -- (very nice, but too bad the HP /usr/include files don't agree.)
-        = ["-D_HPUX_SOURCE"]
-
-#elif i386_TARGET_ARCH
-      -- -fno-defer-pop : basically the same game as for m68k
-      --
-      -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
-      --   the fp (%ebp) for our register maps.
-        =  if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else []
-
-#else
-        = []
-#endif
-
 picCCOpts :: DynFlags -> [String]
 picCCOpts _dflags
 #if darwin_TARGET_OS
@@ -2322,7 +2366,6 @@ compilerInfo dflags
        ("Debug on",                    show debugIsOn),
        ("LibDir",                      topDir dflags),
        ("Global Package DB",           systemPackageConfig dflags),
-       ("C compiler flags",            show cCcOpts),
        ("Gcc Linker flags",            show cGccLinkerOpts),
        ("Ld Linker flags",             show cLdLinkerOpts)
       ]
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d0a8a86..1c7a389 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -41,6 +41,9 @@ import StaticFlags	( opt_ErrorSpans )
 
 import System.Exit	( ExitCode(..), exitWith )
 import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
 import System.IO
 
 -- -----------------------------------------------------------------------------
@@ -67,7 +70,8 @@ mkLocMessage locn msg
   -- would look strange.  Better to say explicitly "<no location info>".
 
 printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+  printErrs (mkLocMessage span msg) defaultErrStyle
 
 
 -- -----------------------------------------------------------------------------
@@ -207,19 +211,26 @@ mkDumpDoc hdr doc
 --	otherwise emit to stdout.
 dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpSDoc dflags dflag hdr doc
- = do	let mFile	= chooseDumpFile dflags dflag
- 	case mFile of
-		-- write the dump to a file
-		--	don't add the header in this case, we can see what kind
-		--	of dump it is from the filename.
-		Just fileName
-		 -> do	handle	<- openFile fileName AppendMode
-		 	hPrintDump handle doc
-		 	hClose handle
-
-		-- write the dump to stdout
-		Nothing
-		 -> do	printDump (mkDumpDoc hdr doc)
+ = do let mFile = chooseDumpFile dflags dflag
+      case mFile of
+            -- write the dump to a file
+            -- don't add the header in this case, we can see what kind
+            -- of dump it is from the filename.
+            Just fileName
+                 -> do
+                        let gdref = generatedDumps dflags
+                        gd <- readIORef gdref
+                        let append = Set.member fileName gd
+                            mode = if append then AppendMode else WriteMode
+                        when (not append) $
+                            writeIORef gdref (Set.insert fileName gd)
+                        handle <- openFile fileName mode
+                        hPrintDump handle doc
+                        hClose handle
+
+            -- write the dump to stdout
+            Nothing
+                 -> printDump (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index a9e652d..44ec3ff 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -171,7 +171,7 @@ module GHC (
 	pprParendType, pprTypeApp, 
 	Kind,
 	PredType,
-	ThetaType, pprForAll, pprThetaArrow,
+	ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
 
 	-- ** Entities
 	TyThing(..), 
@@ -256,7 +256,6 @@ import Type
 import Coercion		( synTyConResKind )
 import TcType		hiding( typeKind )
 import Id
-import Var
 import TysPrim		( alphaTyVars )
 import TyCon
 import Class
@@ -388,7 +387,7 @@ runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> Ghc a           -- ^ The action to perform.
        -> IO a
 runGhc mb_top_dir ghc = do
-  ref <- newIORef undefined
+  ref <- newIORef (panic "empty session")
   let session = Session ref
   flip unGhc session $ do
     initGhcMonad mb_top_dir
@@ -406,7 +405,7 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
         -> GhcT m a        -- ^ The action to perform.
         -> m a
 runGhcT mb_top_dir ghct = do
-  ref <- liftIO $ newIORef undefined
+  ref <- liftIO $ newIORef (panic "empty session")
   let session = Session ref
   flip unGhcT session $ do
     initGhcMonad mb_top_dir
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0d41435..ab65894 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
   = do
         let dflags = hsc_dflags hsc_env
-	-- case we bypass the preprocessing stage?
-	let 
-	    local_opts = getOptions dflags buf src_fn
-	--
+	let local_opts = getOptions dflags buf src_fn
+
 	(dflags', leftovers, warns)
             <- parseDynamicNoPackageFlags dflags local_opts
         checkProcessArgsResult leftovers
         handleFlagWarnings dflags' warns
 
-	let
-	    needs_preprocessing
+	let needs_preprocessing
 		| Just (Unlit _) <- mb_phase    = True
 	        | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
 		  -- note: local_opts is only required if there's no Unlit phase
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 711259c..4c72f14 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -15,11 +15,11 @@ module GhcMonad (
         reflectGhc, reifyGhc,
         getSessionDynFlags, 
         liftIO,
-	Session(..), withSession, modifySession, withTempSession,
+        Session(..), withSession, modifySession, withTempSession,
 
         -- ** Warnings
         logWarnings, printException, printExceptionAndWarnings,
-	WarnErrLogger, defaultWarnErrLogger
+        WarnErrLogger, defaultWarnErrLogger
   ) where
 
 import MonadUtils
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 70ddd6a..6a5552f 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -1132,12 +1132,11 @@ hscTcExpr	-- Typecheck an expression (but don't run it)
 hscTcExpr hsc_env expr = runHsc hsc_env $ do
     maybe_stmt <- hscParseStmt expr
     case maybe_stmt of
-      Just (L _ (ExprStmt expr _ _)) ->
-          ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
-      _ -> 
-          liftIO $ throwIO $ mkSrcErr $ unitBag $ 
-              mkPlainErrMsg noSrcSpan
-                            (text "not an expression:" <+> quotes (text expr))
+        Just (L _ (ExprStmt expr _ _ _)) ->
+            ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+        _ ->
+            liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+                (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
 hscKcType
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index b96eb56..d902626 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 	      	("InstType         ", inst_type_ds),
 	      	("InstData         ", inst_data_ds),
 	      	("TypeSigs         ", bind_tys),
+	      	("GenericSigs      ", generic_sigs),
 	      	("ValBinds         ", val_bind_ds),
 	      	("FunBinds         ", fn_bind_ds),
 	      	("InlineMeths      ", method_inlines),
@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     
     trim ls     = takeWhile (not.isSpace) (dropWhile isSpace ls)
 
-    (fixity_sigs, bind_tys, bind_specs, bind_inlines) 
+    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) 
 	= count_sigs [d | SigD d <- decls]
 		-- NB: this omits fixity decls on local bindings and
 		-- in class decls.  ToDo
@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     count_bind (FunBind {})                           = (0,1)
     count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
 
-    count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+    count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
 
-    sig_info (FixSig _)		= (1,0,0,0)
-    sig_info (TypeSig _ _)      = (0,1,0,0)
-    sig_info (SpecSig _ _ _)    = (0,0,1,0)
-    sig_info (InlineSig _ _)    = (0,0,0,1)
-    sig_info _                  = (0,0,0,0)
+    sig_info (FixSig _)		= (1,0,0,0,0)
+    sig_info (TypeSig _ _)      = (0,1,0,0,0)
+    sig_info (SpecSig _ _ _)    = (0,0,1,0,0)
+    sig_info (InlineSig _ _)    = (0,0,0,1,0)
+    sig_info (GenericSig _ _)   = (0,0,0,0,1)
+    sig_info _                  = (0,0,0,0,0)
 
     import_info (L _ (ImportDecl _ _ _ qual as spec))
 	= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     class_info decl@(ClassDecl {})
 	= case count_sigs (map unLoc (tcdSigs decl)) of
-	    (_,classops,_,_) ->
+	    (_,classops,_,_,_) ->
 	       (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info _ = (0,0)
 
     inst_info (InstDecl _ inst_meths inst_sigs ats)
 	= case count_sigs (map unLoc inst_sigs) of
-	    (_,_,ss,is) ->
+	    (_,_,ss,is,_) ->
 	      case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
 	        (tyDecl, dtDecl) ->
 	          (addpr (foldr add2 (0,0) 
@@ -157,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     addpr :: (Int,Int) -> Int
     add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
-    add4  :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
     add5  :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
     add6  :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
 
     addpr (x,y) = x+y
     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-    add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
     add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
 \end{code}
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e59c223..22aa3f4 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -54,13 +54,13 @@ module HscTypes (
 
         -- * TyThings and type environments
 	TyThing(..),
-	tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
-	implicitTyThings, isImplicitTyThing,
+	tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
+	implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
 	
 	TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
 	extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
 	typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
-	typeEnvDataCons,
+	typeEnvDataCons, typeEnvCoAxioms,
 
         -- * MonadThings
         MonadThings(..),
@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
 -- | A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
 -- being compiled right now.  Once it is compiled, a 'ModIface' and 
--- 'ModDetails' are extracted and the ModGuts is dicarded.
+-- 'ModDetails' are extracted and the ModGuts is discarded.
 data ModGuts
   = ModGuts {
         mg_module    :: !Module,         -- ^ Module being compiled
@@ -1027,19 +1027,18 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 -- The order of the list does not matter.
 implicitTyThings :: TyThing -> [TyThing]
-
--- For data and newtype declarations:
-implicitTyThings (ATyCon tc)
-  =   -- fields (names of selectors)
-      -- (possibly) implicit coercion and family coercion
-      --   depending on whether it's a newtype or a family instance or both
-    implicitCoTyCon tc ++
-      -- for each data constructor in order,
-      --   the contructor, worker, and (possibly) wrapper
-    concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-		     
-implicitTyThings (AClass cl) 
-  = -- dictionary datatype:
+implicitTyThings (AnId _)       = []
+implicitTyThings (ACoAxiom _cc) = []
+implicitTyThings (ATyCon tc)    = implicitTyConThings tc
+implicitTyThings (AClass cl)    = implicitClassThings cl
+implicitTyThings (ADataCon dc)  = map AnId (dataConImplicitIds dc)
+    -- For data cons add the worker and (possibly) wrapper
+    
+implicitClassThings :: Class -> [TyThing]
+implicitClassThings cl 
+  = -- Does not include default methods, because those Ids may have
+    --    their own pragmas, unfoldings etc, not derived from the Class object
+    -- Dictionary datatype:
     --    [extras_plus:]
     --      type constructor 
     --    [recursive call:]
@@ -1055,11 +1054,16 @@ implicitTyThings (AClass cl)
     -- superclass and operation selectors
     map AnId (classAllSelIds cl)
 
-implicitTyThings (ADataCon dc) = 
-    -- For data cons add the worker and (possibly) wrapper
-    map AnId (dataConImplicitIds dc)
+implicitTyConThings :: TyCon -> [TyThing]
+implicitTyConThings tc 
+  =   -- fields (names of selectors)
+      -- (possibly) implicit coercion and family coercion
+      --   depending on whether it's a newtype or a family instance or both
+    implicitCoTyCon tc ++
+      -- for each data constructor in order,
+      --   the contructor, worker, and (possibly) wrapper
+    concatMap (extras_plus . ADataCon) (tyConDataCons tc)
 
-implicitTyThings (AnId _)   = []
 
 -- add a thing and recursive call
 extras_plus :: TyThing -> [TyThing]
@@ -1069,10 +1073,10 @@ extras_plus thing = thing : implicitTyThings thing
 -- add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc 
-  = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not
-                              newTyConCo_maybe tc, 
+  = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
+                              newTyConCo_maybe tc,
                               -- Just if family instance, Nothing if not
-			        tyConFamilyCoercion_maybe tc] 
+			      tyConFamilyCoercion_maybe tc] 
 
 -- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
 
@@ -1082,10 +1086,11 @@ implicitCoTyCon tc
 -- of some other declaration, or it is generated implicitly by some
 -- other declaration.
 isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon _)  = True
-isImplicitTyThing (AnId     id) = isImplicitId id
-isImplicitTyThing (AClass   _)  = False
-isImplicitTyThing (ATyCon   tc) = isImplicitTyCon tc
+isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AnId id)     = isImplicitId id
+isImplicitTyThing (AClass {})   = False
+isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
+isImplicitTyThing (ACoAxiom {}) = True
 
 extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
 extendTypeEnvWithIds env ids
@@ -1107,6 +1112,7 @@ emptyTypeEnv    :: TypeEnv
 typeEnvElts     :: TypeEnv -> [TyThing]
 typeEnvClasses  :: TypeEnv -> [Class]
 typeEnvTyCons   :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
 typeEnvIds      :: TypeEnv -> [Id]
 typeEnvDataCons :: TypeEnv -> [DataCon]
 lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing
@@ -1115,6 +1121,7 @@ emptyTypeEnv 	    = emptyNameEnv
 typeEnvElts     env = nameEnvElts env
 typeEnvClasses  env = [cl | AClass cl   <- typeEnvElts env]
 typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env] 
+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] 
 typeEnvIds      env = [id | AnId id     <- typeEnvElts env] 
 typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] 
 
@@ -1170,6 +1177,11 @@ tyThingTyCon :: TyThing -> TyCon
 tyThingTyCon (ATyCon tc) = tc
 tyThingTyCon other	 = pprPanic "tyThingTyCon" (pprTyThing other)
 
+-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
+tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom (ACoAxiom ax) = ax
+tyThingCoAxiom other	     = pprPanic "tyThingCoAxiom" (pprTyThing other)
+
 -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
 tyThingClass :: TyThing -> Class
 tyThingClass (AClass cls) = cls
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 451f78d..860464e 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -56,7 +56,8 @@ import ErrUtils         ( debugTraceMsg, putMsg, Message )
 import Exception
 
 import System.Directory
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
 import Control.Monad
 import Data.List as List
 import Data.Map (Map)
@@ -246,7 +247,8 @@ readPackageConfig dflags conf_file = do
 
   let
       top_dir = topDir dflags
-      pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+      pkgroot = takeDirectory conf_file
+      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
       pkg_configs2 = maybeHidePackages dflags pkg_configs1
   --
   return pkg_configs2
@@ -258,27 +260,52 @@ maybeHidePackages dflags pkgs
   where
     hide pkg = pkg{ exposed = False }
 
-mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$topdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where 
-  munge_pkg p = p{ importDirs  = munge_paths (importDirs p),
-		   includeDirs = munge_paths (includeDirs p),
-    		   libraryDirs = munge_paths (libraryDirs p),
-		   frameworkDirs = munge_paths (frameworkDirs p),
-                   haddockInterfaces = munge_paths (haddockInterfaces p),
-	           haddockHTMLs = munge_paths (haddockHTMLs p)
-                    }
-
-  munge_paths = map munge_path
-
-  munge_path p 
-	  | Just p' <- stripPrefix "$topdir"     p =            top_dir ++ p'
-	  | Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p'
-	  | otherwise				    = p
-
-  toHttpPath p = "file:///" ++ p
+mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+    pkg {
+      importDirs  = munge_paths (importDirs pkg),
+      includeDirs = munge_paths (includeDirs pkg),
+      libraryDirs = munge_paths (libraryDirs pkg),
+      frameworkDirs = munge_paths (frameworkDirs pkg),
+      haddockInterfaces = munge_paths (haddockInterfaces pkg),
+      haddockHTMLs = munge_urls (haddockHTMLs pkg)
+    }
+  where 
+    munge_paths = map munge_path
+    munge_urls  = map munge_url
+
+    munge_path p
+      | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+      | Just p' <- stripVarPrefix "$topdir"    sp = top_dir </> p'
+      | otherwise                                 = p
+      where
+        sp = splitPath p
+
+    munge_url p
+      | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+      | Just p' <- stripVarPrefix "$httptopdir"   sp = toUrlPath top_dir p'
+      | otherwise                                    = p
+      where
+        sp = splitPath p
+
+    toUrlPath r p = "file:///"
+                 -- URLs always use posix style '/' separators:
+                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+    stripVarPrefix var (root:path')
+      | Just [sep] <- stripPrefix var root
+      , isPathSeparator sep
+      = Just (joinPath path')
+
+    stripVarPrefix _ _ = Nothing
 
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index d859784..6d5344d 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -23,8 +23,8 @@ import DataCon
 import Id
 import IdInfo
 import TyCon
+import Coercion( pprCoAxiom )
 import TcType
-import Var
 import Name
 import Outputable
 import FastString
@@ -45,7 +45,7 @@ type ShowMe = Name -> Bool
 ----------------------------
 -- | Pretty-prints a 'TyThing' with its defining location.
 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing 
+pprTyThingLoc pefas tyThing
   = showWithLoc loc (pprTyThing pefas tyThing)
   where loc = pprNameLoc (GHC.getName tyThing)
 
@@ -57,10 +57,11 @@ ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
 ppr_ty_thing pefas _ 	 (AnId id)          = pprId         pefas id
 ppr_ty_thing pefas _ 	 (ADataCon dataCon) = pprDataConSig pefas dataCon
 ppr_ty_thing pefas show_me (ATyCon tyCon)   = pprTyCon      pefas show_me tyCon
+ppr_ty_thing _     _       (ACoAxiom ax)    = pprCoAxiom    ax
 ppr_ty_thing pefas show_me (AClass cls)     = pprClass      pefas show_me cls
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then 
+-- is a data constructor, record selector, or class method, then
 -- the entity's parent declaration is pretty-printed with irrelevant
 -- parts omitted.
 pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
@@ -77,7 +78,7 @@ pprTyThingInContextLoc pefas tyThing
                 (pprTyThingInContext pefas tyThing)
 
 pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p) 
+-- (pprTyThingParent_maybe x) returns (Just p)
 -- when pprTyThingInContext sould print a declaration for p
 -- (albeit with some "..." in it) when asked to show x
 pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
@@ -94,6 +95,7 @@ pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
 pprTyThingHdr pefas (AnId id)          = pprId         pefas id
 pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
 pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
+pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
 pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
 
 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
@@ -103,7 +105,7 @@ pprTyConHdr _ tyCon
   | otherwise
   = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
-    vars | GHC.isPrimTyCon tyCon || 
+    vars | GHC.isPrimTyCon tyCon ||
 	   GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
 	 | otherwise = GHC.tyConTyVars tyCon
 
@@ -116,7 +118,7 @@ pprTyConHdr _ tyCon
       | otherwise             = empty
 
     opt_stupid 	-- The "stupid theta" part of the declaration
-	| isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon)
+	| isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
 	| otherwise	   = empty	-- Returns 'empty' if null theta
 
 pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
@@ -125,14 +127,14 @@ pprDataConSig pefas dataCon
 
 pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
 pprClassHdr _ cls
-  = ptext (sLit "class") <+> 
-    GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+  = ptext (sLit "class") <+>
+    GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
     ppr_bndr cls <+>
     hsep (map ppr tyVars) <+>
     GHC.pprFundeps funDeps
   where
      (tyVars, funDeps) = GHC.classTvsFds cls
-     
+
 pprId :: PrintExplicitForalls -> Var -> SDoc
 pprId pefas ident
   = hang (ppr_bndr ident <+> dcolon)
@@ -147,7 +149,7 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
 --	forall a. C a => forall b. Ord b => stuff
 -- Then we want to display
 --	(C a, Ord b) => stuff
-pprTypeForUser print_foralls ty 
+pprTypeForUser print_foralls ty
   | print_foralls = ppr tidy_ty
   | otherwise     = ppr (mkPhiTy ctxt ty')
   where
@@ -160,7 +162,7 @@ pprTyCon pefas show_me tyCon
   = if GHC.isFamilyTyCon tyCon
     then pprTyConHdr pefas tyCon <+> dcolon <+> 
 	 pprTypeForUser pefas (GHC.synTyConResKind tyCon)
-    else 
+    else
       let rhs_type = GHC.synTyConType tyCon
       in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
   | otherwise
@@ -168,7 +170,7 @@ pprTyCon pefas show_me tyCon
 
 pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
 pprAlgTyCon pefas show_me tyCon
-  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ 
+  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
 		   nest 2 (vcat (ppr_trim show_con datacons))
   | otherwise = hang (pprTyConHdr pefas tyCon)
     		   2 (add_bars (ppr_trim show_con datacons))
@@ -184,8 +186,8 @@ pprAlgTyCon pefas show_me tyCon
 pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
 pprDataConDecl pefas show_me gadt_style dataCon
   | not gadt_style = ppr_fields tys_w_strs
-  | otherwise      = ppr_bndr dataCon <+> dcolon <+> 
-			sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
+  | otherwise      = ppr_bndr dataCon <+> dcolon <+>
+			sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
 	-- Printing out the dataCon as a type signature, in GADT style
   where
     (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
@@ -214,15 +216,15 @@ pprDataConDecl pefas show_me gadt_style dataCon
 	| null labels
 	= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
 	| otherwise
-	= ppr_bndr dataCon <+> 
-		braces (sep (punctuate comma (ppr_trim maybe_show_label 
+	= ppr_bndr dataCon <+>
+		braces (sep (punctuate comma (ppr_trim maybe_show_label
 					(zip labels fields))))
 
 pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
 pprClass pefas show_me cls
   | null methods
   = pprClassHdr pefas cls
-  | otherwise 
+  | otherwise
   = hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
        2 (vcat (ppr_trim show_meth methods))
   where
@@ -237,7 +239,7 @@ pprClassMethod pefas id
   -- Here's the magic incantation to strip off the dictionary
   -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
   --
-  -- It's important to tidy it *before* splitting it up, so that if 
+  -- It's important to tidy it *before* splitting it up, so that if
   -- we have	class C a b where
   --	          op :: forall a. a -> b
   -- then the inner forall on op gets renamed to a1, and we print
@@ -268,7 +270,7 @@ ppr_bndr :: GHC.NamedThing a => a -> SDoc
 ppr_bndr a = GHC.pprParenSymName a
 
 showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc 
+showWithLoc loc doc
     = hang doc 2 (char '\t' <> comment <+> loc)
 		-- The tab tries to make them line up a bit
   where
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index eddc9ca..f6d0af2 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -192,16 +192,12 @@ opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
 
 -- debugging options
 -- | Suppress all that is suppressable in core dumps.
+--   Except for uniques, as some simplifier phases introduce new varibles that
+--   have otherwise identical names.
 opt_SuppressAll :: Bool
 opt_SuppressAll	
 	= lookUp  (fsLit "-dsuppress-all")
 
--- | Suppress unique ids on variables.
-opt_SuppressUniques :: Bool
-opt_SuppressUniques
-	=  lookUp  (fsLit "-dsuppress-all")
-	|| lookUp  (fsLit "-dsuppress-uniques")
-
 -- | Suppress all coercions, them replacing with '...'
 opt_SuppressCoercions :: Bool
 opt_SuppressCoercions
@@ -232,10 +228,16 @@ opt_SuppressTypeSignatures
 	=  lookUp  (fsLit "-dsuppress-all")
 	|| lookUp  (fsLit "-dsuppress-type-signatures")
 
+-- | Suppress unique ids on variables.
+--   Except for uniques, as some simplifier phases introduce new variables that
+--   have otherwise identical names.
+opt_SuppressUniques :: Bool
+opt_SuppressUniques
+	=  lookUp  (fsLit "-dsuppress-uniques")
 
 -- | Display case expressions with a single alternative as strict let bindings
 opt_PprCaseAsLet :: Bool
-opt_PprCaseAsLet		= lookUp   (fsLit "-dppr-case-as-let")
+opt_PprCaseAsLet	= lookUp   (fsLit "-dppr-case-as-let")
 
 -- | Set the maximum width of the dumps
 --   If GHC's command line options are bad then the options parser uses the
@@ -330,16 +332,16 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int
 opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
 opt_UF_KeenessFactor :: Float
 
-opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
-opt_UF_UseThreshold	 = lookup_def_int "-funfolding-use-threshold"	   (6::Int)
-opt_UF_FunAppDiscount	 = lookup_def_int "-funfolding-fun-discount"	   (6::Int)
+opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int)
+opt_UF_UseThreshold      = lookup_def_int "-funfolding-use-threshold"      (60::Int)
+opt_UF_FunAppDiscount    = lookup_def_int "-funfolding-fun-discount"       (60::Int)
 
-opt_UF_DictDiscount	 = lookup_def_int "-funfolding-dict-discount"	   (3::Int)
+opt_UF_DictDiscount      = lookup_def_int "-funfolding-dict-discount"      (30::Int)
    -- Be fairly keen to inline a fuction if that means
    -- we'll be able to pick the right method from a dictionary
 
 opt_UF_KeenessFactor	 = lookup_def_float "-funfolding-keeness-factor"   (1.5::Float)
-opt_UF_DearOp            = ( 4 :: Int)
+opt_UF_DearOp            = ( 40 :: Int)
 
 
 -- Related to linking
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 2529dbf..9c086cc 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -182,6 +182,9 @@ initSysTools mbMinusB
         -- to make that possible, so for now you can't.
         ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc"
                                        else getSetting "C compiler command"
+        ; gcc_args_str <- if isWindowsHost then return []
+                                           else getSetting "C compiler flags"
+        ; let gcc_args = map Option (words gcc_args_str)
         ; perl_path <- if isWindowsHost
                        then return $ installed_perl_bin "perl"
                        else getSetting "perl command"
@@ -224,14 +227,18 @@ initSysTools mbMinusB
         -- cpp is derived from gcc on all platforms
         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
         -- Config.hs one day.
-        ; let cpp_path  = (gcc_prog,
-                           (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+        ; let cpp_prog  = gcc_prog
+              cpp_args  = Option "-E"
+                        : map Option (words cRAWCPP_FLAGS)
+                       ++ gcc_args
 
         -- Other things being equal, as and ld are simply gcc
         ; let   as_prog  = gcc_prog
+                as_args  = gcc_args
                 ld_prog  = gcc_prog
+                ld_args  = gcc_args
 
-        -- figure out llvm location. (TODO: Acutally implement).
+        -- We just assume on command line
         ; let lc_prog = "llc"
               lo_prog = "opt"
 
@@ -244,12 +251,12 @@ initSysTools mbMinusB
                         sExtraGccViaCFlags = words myExtraGccViaCFlags,
                         sSystemPackageConfig = pkgconfig_path,
                         sPgm_L   = unlit_path,
-                        sPgm_P   = cpp_path,
+                        sPgm_P   = (cpp_prog, cpp_args),
                         sPgm_F   = "",
-                        sPgm_c   = (gcc_prog,[]),
+                        sPgm_c   = (gcc_prog, gcc_args),
                         sPgm_s   = (split_prog,split_args),
-                        sPgm_a   = (as_prog,[]),
-                        sPgm_l   = (ld_prog,[]),
+                        sPgm_a   = (as_prog, as_args),
+                        sPgm_l   = (ld_prog, ld_args),
                         sPgm_dll = (mkdll_prog,mkdll_args),
                         sPgm_T   = touch_path,
                         sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
@@ -781,20 +788,16 @@ data BuildMessage
   | EOF
 
 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+-- trace the command (at two levels of verbosity)
 traceCmd dflags phase_name cmd_line action
  = do   { let verb = verbosity dflags
         ; showPass dflags phase_name
         ; debugTraceMsg dflags 3 (text cmd_line)
         ; hFlush stderr
 
-           -- Test for -n flag
-        ; unless (dopt Opt_DryRun dflags) $ do {
-
            -- And run it!
         ; action `catchIO` handle_exn verb
-        }}
+        }
   where
     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
@@ -815,14 +818,15 @@ getBaseDir :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
 -- return the path $(stuff)/lib.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
-                buf <- mallocArray len
-                ret <- getModuleFileName nullPtr buf len
-                if ret == 0 then free buf >> return Nothing
-                            else do s <- peekCString buf
-                                    free buf
-                                    return (Just (rootDir s))
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
   where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+    
     rootDir s = case splitFileName $ normalise s of
                 (d, ghc_exe)
                  | lower ghc_exe `elem` ["ghc.exe",
@@ -837,8 +841,8 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
               lower = map toLower
 
-foreign import stdcall unsafe "GetModuleFileNameA"
-  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getBaseDir = return Nothing
 #endif
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index f23280b..b4296cb 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -1156,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts
 cafRefs p (Note _n e) 	       = cafRefs p e
 cafRefs p (Cast e _co)         = cafRefs p e
 cafRefs _ (Type _) 	       = fastBool False
+cafRefs _ (Coercion _)         = fastBool False
 
 cafRefss :: VarEnv Id -> [Expr a] -> FastBool
 cafRefss _ [] 	  = fastBool False
diff --git a/compiler/nativeGen/Alpha/CodeGen.hs b/compiler/nativeGen/Alpha/CodeGen.hs
deleted file mode 100644
index 4ce774f..0000000
--- a/compiler/nativeGen/Alpha/CodeGen.hs
+++ /dev/null
@@ -1,789 +0,0 @@
-module Alpha.CodeGen ()
-
-where
-
-{-
-
-getRegister :: CmmExpr -> NatM Register
-
-#if !x86_64_TARGET_ARCH
-    -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
-    -- register, it can only be used for rip-relative addressing.
-getRegister (CmmReg (CmmGlobal PicBaseReg))
-  = do
-      reg <- getPicBaseNat wordSize
-      return (Fixed wordSize reg nilOL)
-#endif
-
-getRegister (CmmReg reg) 
-  = return (Fixed (cmmTypeSize (cmmRegType reg)) 
-		  (getRegisterReg reg) nilOL)
-
-getRegister tree@(CmmRegOff _ _) 
-  = getRegister (mangleIndexTree tree)
-
-
-#if WORD_SIZE_IN_BITS==32
-    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
-    -- TO_W_(x), TO_W_(x >> 32)
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32)
-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32)
-             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
-  ChildCode64 code rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code       
-
-#endif
-
--- end of machine-"independent" bit; here we go on the rest...
-
-
-getRegister (StDouble d)
-  = getBlockIdNat 	    	    `thenNat` \ lbl ->
-    getNewRegNat PtrRep    	    `thenNat` \ tmp ->
-    let code dst = mkSeqInstrs [
-	    LDATA RoDataSegment lbl [
-		    DATA TF [ImmLab (rational d)]
-		],
-	    LDA tmp (AddrImm (ImmCLbl lbl)),
-	    LD TF dst (AddrReg tmp)]
-    in
-    	return (Any FF64 code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
-  = case primop of
-      IntNegOp -> trivialUCode (NEG Q False) x
-
-      NotOp    -> trivialUCode NOT x
-
-      FloatNegOp  -> trivialUFCode FloatRep (FNEG TF) x
-      DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
-
-      OrdOp -> coerceIntCode IntRep x
-      ChrOp -> chrCode x
-
-      Float2IntOp  -> coerceFP2Int    x
-      Int2FloatOp  -> coerceInt2FP pr x
-      Double2IntOp -> coerceFP2Int    x
-      Int2DoubleOp -> coerceInt2FP pr x
-
-      Double2FloatOp -> coerceFltCode x
-      Float2DoubleOp -> coerceFltCode x
-
-      other_op -> getRegister (StCall fn CCallConv FF64 [x])
-	where
-	  fn = case other_op of
-		 FloatExpOp    -> fsLit "exp"
-		 FloatLogOp    -> fsLit "log"
-		 FloatSqrtOp   -> fsLit "sqrt"
-		 FloatSinOp    -> fsLit "sin"
-		 FloatCosOp    -> fsLit "cos"
-		 FloatTanOp    -> fsLit "tan"
-		 FloatAsinOp   -> fsLit "asin"
-		 FloatAcosOp   -> fsLit "acos"
-		 FloatAtanOp   -> fsLit "atan"
-		 FloatSinhOp   -> fsLit "sinh"
-		 FloatCoshOp   -> fsLit "cosh"
-		 FloatTanhOp   -> fsLit "tanh"
-		 DoubleExpOp   -> fsLit "exp"
-		 DoubleLogOp   -> fsLit "log"
-		 DoubleSqrtOp  -> fsLit "sqrt"
-		 DoubleSinOp   -> fsLit "sin"
-		 DoubleCosOp   -> fsLit "cos"
-		 DoubleTanOp   -> fsLit "tan"
-		 DoubleAsinOp  -> fsLit "asin"
-		 DoubleAcosOp  -> fsLit "acos"
-		 DoubleAtanOp  -> fsLit "atan"
-		 DoubleSinhOp  -> fsLit "sinh"
-		 DoubleCoshOp  -> fsLit "cosh"
-		 DoubleTanhOp  -> fsLit "tanh"
-  where
-    pr = panic "MachCode.getRegister: no primrep needed for Alpha"
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
-  = case primop of
-      CharGtOp -> trivialCode (CMP LTT) y x
-      CharGeOp -> trivialCode (CMP LE) y x
-      CharEqOp -> trivialCode (CMP EQQ) x y
-      CharNeOp -> int_NE_code x y
-      CharLtOp -> trivialCode (CMP LTT) x y
-      CharLeOp -> trivialCode (CMP LE) x y
-
-      IntGtOp  -> trivialCode (CMP LTT) y x
-      IntGeOp  -> trivialCode (CMP LE) y x
-      IntEqOp  -> trivialCode (CMP EQQ) x y
-      IntNeOp  -> int_NE_code x y
-      IntLtOp  -> trivialCode (CMP LTT) x y
-      IntLeOp  -> trivialCode (CMP LE) x y
-
-      WordGtOp -> trivialCode (CMP ULT) y x
-      WordGeOp -> trivialCode (CMP ULE) x y
-      WordEqOp -> trivialCode (CMP EQQ)  x y
-      WordNeOp -> int_NE_code x y
-      WordLtOp -> trivialCode (CMP ULT) x y
-      WordLeOp -> trivialCode (CMP ULE) x y
-
-      AddrGtOp -> trivialCode (CMP ULT) y x
-      AddrGeOp -> trivialCode (CMP ULE) y x
-      AddrEqOp -> trivialCode (CMP EQQ)  x y
-      AddrNeOp -> int_NE_code x y
-      AddrLtOp -> trivialCode (CMP ULT) x y
-      AddrLeOp -> trivialCode (CMP ULE) x y
-	
-      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
-      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
-      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
-      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
-      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
-      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
-
-      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
-      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
-      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
-      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
-      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
-      DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
-
-      IntAddOp  -> trivialCode (ADD Q False) x y
-      IntSubOp  -> trivialCode (SUB Q False) x y
-      IntMulOp  -> trivialCode (MUL Q False) x y
-      IntQuotOp -> trivialCode (DIV Q False) x y
-      IntRemOp  -> trivialCode (REM Q False) x y
-
-      WordAddOp  -> trivialCode (ADD Q False) x y
-      WordSubOp  -> trivialCode (SUB Q False) x y
-      WordMulOp  -> trivialCode (MUL Q False) x y
-      WordQuotOp -> trivialCode (DIV Q True) x y
-      WordRemOp  -> trivialCode (REM Q True) x y
-
-      FloatAddOp -> trivialFCode  W32 (FADD TF) x y
-      FloatSubOp -> trivialFCode  W32 (FSUB TF) x y
-      FloatMulOp -> trivialFCode  W32 (FMUL TF) x y
-      FloatDivOp -> trivialFCode  W32 (FDIV TF) x y
-
-      DoubleAddOp -> trivialFCode  W64 (FADD TF) x y
-      DoubleSubOp -> trivialFCode  W64 (FSUB TF) x y
-      DoubleMulOp -> trivialFCode  W64 (FMUL TF) x y
-      DoubleDivOp -> trivialFCode  W64 (FDIV TF) x y
-
-      AddrAddOp  -> trivialCode (ADD Q False) x y
-      AddrSubOp  -> trivialCode (SUB Q False) x y
-      AddrRemOp  -> trivialCode (REM Q True) x y
-
-      AndOp  -> trivialCode AND x y
-      OrOp   -> trivialCode OR  x y
-      XorOp  -> trivialCode XOR x y
-      SllOp  -> trivialCode SLL x y
-      SrlOp  -> trivialCode SRL x y
-
-      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
-      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
-      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
-
-      FloatPowerOp  -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
-      DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
-  where
-    {- ------------------------------------------------------------
-	Some bizarre special code for getting condition codes into
-	registers.  Integer non-equality is a test for equality
-	followed by an XOR with 1.  (Integer comparisons always set
-	the result register to 0 or 1.)  Floating point comparisons of
-	any kind leave the result in a floating point register, so we
-	need to wrangle an integer register out of things.
-    -}
-    int_NE_code :: StixTree -> StixTree -> NatM Register
-
-    int_NE_code x y
-      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
-	getNewRegNat IntRep		`thenNat` \ tmp ->
-	let
-	    code = registerCode register tmp
-	    src  = registerName register tmp
-	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
-	in
-	return (Any IntRep code__2)
-
-    {- ------------------------------------------------------------
-	Comments for int_NE_code also apply to cmpF_code
-    -}
-    cmpF_code
-	:: (Reg -> Reg -> Reg -> Instr)
-	-> Cond
-	-> StixTree -> StixTree
-	-> NatM Register
-
-    cmpF_code instr cond x y
-      = trivialFCode pr instr x y	`thenNat` \ register ->
-	getNewRegNat FF64		`thenNat` \ tmp ->
-	getBlockIdNat			`thenNat` \ lbl ->
-	let
-	    code = registerCode register tmp
-	    result  = registerName register tmp
-
-	    code__2 dst = code . mkSeqInstrs [
-		OR zeroh (RIImm (ImmInt 1)) dst,
-		BF cond  result (ImmCLbl lbl),
-		OR zeroh (RIReg zeroh) dst,
-		NEWBLOCK lbl]
-	in
-	return (Any IntRep code__2)
-      where
-	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-      ------------------------------------------------------------
-
-getRegister (CmmLoad pk mem)
-  = getAmode mem    	    	    `thenNat` \ amode ->
-    let
-    	code = amodeCode amode
-    	src   = amodeAddr amode
-    	size = primRepToSize pk
-    	code__2 dst = code . mkSeqInstr (LD size dst src)
-    in
-    return (Any pk code__2)
-
-getRegister (StInt i)
-  | fits8Bits i
-  = let
-    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
-    in
-    return (Any IntRep code)
-  | otherwise
-  = let
-    	code dst = mkSeqInstr (LDI Q dst src)
-    in
-    return (Any IntRep code)
-  where
-    src = ImmInt (fromInteger i)
-
-getRegister leaf
-  | isJust imm
-  = let
-    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
-    in
-    return (Any PtrRep code)
-  where
-    imm = maybeImm leaf
-    imm__2 = case imm of Just x -> x
-
-
-getAmode :: CmmExpr -> NatM Amode
-getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [x, StInt i])
-  = getNewRegNat PtrRep		`thenNat` \ tmp ->
-    getRegister x		`thenNat` \ register ->
-    let
-    	code = registerCode register tmp
-    	reg  = registerName register tmp
-    	off  = ImmInt (-(fromInteger i))
-    in
-    return (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
-  = getNewRegNat PtrRep		`thenNat` \ tmp ->
-    getRegister x		`thenNat` \ register ->
-    let
-    	code = registerCode register tmp
-    	reg  = registerName register tmp
-    	off  = ImmInt (fromInteger i)
-    in
-    return (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
-  | isJust imm
-  = return (Amode (AddrImm imm__2) id)
-  where
-    imm = maybeImm leaf
-    imm__2 = case imm of Just x -> x
-
-getAmode other
-  = getNewRegNat PtrRep		`thenNat` \ tmp ->
-    getRegister other		`thenNat` \ register ->
-    let
-    	code = registerCode register tmp
-    	reg  = registerName register tmp
-    in
-    return (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business.  Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers.  If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side.  This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-
-assignIntCode pk (CmmLoad dst _) src
-  = getNewRegNat IntRep    	    `thenNat` \ tmp ->
-    getAmode dst    	    	    `thenNat` \ amode ->
-    getRegister src	     	    `thenNat` \ register ->
-    let
-    	code1   = amodeCode amode []
-    	dst__2  = amodeAddr amode
-    	code2   = registerCode register tmp []
-    	src__2  = registerName register tmp
-    	sz      = primRepToSize pk
-    	code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
-    in
-    return code__2
-
-assignIntCode pk dst src
-  = getRegister dst	    	    	    `thenNat` \ register1 ->
-    getRegister src	    	    	    `thenNat` \ register2 ->
-    let
-    	dst__2  = registerName register1 zeroh
-    	code    = registerCode register2 dst__2
-    	src__2  = registerName register2 dst__2
-    	code__2 = if isFixed register2
-		  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
-    	    	  else code
-    in
-    return code__2
-
-assignFltCode pk (CmmLoad dst _) src
-  = getNewRegNat pk        	    `thenNat` \ tmp ->
-    getAmode dst    	    	    `thenNat` \ amode ->
-    getRegister src	    	    	    `thenNat` \ register ->
-    let
-    	code1   = amodeCode amode []
-    	dst__2  = amodeAddr amode
-    	code2   = registerCode register tmp []
-    	src__2  = registerName register tmp
-    	sz      = primRepToSize pk
-    	code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
-    in
-    return code__2
-
-assignFltCode pk dst src
-  = getRegister dst	    	    	    `thenNat` \ register1 ->
-    getRegister src	    	    	    `thenNat` \ register2 ->
-    let
-    	dst__2  = registerName register1 zeroh
-    	code    = registerCode register2 dst__2
-    	src__2  = registerName register2 dst__2
-    	code__2 = if isFixed register2
-		  then code . mkSeqInstr (FMOV src__2 dst__2)
-		  else code
-    in
-    return code__2
-
-
--- -----------------------------------------------------------------------------
--- Generating an non-local jump
-
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-
-genJump (CmmLabel lbl)
-  | isAsmTemp lbl = returnInstr (BR target)
-  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
-  where
-    target = ImmCLbl lbl
-
-genJump tree
-  = getRegister tree	     	    `thenNat` \ register ->
-    getNewRegNat PtrRep    	    `thenNat` \ tmp ->
-    let
-    	dst    = registerName register pv
-    	code   = registerCode register pv
-    	target = registerName register pv
-    in
-    if isFixed register then
-	returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
-    else
-    return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-
--- -----------------------------------------------------------------------------
---  Unconditional branches
-
-genBranch :: BlockId -> NatM InstrBlock
-
-genBranch = return . toOL . mkBranchInstr
-
-
--- -----------------------------------------------------------------------------
---  Conditional jumps
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions.  We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
--}
-
-
-genCondJump
-    :: BlockId	    -- the branch target
-    -> CmmExpr      -- the condition on which to branch
-    -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-genCondJump id (StPrim op [x, StInt 0])
-  = getRegister x	  	    	    `thenNat` \ register ->
-    getNewRegNat (registerRep register)
-    	    	        	    `thenNat` \ tmp ->
-    let
-    	code   = registerCode register tmp
-    	value  = registerName register tmp
-    	pk     = registerRep register
-	target = ImmCLbl lbl
-    in
-    returnSeq code [BI (cmpOp op) value target]
-  where
-    cmpOp CharGtOp = GTT
-    cmpOp CharGeOp = GE
-    cmpOp CharEqOp = EQQ
-    cmpOp CharNeOp = NE
-    cmpOp CharLtOp = LTT
-    cmpOp CharLeOp = LE
-    cmpOp IntGtOp = GTT
-    cmpOp IntGeOp = GE
-    cmpOp IntEqOp = EQQ
-    cmpOp IntNeOp = NE
-    cmpOp IntLtOp = LTT
-    cmpOp IntLeOp = LE
-    cmpOp WordGtOp = NE
-    cmpOp WordGeOp = ALWAYS
-    cmpOp WordEqOp = EQQ
-    cmpOp WordNeOp = NE
-    cmpOp WordLtOp = NEVER
-    cmpOp WordLeOp = EQQ
-    cmpOp AddrGtOp = NE
-    cmpOp AddrGeOp = ALWAYS
-    cmpOp AddrEqOp = EQQ
-    cmpOp AddrNeOp = NE
-    cmpOp AddrLtOp = NEVER
-    cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
-  = getRegister x	  	    	    `thenNat` \ register ->
-    getNewRegNat (registerRep register)
-    	    	        	    `thenNat` \ tmp ->
-    let
-    	code   = registerCode register tmp
-    	value  = registerName register tmp
-    	pk     = registerRep register
-	target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BF (cmpOp op) value target))
-  where
-    cmpOp FloatGtOp = GTT
-    cmpOp FloatGeOp = GE
-    cmpOp FloatEqOp = EQQ
-    cmpOp FloatNeOp = NE
-    cmpOp FloatLtOp = LTT
-    cmpOp FloatLeOp = LE
-    cmpOp DoubleGtOp = GTT
-    cmpOp DoubleGeOp = GE
-    cmpOp DoubleEqOp = EQQ
-    cmpOp DoubleNeOp = NE
-    cmpOp DoubleLtOp = LTT
-    cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
-  | fltCmpOp op
-  = trivialFCode pr instr x y 	    `thenNat` \ register ->
-    getNewRegNat FF64    	    `thenNat` \ tmp ->
-    let
-    	code   = registerCode register tmp
-    	result = registerName register tmp
-	target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BF cond result target))
-  where
-    pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
-    fltCmpOp op = case op of
-	FloatGtOp -> True
-	FloatGeOp -> True
-	FloatEqOp -> True
-	FloatNeOp -> True
-	FloatLtOp -> True
-	FloatLeOp -> True
-	DoubleGtOp -> True
-	DoubleGeOp -> True
-	DoubleEqOp -> True
-	DoubleNeOp -> True
-	DoubleLtOp -> True
-	DoubleLeOp -> True
-	_ -> False
-    (instr, cond) = case op of
-	FloatGtOp -> (FCMP TF LE, EQQ)
-	FloatGeOp -> (FCMP TF LTT, EQQ)
-	FloatEqOp -> (FCMP TF EQQ, NE)
-	FloatNeOp -> (FCMP TF EQQ, EQQ)
-	FloatLtOp -> (FCMP TF LTT, NE)
-	FloatLeOp -> (FCMP TF LE, NE)
-	DoubleGtOp -> (FCMP TF LE, EQQ)
-	DoubleGeOp -> (FCMP TF LTT, EQQ)
-	DoubleEqOp -> (FCMP TF EQQ, NE)
-	DoubleNeOp -> (FCMP TF EQQ, EQQ)
-	DoubleLtOp -> (FCMP TF LTT, NE)
-	DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op [x, y])
-  = trivialCode instr x y    	    `thenNat` \ register ->
-    getNewRegNat IntRep    	    `thenNat` \ tmp ->
-    let
-    	code   = registerCode register tmp
-    	result = registerName register tmp
-	target = ImmCLbl lbl
-    in
-    return (code . mkSeqInstr (BI cond result target))
-  where
-    (instr, cond) = case op of
-	CharGtOp -> (CMP LE, EQQ)
-	CharGeOp -> (CMP LTT, EQQ)
-	CharEqOp -> (CMP EQQ, NE)
-	CharNeOp -> (CMP EQQ, EQQ)
-	CharLtOp -> (CMP LTT, NE)
-	CharLeOp -> (CMP LE, NE)
-	IntGtOp -> (CMP LE, EQQ)
-	IntGeOp -> (CMP LTT, EQQ)
-	IntEqOp -> (CMP EQQ, NE)
-	IntNeOp -> (CMP EQQ, EQQ)
-	IntLtOp -> (CMP LTT, NE)
-	IntLeOp -> (CMP LE, NE)
-	WordGtOp -> (CMP ULE, EQQ)
-	WordGeOp -> (CMP ULT, EQQ)
-	WordEqOp -> (CMP EQQ, NE)
-	WordNeOp -> (CMP EQQ, EQQ)
-	WordLtOp -> (CMP ULT, NE)
-	WordLeOp -> (CMP ULE, NE)
-	AddrGtOp -> (CMP ULE, EQQ)
-	AddrGeOp -> (CMP ULT, EQQ)
-	AddrEqOp -> (CMP EQQ, NE)
-	AddrNeOp -> (CMP EQQ, EQQ)
-	AddrLtOp -> (CMP ULT, NE)
-	AddrLeOp -> (CMP ULE, NE)
-
--- -----------------------------------------------------------------------------
---  Generating C calls
-
--- Now the biggest nightmare---calls.  Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations.  Apart from that, the code is easy.
--- 
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genCCall
-    :: CmmCallTarget		-- function to call
-    -> HintedCmmFormals		-- where to put the result
-    -> HintedCmmActuals		-- arguments (of mixed type)
-    -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-ccallResultRegs = 
-
-genCCall fn cconv result_regs args
-  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
-    	    	  	  `thenNat` \ ((unused,_), argCode) ->
-    let
-    	nRegs = length allArgRegs - length unused
-    	code = asmSeqThen (map ($ []) argCode)
-    in
-    	returnSeq code [
-    	    LDA pv (AddrImm (ImmLab (ptext fn))),
-    	    JSR ra (AddrReg pv) nRegs,
-    	    LDGP gp (AddrReg ra)]
-  where
-    ------------------------
-    {-	Try to get a value into a specific register (or registers) for
-	a call.  The first 6 arguments go into the appropriate
-	argument register (separate registers for integer and floating
-	point arguments, but used in lock-step), and the remaining
-	arguments are dumped to the stack, beginning at 0(sp).  Our
-	first argument is a pair of the list of remaining argument
-	registers to be assigned for this call and the next stack
-	offset to use for overflowing arguments.  This way,
-	@get_Arg@ can be applied to all of a call's arguments using
-	@mapAccumLNat@.
-    -}
-    get_arg
-	:: ([(Reg,Reg)], Int)	-- Argument registers and stack offset (accumulator)
-	-> StixTree		-- Current argument
-	-> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-
-    -- We have to use up all of our argument registers first...
-
-    get_arg ((iDst,fDst):dsts, offset) arg
-      = getRegister arg	    	    	    `thenNat` \ register ->
-	let
-	    reg  = if isFloatType pk then fDst else iDst
-	    code = registerCode register reg
-	    src  = registerName register reg
-	    pk   = registerRep register
-	in
-	return (
-	    if isFloatType pk then
-		((dsts, offset), if isFixed register then
-		    code . mkSeqInstr (FMOV src fDst)
-		    else code)
-	    else
-		((dsts, offset), if isFixed register then
-		    code . mkSeqInstr (OR src (RIReg src) iDst)
-		    else code))
-
-    -- Once we have run out of argument registers, we move to the
-    -- stack...
-
-    get_arg ([], offset) arg
-      = getRegister arg			`thenNat` \ register ->
-	getNewRegNat (registerRep register)
-					`thenNat` \ tmp ->
-	let
-	    code = registerCode register tmp
-	    src  = registerName register tmp
-	    pk   = registerRep register
-	    sz   = primRepToSize pk
-	in
-	return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-trivialCode instr x (StInt y)
-  | fits8Bits y
-  = getRegister x		`thenNat` \ register ->
-    getNewRegNat IntRep		`thenNat` \ tmp ->
-    let
-    	code = registerCode register tmp
-    	src1 = registerName register tmp
-    	src2 = ImmInt (fromInteger y)
-    	code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
-    in
-    return (Any IntRep code__2)
-
-trivialCode instr x y
-  = getRegister x		`thenNat` \ register1 ->
-    getRegister y		`thenNat` \ register2 ->
-    getNewRegNat IntRep		`thenNat` \ tmp1 ->
-    getNewRegNat IntRep		`thenNat` \ tmp2 ->
-    let
-    	code1 = registerCode register1 tmp1 []
-    	src1  = registerName register1 tmp1
-    	code2 = registerCode register2 tmp2 []
-    	src2  = registerName register2 tmp2
-    	code__2 dst = asmSeqThen [code1, code2] .
-    	    	     mkSeqInstr (instr src1 (RIReg src2) dst)
-    in
-    return (Any IntRep code__2)
-
-------------
-trivialUCode instr x
-  = getRegister x		`thenNat` \ register ->
-    getNewRegNat IntRep		`thenNat` \ tmp ->
-    let
-    	code = registerCode register tmp
-    	src  = registerName register tmp
-    	code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
-    in
-    return (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
-  = getRegister x		`thenNat` \ register1 ->
-    getRegister y		`thenNat` \ register2 ->
-    getNewRegNat FF64	`thenNat` \ tmp1 ->
-    getNewRegNat FF64	`thenNat` \ tmp2 ->
-    let
-    	code1 = registerCode register1 tmp1
-    	src1  = registerName register1 tmp1
-
-    	code2 = registerCode register2 tmp2
-    	src2  = registerName register2 tmp2
-
-    	code__2 dst = asmSeqThen [code1 [], code2 []] .
-    	    	      mkSeqInstr (instr src1 src2 dst)
-    in
-    return (Any FF64 code__2)
-
-trivialUFCode _ instr x
-  = getRegister x		`thenNat` \ register ->
-    getNewRegNat FF64	`thenNat` \ tmp ->
-    let
-    	code = registerCode register tmp
-    	src  = registerName register tmp
-    	code__2 dst = code . mkSeqInstr (instr src dst)
-    in
-    return (Any FF64 code__2)
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
-  = getRegister x		`thenNat` \ register ->
-    getNewRegNat IntRep		`thenNat` \ reg ->
-    let
-    	code = registerCode register reg
-    	src  = registerName register reg
-
-    	code__2 dst = code . mkSeqInstrs [
-    	    ST Q src (spRel 0),
-    	    LD TF dst (spRel 0),
-    	    CVTxy Q TF dst dst]
-    in
-    return (Any FF64 code__2)
-
--------------
-coerceFP2Int x
-  = getRegister x		`thenNat` \ register ->
-    getNewRegNat FF64	`thenNat` \ tmp ->
-    let
-    	code = registerCode register tmp
-    	src  = registerName register tmp
-
-    	code__2 dst = code . mkSeqInstrs [
-    	    CVTxy TF Q src tmp,
-    	    ST TF tmp (spRel 0),
-    	    LD Q dst (spRel 0)]
-    in
-    return (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--}
-
-
-
-
-
diff --git a/compiler/nativeGen/Alpha/Instr.hs b/compiler/nativeGen/Alpha/Instr.hs
deleted file mode 100644
index 990ea8b..0000000
--- a/compiler/nativeGen/Alpha/Instr.hs
+++ /dev/null
@@ -1,142 +0,0 @@
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-module Alpha.Instr (
---	Cond(..),
---	Instr(..),
---	RI(..)
-)
-
-where
-
-{-
-import BlockId
-import Regs
-import Cmm
-import FastString
-import CLabel
-
-data Cond
-	= ALWAYS	-- For BI (same as BR)
-	| EQQ		-- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
-	| GE		-- For BI only
-	| GTT		-- For BI only (NB: "GT" is a 1.3 Prelude name)
-	| LE		-- For CMP and BI
-	| LTT		-- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
-	| NE		-- For BI only
-	| NEVER		-- For BI (null instruction)
-	| ULE		-- For CMP only
-	| ULT		-- For CMP only
-	deriving Eq
-	
-
--- -----------------------------------------------------------------------------
--- Machine's assembly language
-
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Register or immediate
-data RI 
-	= RIReg Reg
-	| RIImm Imm
-
-data Instr
-	-- comment pseudo-op
-	= COMMENT FastString		
-
-	-- some static data spat out during code
-	-- generation.  Will be extracted before
-	-- pretty-printing.
-	| LDATA   Section [CmmStatic]	
-
-	-- start a new basic block.  Useful during
-	-- codegen, removed later.  Preceding 
-	-- instruction should be a jump, as per the
-	-- invariants for a BasicBlock (see Cmm).
-	| NEWBLOCK BlockId		
-
-	-- specify current stack offset for
-        -- benefit of subsequent passes
-	| DELTA   Int
-
-	-- | spill this reg to a stack slot
-	| SPILL   Reg Int
-
-	-- | reload this reg from a stack slot
-	| RELOAD  Int Reg
-
-	-- Loads and stores.
-	| LD	      Size Reg AddrMode		-- size, dst, src
-	| LDA	      Reg AddrMode		-- dst, src
-	| LDAH	      Reg AddrMode		-- dst, src
-	| LDGP	      Reg AddrMode		-- dst, src
-	| LDI	      Size Reg Imm     		-- size, dst, src
-	| ST	      Size Reg AddrMode 	-- size, src, dst
-
-	-- Int Arithmetic.
-	| CLR	      Reg		    	-- dst
-	| ABS	      Size RI Reg	    	-- size, src, dst
-	| NEG	      Size Bool RI Reg	   	-- size, overflow, src, dst
-	| ADD	      Size Bool Reg RI Reg 	-- size, overflow, src, src, dst
-	| SADD	      Size Size Reg RI Reg 	-- size, scale, src, src, dst
-	| SUB	      Size Bool Reg RI Reg 	-- size, overflow, src, src, dst
-	| SSUB	      Size Size Reg RI Reg 	-- size, scale, src, src, dst
-	| MUL	      Size Bool Reg RI Reg 	-- size, overflow, src, src, dst
-	| DIV	      Size Bool Reg RI Reg 	-- size, unsigned, src, src, dst
-	| REM	      Size Bool Reg RI Reg 	-- size, unsigned, src, src, dst
-
-	-- Simple bit-twiddling.
-	| NOT	      RI Reg
-	| AND	      Reg RI Reg
-	| ANDNOT      Reg RI Reg
-	| OR	      Reg RI Reg
-	| ORNOT	      Reg RI Reg
-	| XOR	      Reg RI Reg
-	| XORNOT      Reg RI Reg
-	| SLL	      Reg RI Reg
-	| SRL	      Reg RI Reg
-	| SRA	      Reg RI Reg
-
-	| ZAP	      Reg RI Reg
-	| ZAPNOT      Reg RI Reg
-
-	| NOP
-
-	-- Comparison
-	| CMP	      Cond Reg RI Reg
-
-	-- Float Arithmetic.
-	| FCLR	      Reg
-	| FABS	      Reg Reg
-	| FNEG	      Size Reg Reg
-	| FADD	      Size Reg Reg Reg
-	| FDIV	      Size Reg Reg Reg
-	| FMUL	      Size Reg Reg Reg
-	| FSUB	      Size Reg Reg Reg
-	| CVTxy	      Size Size Reg Reg
-	| FCMP	      Size Cond Reg Reg Reg
-	| FMOV	      Reg Reg
-
-	-- Jumping around.
-	| BI	      Cond Reg Imm
-	| BF	      Cond Reg Imm
-	| BR	      Imm
-	| JMP	      Reg AddrMode Int
-	| BSR	      Imm Int
-	| JSR	      Reg AddrMode Int
-
-	-- Alpha-specific pseudo-ops.
-	| FUNBEGIN CLabel
-	| FUNEND CLabel
-
-
--}
diff --git a/compiler/nativeGen/Alpha/Ppr.hs-old b/compiler/nativeGen/Alpha/Ppr.hs-old
deleted file mode 100644
index c14eef2..0000000
--- a/compiler/nativeGen/Alpha/Ppr.hs-old
+++ /dev/null
@@ -1,562 +0,0 @@
-
-module Alpha.Ppr (
-{-
-	pprReg,
-	pprSize,
-	pprCond,
-	pprAddr,
-	pprSectionHeader,
-	pprTypeAndSizeDecl,
-	pprRI,
-	pprRegRIReg,
-	pprSizeRegRegReg
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-import BlockId
-import Cmm
-import Regs		-- may differ per-platform
-import Instrs
-
-import CLabel		( CLabel, pprCLabel, externallyVisibleCLabel,
-			  labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
-
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-import CLabel       ( mkDeadStripPreventer )
-#endif
-
-import Panic		( panic )
-import Unique		( pprUnique )
-import Pretty
-import FastString
-import qualified Outputable
-import Outputable	( Outputable, pprPanic, ppr, docToSDoc)
-
-import Data.Array.ST
-import Data.Word	( Word8 )
-import Control.Monad.ST
-import Data.Char	( chr, ord )
-import Data.Maybe       ( isJust )
-
-
-
-pprReg :: Reg -> Doc
-pprReg r
-  = case r of
-      RealReg i      -> ppr_reg_no i
-      VirtualRegI  u  -> text "%vI_"  <> asmSDoc (pprUnique u)
-      VirtualRegHi u  -> text "%vHi_" <> asmSDoc (pprUnique u)
-      VirtualRegF  u  -> text "%vF_"  <> asmSDoc (pprUnique u)
-      VirtualRegD  u  -> text "%vD_"  <> asmSDoc (pprUnique u)
-  where
-    ppr_reg_no :: Int -> Doc
-    ppr_reg_no i = ptext
-      (case i of {
-	 0 -> sLit "$0";    1 -> sLit "$1";
-	 2 -> sLit "$2";    3 -> sLit "$3";
-	 4 -> sLit "$4";    5 -> sLit "$5";
-	 6 -> sLit "$6";    7 -> sLit "$7";
-	 8 -> sLit "$8";    9 -> sLit "$9";
-	10 -> sLit "$10";  11 -> sLit "$11";
-	12 -> sLit "$12";  13 -> sLit "$13";
-	14 -> sLit "$14";  15 -> sLit "$15";
-	16 -> sLit "$16";  17 -> sLit "$17";
-	18 -> sLit "$18";  19 -> sLit "$19";
-	20 -> sLit "$20";  21 -> sLit "$21";
-	22 -> sLit "$22";  23 -> sLit "$23";
-	24 -> sLit "$24";  25 -> sLit "$25";
-	26 -> sLit "$26";  27 -> sLit "$27";
-	28 -> sLit "$28";  29 -> sLit "$29";
-	30 -> sLit "$30";  31 -> sLit "$31";
-	32 -> sLit "$f0";  33 -> sLit "$f1";
-	34 -> sLit "$f2";  35 -> sLit "$f3";
-	36 -> sLit "$f4";  37 -> sLit "$f5";
-	38 -> sLit "$f6";  39 -> sLit "$f7";
-	40 -> sLit "$f8";  41 -> sLit "$f9";
-	42 -> sLit "$f10"; 43 -> sLit "$f11";
-	44 -> sLit "$f12"; 45 -> sLit "$f13";
-	46 -> sLit "$f14"; 47 -> sLit "$f15";
-	48 -> sLit "$f16"; 49 -> sLit "$f17";
-	50 -> sLit "$f18"; 51 -> sLit "$f19";
-	52 -> sLit "$f20"; 53 -> sLit "$f21";
-	54 -> sLit "$f22"; 55 -> sLit "$f23";
-	56 -> sLit "$f24"; 57 -> sLit "$f25";
-	58 -> sLit "$f26"; 59 -> sLit "$f27";
-	60 -> sLit "$f28"; 61 -> sLit "$f29";
-	62 -> sLit "$f30"; 63 -> sLit "$f31";
-	_  -> sLit "very naughty alpha register"
-      })
-
-
-pprSize :: Size -> Doc
-pprSize x = ptext (case x of
-	 B  -> sLit "b"
-	 Bu -> sLit "bu"
---	 W  -> sLit "w" UNUSED
---	 Wu -> sLit "wu" UNUSED
-	 L  -> sLit "l"
-	 Q  -> sLit "q"
---	 FF -> sLit "f" UNUSED
---	 DF -> sLit "d" UNUSED
---	 GF -> sLit "g" UNUSED
---	 SF -> sLit "s" UNUSED
-	 TF -> sLit "t"
-
-
-pprCond :: Cond -> Doc
-pprCond c 
- = ptext (case c of
-		EQQ  -> sLit "eq"
-		LTT  -> sLit "lt"
-		LE  -> sLit "le"
-		ULT -> sLit "ult"
-		ULE -> sLit "ule"
-		NE  -> sLit "ne"
-		GTT  -> sLit "gt"
-		GE  -> sLit "ge")
-
-
-pprAddr :: AddrMode -> Doc
-pprAddr (AddrReg r) = parens (pprReg r)
-pprAddr (AddrImm i) = pprImm i
-pprAddr (AddrRegImm r1 i)
-  = (<>) (pprImm i) (parens (pprReg r1))
-
-
-pprSectionHeader Text
-    = ptext	(sLit "\t.text\n\t.align 3")
-
-pprSectionHeader Data
-    = ptext	(sLit "\t.data\n\t.align 3")
-
-pprSectionHeader ReadOnlyData
-    = ptext	(sLit "\t.data\n\t.align 3")
-
-pprSectionHeader RelocatableReadOnlyData
-    = ptext	(sLit "\t.data\n\t.align 3")
-
-pprSectionHeader UninitialisedData
-    = ptext	(sLit "\t.bss\n\t.align 3")
-
-pprSectionHeader ReadOnlyData16
-    = ptext	(sLit "\t.data\n\t.align 4")
-
-pprSectionHeader (OtherSection sec)
-    = panic "PprMach.pprSectionHeader: unknown section"
-
-
-pprTypeAndSizeDecl :: CLabel -> Doc
-pprTypeAndSizeDecl lbl
-  = empty
-
-
-
-pprInstr :: Instr -> Doc
-
-pprInstr (DELTA d)
-   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-
-pprInstr (NEWBLOCK _)
-   = panic "PprMach.pprInstr: NEWBLOCK"
-
-pprInstr (LDATA _ _)
-   = panic "PprMach.pprInstr: LDATA"
-
-pprInstr (SPILL reg slot)
-   = hcat [
-   	ptext (sLit "\tSPILL"),
-	char '\t',
-	pprReg reg,
-	comma,
-	ptext (sLit "SLOT") <> parens (int slot)]
-
-pprInstr (RELOAD slot reg)
-   = hcat [
-   	ptext (sLit "\tRELOAD"),
-	char '\t',
-	ptext (sLit "SLOT") <> parens (int slot),
-	comma,
-	pprReg reg]
-
-pprInstr (LD size reg addr)
-  = hcat [
-	ptext (sLit "\tld"),
-	pprSize size,
-	char '\t',
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (LDA reg addr)
-  = hcat [
-	ptext (sLit "\tlda\t"),
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (LDAH reg addr)
-  = hcat [
-	ptext (sLit "\tldah\t"),
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (LDGP reg addr)
-  = hcat [
-	ptext (sLit "\tldgp\t"),
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (LDI size reg imm)
-  = hcat [
-	ptext (sLit "\tldi"),
-	pprSize size,
-	char '\t',
-	pprReg reg,
-	comma,
-	pprImm imm
-    ]
-
-pprInstr (ST size reg addr)
-  = hcat [
-	ptext (sLit "\tst"),
-	pprSize size,
-	char '\t',
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (CLR reg)
-  = hcat [
-	ptext (sLit "\tclr\t"),
-	pprReg reg
-    ]
-
-pprInstr (ABS size ri reg)
-  = hcat [
-	ptext (sLit "\tabs"),
-	pprSize size,
-	char '\t',
-	pprRI ri,
-	comma,
-	pprReg reg
-    ]
-
-pprInstr (NEG size ov ri reg)
-  = hcat [
-	ptext (sLit "\tneg"),
-	pprSize size,
-	if ov then ptext (sLit "v\t") else char '\t',
-	pprRI ri,
-	comma,
-	pprReg reg
-    ]
-
-pprInstr (ADD size ov reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\tadd"),
-	pprSize size,
-	if ov then ptext (sLit "v\t") else char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (SADD size scale reg1 ri reg2)
-  = hcat [
-	ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
-	ptext (sLit "add"),
-	pprSize size,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (SUB size ov reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\tsub"),
-	pprSize size,
-	if ov then ptext (sLit "v\t") else char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (SSUB size scale reg1 ri reg2)
-  = hcat [
-	ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
-	ptext (sLit "sub"),
-	pprSize size,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (MUL size ov reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\tmul"),
-	pprSize size,
-	if ov then ptext (sLit "v\t") else char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (DIV size uns reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\tdiv"),
-	pprSize size,
-	if uns then ptext (sLit "u\t") else char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (REM size uns reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\trem"),
-	pprSize size,
-	if uns then ptext (sLit "u\t") else char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (NOT ri reg)
-  = hcat [
-	ptext (sLit "\tnot"),
-	char '\t',
-	pprRI ri,
-	comma,
-	pprReg reg
-    ]
-
-pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
-pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
-pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
-pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
-pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
-pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
-
-pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
-
-pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
-pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
-
-pprInstr (NOP) = ptext (sLit "\tnop")
-
-pprInstr (CMP cond reg1 ri reg2)
-  = hcat [
-	ptext (sLit "\tcmp"),
-	pprCond cond,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (FCLR reg)
-  = hcat [
-	ptext (sLit "\tfclr\t"),
-	pprReg reg
-    ]
-
-pprInstr (FABS reg1 reg2)
-  = hcat [
-	ptext (sLit "\tfabs\t"),
-	pprReg reg1,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (FNEG size reg1 reg2)
-  = hcat [
-	ptext (sLit "\tneg"),
-	pprSize size,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
-pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
-pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
-pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
-
-pprInstr (CVTxy size1 size2 reg1 reg2)
-  = hcat [
-	ptext (sLit "\tcvt"),
-	pprSize size1,
-	case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (FCMP size cond reg1 reg2 reg3)
-  = hcat [
-	ptext (sLit "\tcmp"),
-	pprSize size,
-	pprCond cond,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprReg reg2,
-	comma,
-	pprReg reg3
-    ]
-
-pprInstr (FMOV reg1 reg2)
-  = hcat [
-	ptext (sLit "\tfmov\t"),
-	pprReg reg1,
-	comma,
-	pprReg reg2
-    ]
-
-pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-
-pprInstr (BI NEVER reg lab) = empty
-
-pprInstr (BI cond reg lab)
-  = hcat [
-	ptext (sLit "\tb"),
-	pprCond cond,
-	char '\t',
-	pprReg reg,
-	comma,
-	pprImm lab
-    ]
-
-pprInstr (BF cond reg lab)
-  = hcat [
-	ptext (sLit "\tfb"),
-	pprCond cond,
-	char '\t',
-	pprReg reg,
-	comma,
-	pprImm lab
-    ]
-
-pprInstr (BR lab)
-  = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
-
-pprInstr (JMP reg addr hint)
-  = hcat [
-	ptext (sLit "\tjmp\t"),
-	pprReg reg,
-	comma,
-	pprAddr addr,
-	comma,
-	int hint
-    ]
-
-pprInstr (BSR imm n)
-  = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
-
-pprInstr (JSR reg addr n)
-  = hcat [
-	ptext (sLit "\tjsr\t"),
-	pprReg reg,
-	comma,
-	pprAddr addr
-    ]
-
-pprInstr (FUNBEGIN clab)
-  = hcat [
-	if (externallyVisibleCLabel clab) then
-	    hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
-	else
-	    empty,
-	ptext (sLit "\t.ent "),
-	pp_lab,
-	char '\n',
-	pp_lab,
-	pp_ldgp,
-	pp_lab,
-	pp_frame
-    ]
-    where
-	pp_lab = pprCLabel_asm clab
-
-        -- NEVER use commas within those string literals, cpp will ruin your day
-	pp_ldgp  = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
-	pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
-                          ptext (sLit "4240"), char ',',
-                          ptext (sLit "$26"), char ',',
-                          ptext (sLit "0\n\t.prologue 1") ]
-
-pprInstr (FUNEND clab)
-  = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
-
-
-pprRI :: RI -> Doc
-
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
-pprRegRIReg name reg1 ri reg2
-  = hcat [
- 	char '\t',
-	ptext name,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprRI ri,
-	comma,
-	pprReg reg2
-    ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
-  = hcat [
-	char '\t',
-	ptext name,
-	pprSize size,
-	char '\t',
-	pprReg reg1,
-	comma,
-	pprReg reg2,
-	comma,
-	pprReg reg3
-    ]
-
--}
-
-
-
diff --git a/compiler/nativeGen/Alpha/RegInfo.hs b/compiler/nativeGen/Alpha/RegInfo.hs
deleted file mode 100644
index 7fdde4d..0000000
--- a/compiler/nativeGen/Alpha/RegInfo.hs
+++ /dev/null
@@ -1,218 +0,0 @@
-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
-module Alpha.RegInfo (
-{-
-	RegUsage(..),
-	noUsage,
-	regUsage,
-	patchRegs,
-	jumpDests,
-	isJumpish,
-	patchJump,
-	isRegRegMove,
-
-        JumpDest, canShortcut, shortcutJump, shortcutStatic,
-
-	maxSpillSlots,
-	mkSpillInstr,
-	mkLoadInstr,
-	mkRegRegMoveInstr,
-	mkBranchInstr
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-
-import BlockId
-import Cmm
-import CLabel
-import Instrs
-import Regs
-import Outputable
-import Constants	( rESERVED_C_STACK_BYTES )
-import FastBool
-
-data RegUsage = RU [Reg] [Reg]
-
-noUsage :: RegUsage
-noUsage  = RU [] []
-
-regUsage :: Instr -> RegUsage
-
-regUsage instr = case instr of
-    SPILL  reg slot	-> usage ([reg], [])
-    RELOAD slot reg	-> usage ([], [reg])
-    LD B reg addr	-> usage (regAddr addr, [reg, t9])
-    LD Bu reg addr	-> usage (regAddr addr, [reg, t9])
---  LD W reg addr	-> usage (regAddr addr, [reg, t9]) : UNUSED
---  LD Wu reg addr	-> usage (regAddr addr, [reg, t9]) : UNUSED
-    LD sz reg addr	-> usage (regAddr addr, [reg])
-    LDA reg addr	-> usage (regAddr addr, [reg])
-    LDAH reg addr	-> usage (regAddr addr, [reg])
-    LDGP reg addr	-> usage (regAddr addr, [reg])
-    LDI sz reg imm	-> usage ([], [reg])
-    ST B reg addr	-> usage (reg : regAddr addr, [t9, t10])
---  ST W reg addr	-> usage (reg : regAddr addr, [t9, t10]) : UNUSED
-    ST sz reg addr	-> usage (reg : regAddr addr, [])
-    CLR reg		-> usage ([], [reg])
-    ABS sz ri reg	-> usage (regRI ri, [reg])
-    NEG sz ov ri reg	-> usage (regRI ri, [reg])
-    ADD sz ov r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
-    SUB sz ov r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
-    MUL sz ov r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    DIV sz un r1 ar r2	-> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
-    REM sz un r1 ar r2	-> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
-    NOT ri reg		-> usage (regRI ri, [reg])
-    AND r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    ANDNOT r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    OR r1 ar r2		-> usage (r1 : regRI ar, [r2])
-    ORNOT r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    XOR r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    XORNOT r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    SLL r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    SRL r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    SRA r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    ZAP r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    ZAPNOT r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    CMP co r1 ar r2	-> usage (r1 : regRI ar, [r2])
-    FCLR reg		-> usage ([], [reg])
-    FABS r1 r2		-> usage ([r1], [r2])
-    FNEG sz r1 r2	-> usage ([r1], [r2])
-    FADD sz r1 r2 r3	-> usage ([r1, r2], [r3])
-    FDIV sz r1 r2 r3	-> usage ([r1, r2], [r3])
-    FMUL sz r1 r2 r3	-> usage ([r1, r2], [r3])
-    FSUB sz r1 r2 r3	-> usage ([r1, r2], [r3])
-    CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2])
-    FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3])
-    FMOV r1 r2		-> usage ([r1], [r2])
-
-
-    -- We assume that all local jumps will be BI/BF/BR.	 JMP must be out-of-line.
-    BI cond reg lbl	-> usage ([reg], [])
-    BF cond reg lbl	-> usage ([reg], [])
-    JMP reg addr hint	-> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet
-
-    BSR _ n		-> RU (argRegSet n) callClobberedRegSet
-    JSR reg addr n	-> RU (argRegSet n) callClobberedRegSet
-
-    _			-> noUsage
-
-  where
-    usage (src, dst) = RU (mkRegSet (filter interesting src))
-			  (mkRegSet (filter interesting dst))
-
-    interesting (FixedReg _) = False
-    interesting _ = True
-
-    regAddr (AddrReg r1)      = [r1]
-    regAddr (AddrRegImm r1 _) = [r1]
-    regAddr (AddrImm _)	      = []
-
-    regRI (RIReg r) = [r]
-    regRI  _	= []
-
-
-patchRegs :: Instr -> (Reg -> Reg) -> Instr
-patchRegs instr env = case instr of
-    SPILL  reg slot	-> SPILL (env reg) slot
-    RELOAD slot reg	-> RELOAD slot (env reg)
-    LD sz reg addr -> LD sz (env reg) (fixAddr addr)
-    LDA reg addr -> LDA (env reg) (fixAddr addr)
-    LDAH reg addr -> LDAH (env reg) (fixAddr addr)
-    LDGP reg addr -> LDGP (env reg) (fixAddr addr)
-    LDI sz reg imm -> LDI sz (env reg) imm
-    ST sz reg addr -> ST sz (env reg) (fixAddr addr)
-    CLR reg -> CLR (env reg)
-    ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
-    NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
-    ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
-    SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
-    SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
-    SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
-    MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
-    DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
-    REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
-    NOT ar reg -> NOT (fixRI ar) (env reg)
-    AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
-    ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
-    OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
-    ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
-    XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
-    XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2)
-    SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
-    SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
-    SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
-    ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
-    ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
-    CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
-    FCLR reg -> FCLR (env reg)
-    FABS r1 r2 -> FABS (env r1) (env r2)
-    FNEG s r1 r2 -> FNEG s (env r1) (env r2)
-    FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
-    FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
-    FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
-    FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
-    CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
-    FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
-    FMOV r1 r2 -> FMOV (env r1) (env r2)
-    BI cond reg lbl -> BI cond (env reg) lbl
-    BF cond reg lbl -> BF cond (env reg) lbl
-    JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
-    JSR reg addr i -> JSR (env reg) (fixAddr addr) i
-    _ -> instr
-  where
-    fixAddr (AddrReg r1)       = AddrReg (env r1)
-    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
-    fixAddr other	       = other
-
-    fixRI (RIReg r) = RIReg (env r)
-    fixRI other	= other
-
-
-mkSpillInstr
-   :: Reg		-- register to spill
-   -> Int		-- current stack delta
-   -> Int		-- spill slot to use
-   -> Instr
-
-mkSpillInstr reg delta slot
-  = let	off     = spillSlotToOffset slot
-    in
-    -- Alpha: spill below the stack pointer (?)
-    ST sz dyn (spRel (- (off `div` 8)))
-
-
-mkLoadInstr
-   :: Reg		-- register to load
-   -> Int		-- current stack delta
-   -> Int		-- spill slot to use
-   -> Instr
-mkLoadInstr reg delta slot
-  = let off     = spillSlotToOffset slot
-    in
-	 LD  sz dyn (spRel (- (off `div` 8)))
-
-
-mkBranchInstr
-    :: BlockId
-    -> [Instr]
-
-mkBranchInstr id = [BR id]
-
--}
-
-
-
-
diff --git a/compiler/nativeGen/Alpha/Regs.hs b/compiler/nativeGen/Alpha/Regs.hs
deleted file mode 100644
index ee49050..0000000
--- a/compiler/nativeGen/Alpha/Regs.hs
+++ /dev/null
@@ -1,323 +0,0 @@
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1994-2004
--- 
--- Alpha support is rotted and incomplete.
--- -----------------------------------------------------------------------------
-
-
-module Alpha.Regs (
-{-
-	Size(..),
-	AddrMode(..),
-	fits8Bits,
-	fReg,
-	gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-#include "../includes/stg/MachRegs.h"
-
-import RegsBase
-
-import BlockId
-import Cmm
-import CLabel           ( CLabel, mkMainCapabilityLabel )
-import Pretty
-import Outputable	( Outputable(..), pprPanic, panic )
-import qualified Outputable
-import Unique
-import UniqSet
-import Constants
-import FastTypes
-import FastBool
-import UniqFM
-
-
-data Size
-	= B	    -- byte
-	| Bu
---	| W	    -- word (2 bytes): UNUSED
---	| Wu    -- : UNUSED
-	| L	    -- longword (4 bytes)
-	| Q	    -- quadword (8 bytes)
---	| FF    -- VAX F-style floating pt: UNUSED
---	| GF    -- VAX G-style floating pt: UNUSED
---	| DF    -- VAX D-style floating pt: UNUSED
---	| SF    -- IEEE single-precision floating pt: UNUSED
-	| TF    -- IEEE double-precision floating pt
-	deriving Eq
-
-
-data AddrMode
-	= AddrImm	Imm
-	| AddrReg	Reg
-	| AddrRegImm	Reg Imm
-
-
-addrOffset :: AddrMode -> Int -> Maybe AddrMode
-addrOffset addr off
-  = case addr of
-      _ -> panic "MachMisc.addrOffset not defined for Alpha"
-
-fits8Bits :: Integer -> Bool
-fits8Bits i = i >= -256 && i < 256
-
-
--- The Alpha has 64 registers of interest; 32 integer registers and 32 floating
--- point registers.  The mapping of STG registers to alpha machine registers
--- is defined in StgRegs.h.  We are, of course, prepared for any eventuality.
-
-fReg :: Int -> RegNo
-fReg x = (32 + x)
-
-v0, f0, ra, pv, gp, sp, zeroh :: Reg
-v0    = realReg 0
-f0    = realReg (fReg 0)
-ra    = FixedReg ILIT(26)
-pv    = t12
-gp    = FixedReg ILIT(29)
-sp    = FixedReg ILIT(30)
-zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method)
-
-t9, t10, t11, t12 :: Reg
-t9  = realReg 23
-t10 = realReg 24
-t11 = realReg 25
-t12 = realReg 27
-
-
-#define f0 32
-#define f1 33
-#define f2 34
-#define f3 35
-#define f4 36
-#define f5 37
-#define f6 38
-#define f7 39
-#define f8 40
-#define f9 41
-#define f10 42
-#define f11 43
-#define f12 44
-#define f13 45
-#define f14 46
-#define f15 47
-#define f16 48
-#define f17 49
-#define f18 50
-#define f19 51
-#define f20 52
-#define f21 53
-#define f22 54
-#define f23 55
-#define f24 56
-#define f25 57
-#define f26 58
-#define f27 59
-#define f28 60
-#define f29 61
-#define f30 62
-#define f31 63
-
-
--- allMachRegs is the complete set of machine regs.
-allMachRegNos :: [RegNo]
-allMachRegNos	= [0..63]
-
-
--- these are the regs which we cannot assume stay alive over a
--- C call.  
-callClobberedRegs :: [Reg]
-callClobberedRegs
- =	[0, 1, 2, 3, 4, 5, 6, 7, 8,
-	 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
-	 fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15,
-	 fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23,
-	 fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
-
-
--- argRegs is the set of regs which are read for an n-argument call to C.
--- For archs which pass all args on the stack (x86), is empty.
--- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
-argRegs :: RegNo -> [Reg]
-
-argRegs 0 = []
-argRegs 1 = freeMappedRegs [16, fReg 16]
-argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17]
-argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]
-argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]
-argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]
-argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]
-argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!"
-
-
--- all of the arg regs ??
-allArgRegs :: [(Reg, Reg)]
-allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
-
-
--- horror show -----------------------------------------------------------------
-
-freeReg :: RegNo -> FastBool
-
-freeReg 26 = fastBool False  -- return address (ra)
-freeReg 28 = fastBool False  -- reserved for the assembler (at)
-freeReg 29 = fastBool False  -- global pointer (gp)
-freeReg 30 = fastBool False  -- stack pointer (sp)
-freeReg 31 = fastBool False  -- always zero (zeroh)
-freeReg 63 = fastBool False  -- always zero (f31)
-
-#ifdef REG_Base
-freeReg REG_Base = fastBool False
-#endif
-#ifdef REG_R1
-freeReg REG_R1   = fastBool False
-#endif	
-#ifdef REG_R2  
-freeReg REG_R2   = fastBool False
-#endif	
-#ifdef REG_R3  
-freeReg REG_R3   = fastBool False
-#endif	
-#ifdef REG_R4  
-freeReg REG_R4   = fastBool False
-#endif	
-#ifdef REG_R5  
-freeReg REG_R5   = fastBool False
-#endif	
-#ifdef REG_R6  
-freeReg REG_R6   = fastBool False
-#endif	
-#ifdef REG_R7  
-freeReg REG_R7   = fastBool False
-#endif	
-#ifdef REG_R8  
-freeReg REG_R8   = fastBool False
-#endif
-#ifdef REG_F1
-freeReg REG_F1 = fastBool False
-#endif
-#ifdef REG_F2
-freeReg REG_F2 = fastBool False
-#endif
-#ifdef REG_F3
-freeReg REG_F3 = fastBool False
-#endif
-#ifdef REG_F4
-freeReg REG_F4 = fastBool False
-#endif
-#ifdef REG_D1
-freeReg REG_D1 = fastBool False
-#endif
-#ifdef REG_D2
-freeReg REG_D2 = fastBool False
-#endif
-#ifdef REG_Sp 
-freeReg REG_Sp   = fastBool False
-#endif 
-#ifdef REG_Su
-freeReg REG_Su   = fastBool False
-#endif 
-#ifdef REG_SpLim 
-freeReg REG_SpLim = fastBool False
-#endif 
-#ifdef REG_Hp 
-freeReg REG_Hp   = fastBool False
-#endif
-#ifdef REG_HpLim
-freeReg REG_HpLim = fastBool False
-#endif
-freeReg n               = fastBool True
-
-
---  | Returns 'Nothing' if this global register is not stored
--- in a real machine register, otherwise returns @'Just' reg@, where
--- reg is the machine register it is stored in.
-
-globalRegMaybe :: GlobalReg -> Maybe Reg
-
-#ifdef REG_Base
-globalRegMaybe BaseReg			= Just (RealReg REG_Base)
-#endif
-#ifdef REG_R1
-globalRegMaybe (VanillaReg 1 _)		= Just (RealReg REG_R1)
-#endif 
-#ifdef REG_R2 
-globalRegMaybe (VanillaReg 2 _)		= Just (RealReg REG_R2)
-#endif 
-#ifdef REG_R3 
-globalRegMaybe (VanillaReg 3 _) 	= Just (RealReg REG_R3)
-#endif 
-#ifdef REG_R4 
-globalRegMaybe (VanillaReg 4 _)		= Just (RealReg REG_R4)
-#endif 
-#ifdef REG_R5 
-globalRegMaybe (VanillaReg 5 _)		= Just (RealReg REG_R5)
-#endif 
-#ifdef REG_R6 
-globalRegMaybe (VanillaReg 6 _)		= Just (RealReg REG_R6)
-#endif 
-#ifdef REG_R7 
-globalRegMaybe (VanillaReg 7 _)		= Just (RealReg REG_R7)
-#endif 
-#ifdef REG_R8 
-globalRegMaybe (VanillaReg 8 _)		= Just (RealReg REG_R8)
-#endif
-#ifdef REG_R9 
-globalRegMaybe (VanillaReg 9 _)		= Just (RealReg REG_R9)
-#endif
-#ifdef REG_R10 
-globalRegMaybe (VanillaReg 10 _)	= Just (RealReg REG_R10)
-#endif
-#ifdef REG_F1
-globalRegMaybe (FloatReg 1)		= Just (RealReg REG_F1)
-#endif				 	
-#ifdef REG_F2			 	
-globalRegMaybe (FloatReg 2)		= Just (RealReg REG_F2)
-#endif				 	
-#ifdef REG_F3			 	
-globalRegMaybe (FloatReg 3)		= Just (RealReg REG_F3)
-#endif				 	
-#ifdef REG_F4			 	
-globalRegMaybe (FloatReg 4)		= Just (RealReg REG_F4)
-#endif				 	
-#ifdef REG_D1			 	
-globalRegMaybe (DoubleReg 1)		= Just (RealReg REG_D1)
-#endif				 	
-#ifdef REG_D2			 	
-globalRegMaybe (DoubleReg 2)		= Just (RealReg REG_D2)
-#endif
-#ifdef REG_Sp	    
-globalRegMaybe Sp		   	= Just (RealReg REG_Sp)
-#endif
-#ifdef REG_Lng1			 	
-globalRegMaybe (LongReg 1)		= Just (RealReg REG_Lng1)
-#endif				 	
-#ifdef REG_Lng2			 	
-globalRegMaybe (LongReg 2)		= Just (RealReg REG_Lng2)
-#endif
-#ifdef REG_SpLim	    			
-globalRegMaybe SpLim		   	= Just (RealReg REG_SpLim)
-#endif	    				
-#ifdef REG_Hp	   			
-globalRegMaybe Hp		   	= Just (RealReg REG_Hp)
-#endif	    				
-#ifdef REG_HpLim      			
-globalRegMaybe HpLim		   	= Just (RealReg REG_HpLim)
-#endif	    				
-#ifdef REG_CurrentTSO      			
-globalRegMaybe CurrentTSO	   	= Just (RealReg REG_CurrentTSO)
-#endif	    				
-#ifdef REG_CurrentNursery      			
-globalRegMaybe CurrentNursery	   	= Just (RealReg REG_CurrentNursery)
-#endif	    				
-globalRegMaybe _		   	= Nothing
-
--}
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7a38540..b607434 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -13,38 +13,24 @@ module AsmCodeGen ( nativeCodeGen ) where
 #include "nativeGen/NCG.h"
 
 
-#if   alpha_TARGET_ARCH
-import Alpha.CodeGen
-import Alpha.Regs
-import Alpha.RegInfo
-import Alpha.Instr
-
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
-import X86.CodeGen
-import X86.Regs
-import X86.Instr
-import X86.Ppr
-
-#elif sparc_TARGET_ARCH
-import SPARC.CodeGen
-import SPARC.CodeGen.Expand
-import SPARC.Regs
-import SPARC.Instr
-import SPARC.Ppr
-import SPARC.ShortcutJump
-
-#elif powerpc_TARGET_ARCH
-import PPC.CodeGen
-import PPC.Cond
-import PPC.Regs
-import PPC.RegInfo
-import PPC.Instr
-import PPC.Ppr
-
-#else
-#error "AsmCodeGen: unknown architecture"
-
-#endif
+import qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Cond
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
 
 import RegAlloc.Liveness
 import qualified RegAlloc.Linear.Main		as Linear
@@ -56,6 +42,7 @@ import qualified RegAlloc.Graph.TrivColorable	as Color
 
 import TargetReg
 import Platform
+import Config
 import Instruction
 import PIC
 import Reg
@@ -64,7 +51,7 @@ import NCGMonad
 import BlockId
 import CgUtils		( fixStgRegisters )
 import OldCmm
-import CmmOpt		( cmmMiniInline, cmmMachOpFold )
+import CmmOpt		( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
 import OldPprCmm
 import CLabel
 
@@ -74,9 +61,9 @@ import UniqSupply
 import DynFlags
 import StaticFlags
 import Util
-import Config
 
 import Digraph
+import Pretty (Doc)
 import qualified Pretty
 import BufWrite
 import Outputable
@@ -92,7 +79,6 @@ import Data.List
 import Data.Maybe
 import Control.Monad
 import System.IO
-import Distribution.System
 
 {-
 The native-code generator has machine-independent and
@@ -145,17 +131,87 @@ The machine-dependent bits break down as follows:
 -- -----------------------------------------------------------------------------
 -- Top-level of the native codegen
 
+data NcgImpl instr jumpDest = NcgImpl {
+    cmmTopCodeGen             :: DynFlags -> RawCmmTop -> NatM [NatCmmTop instr],
+    generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
+    canShortcut               :: instr -> Maybe jumpDest,
+    shortcutStatic            :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
+    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+    pprNatCmmTop              :: NatCmmTop instr -> Doc,
+    maxSpillSlots             :: Int,
+    allocatableRegs           :: [RealReg],
+    ncg_x86fp_kludge          :: [NatCmmTop instr] -> [NatCmmTop instr],
+    ncgExpandTop              :: [NatCmmTop instr] -> [NatCmmTop instr],
+    ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
+    }
+
 --------------------
 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
 nativeCodeGen dflags h us cmms
+ = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+       x86NcgImpl = NcgImpl {
+                         cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
+                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+                        ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
+                        ,canShortcut               = X86.Instr.canShortcut
+                        ,shortcutStatic            = X86.Instr.shortcutStatic
+                        ,shortcutJump              = X86.Instr.shortcutJump
+                        ,pprNatCmmTop              = X86.Ppr.pprNatCmmTop
+                        ,maxSpillSlots             = X86.Instr.maxSpillSlots
+                        ,allocatableRegs           = X86.Regs.allocatableRegs
+                        ,ncg_x86fp_kludge          = id
+                        ,ncgExpandTop              = id
+                        ,ncgMakeFarBranches        = id
+                    }
+   in case platformArch $ targetPlatform dflags of
+                 ArchX86    -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
+                 ArchX86_64 -> nCG' x86NcgImpl
+                 ArchPPC ->
+                     nCG' $ NcgImpl {
+                          cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
+                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+                         ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
+                         ,canShortcut               = PPC.RegInfo.canShortcut
+                         ,shortcutStatic            = PPC.RegInfo.shortcutStatic
+                         ,shortcutJump              = PPC.RegInfo.shortcutJump
+                         ,pprNatCmmTop              = PPC.Ppr.pprNatCmmTop
+                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
+                         ,allocatableRegs           = PPC.Regs.allocatableRegs
+                         ,ncg_x86fp_kludge          = id
+                         ,ncgExpandTop              = id
+                         ,ncgMakeFarBranches        = makeFarBranches
+                     }
+                 ArchSPARC ->
+                     nCG' $ NcgImpl {
+                          cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
+                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+                         ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
+                         ,canShortcut               = SPARC.ShortcutJump.canShortcut
+                         ,shortcutStatic            = SPARC.ShortcutJump.shortcutStatic
+                         ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
+                         ,pprNatCmmTop              = SPARC.Ppr.pprNatCmmTop
+                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
+                         ,allocatableRegs           = SPARC.Regs.allocatableRegs
+                         ,ncg_x86fp_kludge          = id
+                         ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
+                         ,ncgMakeFarBranches        = id
+                     }
+                 ArchPPC_64 ->
+                     panic "nativeCodeGen: No NCG for PPC 64"
+
+nativeCodeGen' :: (Instruction instr, Outputable instr)
+               => DynFlags
+               -> NcgImpl instr jumpDest
+               -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen' dflags ncgImpl h us cmms
  = do
 	let split_cmms	= concat $ map add_split cmms
-
         -- BufHandle is a performance hack.  We could hide it inside
         -- Pretty if it weren't for the fact that we do lots of little
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
- 	(imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0
+ 	(imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
         bFlush bufh
 
 	let (native, colorStats, linearStats)
@@ -164,7 +220,7 @@ nativeCodeGen dflags h us cmms
 	-- dump native code
 	dumpIfSet_dyn dflags
 		Opt_D_dump_asm "Asm code"
-		(vcat $ map (docToSDoc . pprNatCmmTop) $ concat native)
+		(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native)
 
 	-- dump global NCG stats for graph coloring allocator
 	(case concat $ catMaybes colorStats of
@@ -210,30 +266,32 @@ nativeCodeGen dflags h us cmms
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens :: DynFlags
+cmmNativeGens :: (Instruction instr, Outputable instr)
+              => DynFlags
+              -> NcgImpl instr jumpDest
               -> BufHandle
               -> UniqSupply
               -> [RawCmmTop]
               -> [[CLabel]]
-              -> [ ([NatCmmTop Instr],
-                   Maybe [Color.RegAllocStats Instr],
+              -> [ ([NatCmmTop instr],
+                   Maybe [Color.RegAllocStats instr],
                    Maybe [Linear.RegAllocStats]) ]
               -> Int
               -> IO ( [[CLabel]],
-                      [([NatCmmTop Instr],
-                      Maybe [Color.RegAllocStats Instr],
+                      [([NatCmmTop instr],
+                      Maybe [Color.RegAllocStats instr],
                       Maybe [Linear.RegAllocStats])] )
 
-cmmNativeGens _ _ _ [] impAcc profAcc _
+cmmNativeGens _ _ _ _ [] impAcc profAcc _
 	= return (reverse impAcc, reverse profAcc)
 
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
+cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
  = do
  	(us', native, imports, colorStats, linearStats)
-		<- cmmNativeGen dflags us cmm count
+		<- cmmNativeGen dflags ncgImpl us cmm count
 
 	Pretty.bufLeftRender h
-		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
+		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native
 
            -- carefully evaluate this strictly.  Binding it with 'let'
            -- and then using 'seq' doesn't work, because the let
@@ -249,7 +307,8 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
 	-- force evaulation all this stuff to avoid space leaks
 	seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
 
-	cmmNativeGens dflags h us' cmms
+	cmmNativeGens dflags ncgImpl
+            h us' cmms
 			(imports : impAcc)
 			((lsPprNative, colorStats, linearStats) : profAcc)
 			count'
@@ -261,18 +320,20 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
 -- | Complete native code generation phase for a single top-level chunk of Cmm.
 --	Dumping the output of each stage along the way.
 --	Global conflict graph and NGC stats
-cmmNativeGen 
-	:: DynFlags
+cmmNativeGen
+	:: (Instruction instr, Outputable instr)
+    => DynFlags
+    -> NcgImpl instr jumpDest
 	-> UniqSupply
 	-> RawCmmTop					-- ^ the cmm to generate code for
 	-> Int						-- ^ sequence number of this top thing
 	-> IO	( UniqSupply
-		, [NatCmmTop Instr]			-- native code
+		, [NatCmmTop instr]			-- native code
 		, [CLabel]				-- things imported by this cmm
-		, Maybe [Color.RegAllocStats Instr]	-- stats for the coloring register allocator
+		, Maybe [Color.RegAllocStats instr]	-- stats for the coloring register allocator
 		, Maybe [Linear.RegAllocStats])		-- stats for the linear register allocators
 
-cmmNativeGen dflags us cmm count
+cmmNativeGen dflags ncgImpl us cmm count
  = do
 
 	-- rewrite assignments to global regs
@@ -292,11 +353,11 @@ cmmNativeGen dflags us cmm count
 	-- generate native code from cmm
 	let ((native, lastMinuteImports), usGen) =
 		{-# SCC "genMachCode" #-}
-		initUs us $ genMachCode dflags opt_cmm
+		initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
 
 	dumpIfSet_dyn dflags
 		Opt_D_dump_asm_native "Native code"
-		(vcat $ map (docToSDoc . pprNatCmmTop) native)
+		(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native)
 
 	-- tag instructions with register liveness information
 	let (withLiveness, usLive) =
@@ -319,7 +380,7 @@ cmmNativeGen dflags us cmm count
 			= foldr (\r -> plusUFM_C unionUniqSets
 					$ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
 				emptyUFM
-			$ allocatableRegs
+			$ allocatableRegs ncgImpl
 
 		-- do the graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
@@ -328,13 +389,13 @@ cmmNativeGen dflags us cmm count
 			  $ Color.regAlloc
 				dflags
 				alloc_regs
-				(mkUniqSet [0..maxSpillSlots])
+				(mkUniqSet [0 .. maxSpillSlots ncgImpl])
 				withLiveness
 
 		-- dump out what happened during register allocation
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_regalloc "Registers allocated"
-			(vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+			(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
 
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_regalloc_stages "Build/spill stages"
@@ -365,7 +426,7 @@ cmmNativeGen dflags us cmm count
 
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_regalloc "Registers allocated"
-			(vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+			(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
 
 		let mPprStats =
 			if dopt Opt_D_dump_asm_stats dflags
@@ -378,38 +439,38 @@ cmmNativeGen dflags us cmm count
 			, Nothing
 			, mPprStats)
 
+        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
+        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
+        ---- is clear, and library functions can return odd results if it
+        ---- isn't.
+        ----
+        ---- NB. must happen before shortcutBranches, because that
+        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
+
+        ---- generate jump tables
+	let tabled	=
+		{-# SCC "generateJumpTables" #-}
+                generateJumpTables ncgImpl kludged
+
 	---- shortcut branches
 	let shorted	=
 	 	{-# SCC "shortcutBranches" #-}
-	 	shortcutBranches dflags alloced
+	 	shortcutBranches dflags ncgImpl tabled
 
 	---- sequence blocks
 	let sequenced	=
 	 	{-# SCC "sequenceBlocks" #-}
-	 	map sequenceTop shorted
-
-	---- x86fp_kludge
-	let kludged =
-#if i386_TARGET_ARCH
-	 	{-# SCC "x86fp_kludge" #-}
-	 	map x86fp_kludge sequenced
-#else
-		sequenced
-#endif
+	 	map (sequenceTop ncgImpl) shorted
 
-	---- expansion of SPARC synthetic instrs
-#if sparc_TARGET_ARCH
+        ---- expansion of SPARC synthetic instrs
 	let expanded = 
 		{-# SCC "sparc_expand" #-}
-		map expandTop kludged
+                ncgExpandTop ncgImpl sequenced
 
 	dumpIfSet_dyn dflags
 		Opt_D_dump_asm_expanded "Synthetic instructions expanded"
-		(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
-#else
-	let expanded = 
-		kludged
-#endif
+		(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded)
 
 	return 	( usAlloc
 		, expanded
@@ -418,12 +479,10 @@ cmmNativeGen dflags us cmm count
 		, ppr_raStatsLinear)
 
 
-#if i386_TARGET_ARCH
-x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
+x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
 x86fp_kludge top@(CmmData _ _) = top
 x86fp_kludge (CmmProc info lbl (ListGraph code)) = 
-	CmmProc info lbl (ListGraph $ i386_insert_ffrees code)
-#endif
+	CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
 
 
 -- | Build a doc for all the imports.
@@ -447,14 +506,12 @@ makeImportsDoc dflags imports
                 -- stack so add the note in:
             Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
 #endif
-#if !defined(darwin_TARGET_OS)
                 -- And just because every other compiler does, lets stick in
 		-- an identifier directive: .ident "GHC x.y.z"
-	    Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+            Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
 	                                  Pretty.text cProjectVersion
                        in Pretty.text ".ident" Pretty.<+>
                           Pretty.doubleQuotes compilerIdent
-#endif
 
  where
 	-- Generate "symbol stubs" for all external symbols that might
@@ -480,7 +537,7 @@ makeImportsDoc dflags imports
 		| otherwise
 		= Pretty.empty
 
-	doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+	doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
 	astyle = mkCodeStyle AsmStyle
 
 
@@ -494,12 +551,12 @@ makeImportsDoc dflags imports
 -- fallthroughs.
 
 sequenceTop 
-	:: NatCmmTop Instr
-	-> NatCmmTop Instr
+	:: Instruction instr
+    => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
 
-sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl (ListGraph blocks)) = 
-  CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop _       top@(CmmData _ _) = top
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = 
+  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -573,11 +630,9 @@ reorder id accum (b@(block,id',out) : rest)
 -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
 -- big, we have to work around this limitation.
 
-makeFarBranches 
-	:: [NatBasicBlock Instr] 
-	-> [NatBasicBlock Instr]
-
-#if powerpc_TARGET_ARCH
+makeFarBranches
+	:: [NatBasicBlock PPC.Instr.Instr] 
+	-> [NatBasicBlock PPC.Instr.Instr]
 makeFarBranches blocks
     | last blockAddresses < nearLimit = blocks
     | otherwise = zipWith handleBlock blockAddresses blocks
@@ -588,12 +643,12 @@ makeFarBranches blocks
         handleBlock addr (BasicBlock id instrs)
                 = BasicBlock id (zipWith makeFar [addr..] instrs)
         
-        makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
-        makeFar addr (BCC cond tgt)
+        makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
+        makeFar addr (PPC.Instr.BCC cond tgt)
             | abs (addr - targetAddr) >= nearLimit
-            = BCCFAR cond tgt
+            = PPC.Instr.BCCFAR cond tgt
             | otherwise
-            = BCC cond tgt
+            = PPC.Instr.BCC cond tgt
             where Just targetAddr = lookupUFM blockAddressMap tgt
         makeFar _ other            = other
         
@@ -604,31 +659,43 @@ makeFarBranches blocks
                          -- things exactly
         
         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
-#else
-makeFarBranches = id
-#endif
+
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+	:: NcgImpl instr jumpDest
+    -> [NatCmmTop instr] -> [NatCmmTop instr]
+generateJumpTables ncgImpl xs = concatMap f xs
+    where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+          f p = [p]
+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
 
 -- -----------------------------------------------------------------------------
 -- Shortcut branches
 
-shortcutBranches 
-	:: DynFlags 
-	-> [NatCmmTop Instr] 
-	-> [NatCmmTop Instr]
+shortcutBranches
+	:: DynFlags
+    -> NcgImpl instr jumpDest
+	-> [NatCmmTop instr] 
+	-> [NatCmmTop instr]
 
-shortcutBranches dflags tops
+shortcutBranches dflags ncgImpl tops
   | optLevel dflags < 1 = tops    -- only with -O or higher
-  | otherwise           = map (apply_mapping mapping) tops'
+  | otherwise           = map (apply_mapping ncgImpl mapping) tops'
   where
-    (tops', mappings) = mapAndUnzip build_mapping tops
+    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
     mapping = foldr plusUFM emptyUFM mappings
 
-build_mapping :: GenCmmTop d t (ListGraph Instr)
-              -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
-build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph []))
+build_mapping :: NcgImpl instr jumpDest
+              -> GenCmmTop d t (ListGraph instr)
+              -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
+build_mapping _ (CmmProc info lbl (ListGraph []))
   = (CmmProc info lbl (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
   = (CmmProc info lbl (ListGraph (head:others)), mapping)
         -- drop the shorted blocks, but don't ever drop the first one,
         -- because it is pointed to by a global label.
@@ -638,11 +705,12 @@ build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
     -- Don't completely eliminate loops here -- that can leave a dangling jump!
     (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
-        | Just (DestBlockId dest) <- canShortcut insn,
+        | Just jd <- canShortcut ncgImpl insn,
+          Just dest <- getJumpDestBlockId ncgImpl jd,
           (setMember dest s) || dest == id -- loop checks
         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
-        | Just dest <- canShortcut insn
+        | Just dest <- canShortcut ncgImpl insn
         = (setInsert id s, (id,dest) : shortcut_blocks, others)
     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
@@ -651,18 +719,19 @@ build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
     mapping = foldl add emptyUFM shortcut_blocks
     add ufm (id,dest) = addToUFM ufm id dest
     
-apply_mapping :: UniqFM JumpDest
-              -> GenCmmTop CmmStatic h (ListGraph Instr)
-              -> GenCmmTop CmmStatic h (ListGraph Instr)
-apply_mapping ufm (CmmData sec statics) 
-  = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
+apply_mapping :: NcgImpl instr jumpDest
+              -> UniqFM jumpDest
+              -> GenCmmTop CmmStatic h (ListGraph instr)
+              -> GenCmmTop CmmStatic h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+  = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics)
   -- we need to get the jump tables, so apply the mapping to the entries
   -- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
   = CmmProc info lbl (ListGraph $ map short_bb blocks)
   where
     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
-    short_insn i = shortcutJump (lookupUFM ufm) i
+    short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
                  -- shortcutJump should apply the mapping repeatedly,
                  -- just in case we can short multiple branches.
 
@@ -688,12 +757,13 @@ apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
 
 genMachCode 
 	:: DynFlags 
+        -> (DynFlags -> RawCmmTop -> NatM [NatCmmTop instr])
 	-> RawCmmTop 
 	-> UniqSM 
-		( [NatCmmTop Instr]
+		( [NatCmmTop instr]
 		, [CLabel])
 
-genMachCode dflags cmm_top
+genMachCode dflags cmmTopCodeGen cmm_top
   = do	{ initial_us <- getUs
 	; let initial_st           = mkNatM_State initial_us 0 dflags
 	      (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
@@ -718,10 +788,9 @@ Here we do:
              and position independent refs
         (ii) compile a list of imported symbols
 
-Ideas for other things we could do (ToDo):
+Ideas for other things we could do:
 
   - shortcut jumps-to-jumps
-  - eliminate dead code blocks
   - simple CSE: if an expr is assigned to a temp, then replace later occs of
     that expr with the temp, until the expr is no longer valid (can push through
     temp assignments, and certain assigns to mem...)
@@ -730,7 +799,7 @@ Ideas for other things we could do (ToDo):
 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-  blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
+  blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
   return $ CmmProc info lbl (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@ -807,8 +876,10 @@ cmmStmtConFold stmt
 
 
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
-   = case expr of
+cmmExprConFold referenceKind expr = do
+     dflags <- getDynFlagsCmmOpt
+     let arch = platformArch (targetPlatform dflags)
+     case expr of
         CmmLoad addr rep
            -> do addr' <- cmmExprConFold DataReference addr
                  return $ CmmLoad addr' rep
@@ -821,11 +892,9 @@ cmmExprConFold referenceKind expr
 
         CmmLit (CmmLabel lbl)
            -> do
-		dflags <- getDynFlagsCmmOpt
 		cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
            -> do
-		 dflags <- getDynFlagsCmmOpt
 		 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                  return $ cmmMachOpFold (MO_Add wordWidth) [
                      dynRef,
@@ -836,15 +905,15 @@ cmmExprConFold referenceKind expr
         -- to use the register table, so we replace these registers
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
-          | cTargetArch == PPC && not opt_PIC
+          | arch == ArchPPC && not opt_PIC
           -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
 
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 29b9a54..c96badd 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -15,6 +15,7 @@
 
 module PPC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -798,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl))
 genJump tree
   = do
         (target,code) <- getSomeReg tree
-        return (code `snocOL` MTCTR target `snocOL` BCTR [])
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
 
 
 -- -----------------------------------------------------------------------------
@@ -1126,22 +1127,12 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just blockid)
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel (getUnique blockid)
-
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` t_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             LD II32 tmp (AddrRegReg tableReg tmp),
                             ADD tmp tmp (RIReg tableReg),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
   | otherwise
@@ -1149,19 +1140,27 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         tmp <- getNewRegNat II32
         lbl <- getNewLabelNat
-        let
-            jumpTable = map jumpTableEntry ids
-        
-            code = e_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
                             LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+    let jumpTable
+            | opt_PIC   = map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                            where blockLabel = mkAsmTempLabel (getUnique blockid)
+    in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 6aeccd3..0288f1b 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -104,7 +104,7 @@ data Instr
 	| JMP     CLabel          	-- same as branch,
                                         -- but with CLabel instead of block ID
 	| MTCTR	Reg
-	| BCTR    [BlockId]       	-- with list of local destinations
+	| BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
 	| BL	CLabel [Reg]		-- with list of argument regs
 	| BCTRL	[Reg]
 	      
@@ -184,7 +184,7 @@ ppc_regUsageOfInstr instr
     BCC	   _ _		-> noUsage
     BCCFAR _ _		-> noUsage
     MTCTR reg		-> usage ([reg],[])
-    BCTR  _		-> noUsage
+    BCTR  _ _		-> noUsage
     BL    _ params	-> usage (params, callClobberedRegs)
     BCTRL params	-> usage (params, callClobberedRegs)
     ADD	  reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
@@ -257,7 +257,7 @@ ppc_patchRegsOfInstr instr env
     BCC	  cond lbl	-> BCC cond lbl
     BCCFAR cond lbl	-> BCCFAR cond lbl
     MTCTR reg		-> MTCTR (env reg)
-    BCTR  targets	-> BCTR targets
+    BCTR  targets lbl	-> BCTR targets lbl
     BL    imm argRegs	-> BL imm argRegs	-- argument regs
     BCTRL argRegs	-> BCTRL argRegs 	-- cannot be remapped
     ADD	  reg1 reg2 ri	-> ADD (env reg1) (env reg2) (fixRI ri)
@@ -326,7 +326,7 @@ ppc_jumpDestsOfInstr insn
   = case insn of
         BCC _ id        -> [id]
         BCCFAR _ id     -> [id]
-        BCTR targets    -> targets
+        BCTR targets _  -> [id | Just id <- targets]
 	_		-> []
 	
 	
@@ -338,7 +338,7 @@ ppc_patchJumpInstr insn patchF
   = case insn of
         BCC cc id 	-> BCC cc (patchF id)
         BCCFAR cc id 	-> BCCFAR cc (patchF id)
-        BCTR _	 	-> error "Cannot patch BCTR"
+        BCTR ids lbl	-> BCTR (map (fmap patchF) ids) lbl
 	_		-> insn
 
 
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 9fb86c0..8d8b16a 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -12,7 +12,6 @@ module PPC.Ppr (
 	pprSectionHeader,
 	pprData,
 	pprInstr,
-	pprUserReg,
 	pprSize,
 	pprImm,
 	pprDataItem,
@@ -157,9 +156,6 @@ instance Outputable Instr where
     ppr	 instr	= Outputable.docToSDoc $ pprInstr instr
 
 
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
 pprReg :: Reg -> Doc
 
 pprReg r
@@ -545,7 +541,7 @@ pprInstr (MTCTR reg) = hcat [
 	char '\t',
 	pprReg reg
     ]
-pprInstr (BCTR _) = hcat [
+pprInstr (BCTR _ _) = hcat [
 	char '\t',
 	ptext (sLit "bctr")
     ]
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index 91c9e15..bfc712a 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -7,7 +7,7 @@
 -----------------------------------------------------------------------------
 
 module PPC.RegInfo (
-        JumpDest( DestBlockId ), 
+        JumpDest( DestBlockId ), getJumpDestBlockId,
 	canShortcut, 
 	shortcutJump, 
 
@@ -31,6 +31,10 @@ import Unique
 
 data JumpDest = DestBlockId BlockId | DestImm Imm
 
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
 canShortcut :: Instr -> Maybe JumpDest
 canShortcut _ = Nothing
 
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index 73e0c20..7a2a84b 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -209,7 +209,6 @@ spRel n	= AddrRegImm sp (ImmInt (n * wORD_SIZE))
 -- argRegs is the set of regs which are read for an n-argument call to C.
 -- For archs which pass all args on the stack (x86), is empty.
 -- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
 argRegs :: RegNo -> [Reg]
 argRegs 0 = []
 argRegs 1 = map regSingle [3]
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 903082f..ef6ae9b 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -190,7 +190,7 @@ joinToTargets_again
 		 _	-> let	instr'	=  patchJumpInstr instr 
 		 				(\bid -> if bid == dest 
 								then mkBlockId fixup_block_id 
-								else dest)
+								else bid) -- no change!
 						
 		 	   in	joinToTargets' block_live (block : new_blocks) block_id instr' dests
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index d08d10d..beb48d6 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -8,6 +8,7 @@
 
 module SPARC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -299,15 +300,11 @@ genSwitch expr ids
 		dst		<- getNewRegNat II32
 
 		label 		<- getNewLabelNat
-		let jumpTable	= map jumpTableEntry ids
 
 		return $ e_code `appOL`
 		 toOL	
-		 	-- the jump table
-			[ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
-			-- load base of jump table
-			, SETHI (HI (ImmCLbl label)) base_reg
+			[ -- load base of jump table
+			  SETHI (HI (ImmCLbl label)) base_reg
 			, OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
 			
 			-- the addrs in the table are 32 bits wide..
@@ -315,6 +312,11 @@ genSwitch expr ids
 
 			-- load and jump to the destination
 			, LD 	  II32 (AddrRegReg base_reg offset_reg) dst
-			, JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+			, JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
 			, NOP ]
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+	let jumpTable = map jumpTableEntry ids
+	in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 79b4629..93f4d27 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -37,6 +37,7 @@ import RegClass
 import Reg
 import Size
 
+import CLabel
 import BlockId
 import OldCmm
 import FastString
@@ -194,7 +195,7 @@ data Instr
 	-- With a tabled jump we know all the possible destinations.
 	-- We also need this info so we can work out what regs are live across the jump.
 	-- 
-	| JMP_TBL	AddrMode [BlockId]
+	| JMP_TBL	AddrMode [Maybe BlockId] CLabel
 
 	| CALL		(Either Imm Reg) Int Bool 	-- target, args, terminal
 
@@ -247,7 +248,7 @@ sparc_regUsageOfInstr instr
     FxTOy   _ _  r1 r2 		-> usage ([r1], 		[r2])
 
     JMP     addr 		-> usage (regAddr addr, [])
-    JMP_TBL addr _      	-> usage (regAddr addr, [])
+    JMP_TBL addr _ _    	-> usage (regAddr addr, [])
 
     CALL  (Left _  )  _ True  	-> noUsage
     CALL  (Left _  )  n False 	-> usage (argRegs n, callClobberedRegs)
@@ -315,7 +316,7 @@ sparc_patchRegsOfInstr instr env = case instr of
     FxTOy s1 s2 r1 r2   	-> FxTOy s1 s2 (env r1) (env r2)
 
     JMP     addr        	-> JMP     (fixAddr addr)
-    JMP_TBL addr ids    	-> JMP_TBL (fixAddr addr) ids
+    JMP_TBL addr ids l  	-> JMP_TBL (fixAddr addr) ids l
 
     CALL  (Left i) n t  	-> CALL (Left i) n t
     CALL  (Right r) n t 	-> CALL (Right (env r)) n t
@@ -345,7 +346,7 @@ sparc_jumpDestsOfInstr insn
   = case insn of
 	BI   _ _ id	-> [id]
 	BF   _ _ id	-> [id]
-	JMP_TBL _ ids	-> ids
+	JMP_TBL _ ids _	-> [id | Just id <- ids]
 	_		-> []
 
 
@@ -354,6 +355,7 @@ sparc_patchJumpInstr insn patchF
   = case insn of
 	BI cc annul id	-> BI cc annul (patchF id)
 	BF cc annul id	-> BF cc annul (patchF id)
+	JMP_TBL n ids l	-> JMP_TBL n (map (fmap patchF) ids) l
 	_		-> insn
 
 
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index a63661f..c5a3314 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -12,7 +12,6 @@ module SPARC.Ppr (
 	pprSectionHeader,
 	pprData,
 	pprInstr,
-	pprUserReg,
 	pprSize,
 	pprImm,
 	pprDataItem
@@ -141,12 +140,6 @@ instance Outputable Instr where
 
 
 -- | Pretty print a register.
---	This is an alias of pprReg for legacy reasons, should remove it.
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
-
--- | Pretty print a register.
 pprReg :: Reg -> Doc
 pprReg reg
  = case reg of
@@ -543,7 +536,7 @@ pprInstr (BF cond b blockid)
     ]
 
 pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
-pprInstr (JMP_TBL op _)  = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)
 
 pprInstr (CALL (Left imm) n _)
   = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
index c0c3343..30e48bb 100644
--- a/compiler/nativeGen/SPARC/ShortcutJump.hs
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -1,6 +1,6 @@
 
 module SPARC.ShortcutJump (
-	JumpDest(..),
+	JumpDest(..), getJumpDestBlockId,
 	canShortcut,
 	shortcutJump,
 	shortcutStatic,
@@ -25,6 +25,10 @@ data JumpDest
 	= DestBlockId BlockId 
 	| DestImm Imm
 
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
 
 canShortcut :: Instr -> Maybe JumpDest
 canShortcut _ = Nothing
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 5df8f77..a6cc36f 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -20,6 +20,7 @@
 
 module X86.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -1932,16 +1933,7 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just blockid)
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel (getUnique blockid)
-
-            op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
                                        (EAIndex reg wORD_SIZE) (ImmInt 0))
 
 #if x86_64_TARGET_ARCH
@@ -1954,8 +1946,7 @@ genSwitch expr ids
     
             code = e_code `appOL` t_code `appOL` toOL [
                             ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
-                            LDATA Text (CmmDataLabel lbl : jumpTable)
+                            JMP_TBL (OpReg tableReg) ids Text lbl
                     ]
 #else
     -- HACK: On x86_64 binutils<2.17 is only able to generate PC32
@@ -1965,20 +1956,18 @@ genSwitch expr ids
     -- conjunction with the hack in PprMach.hs/pprDataItem once
     -- binutils 2.17 is standard.
             code = e_code `appOL` t_code `appOL` toOL [
-			    LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
 			    MOVSxL II32
 				   (OpAddr (AddrBaseIndex (EABaseReg tableReg)
 							  (EAIndex reg wORD_SIZE) (ImmInt 0)))
 				   (OpReg reg),
 			    ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
-			    JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+			    JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
 		   ]
 #endif
 #else
             code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
                             ADD (intSize wordWidth) op (OpReg tableReg),
-                            JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+                            JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
                     ]
 #endif
         return code
@@ -1987,15 +1976,28 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         lbl <- getNewLabelNat
         let
-            jumpTable = map jumpTableEntry ids
             op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
             code = e_code `appOL` toOL [
-                    LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
-                    JMP_TBL op [ id | Just id <- ids ]
+                    JMP_TBL op ids ReadOnlyData lbl
                  ]
         -- in
         return code
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
+generateJumpTableForInstr _ = Nothing
+
+createJumpTable ids section lbl
+    = let jumpTable
+            | opt_PIC =
+                  let jumpTableEntryRel Nothing
+                          = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                          where blockLabel = mkAsmTempLabel (getUnique blockid)
+                  in map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+      in CmmData section (CmmDataLabel lbl : jumpTable)
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index a96452b..b9c851a 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -289,7 +289,11 @@ data Instr
 	| JMP	      Operand
 	| JXX	      Cond BlockId  -- includes unconditional branches
 	| JXX_GBL     Cond Imm      -- non-local version of JXX
-	| JMP_TBL     Operand [BlockId]  -- table jump
+	-- Table jump
+	| JMP_TBL     Operand   -- Address to jump to
+	              [Maybe BlockId] -- Blocks in the jump table
+	              Section   -- Data section jump table should be put in
+	              CLabel    -- Label of jump table
 	| CALL	      (Either Imm Reg) [Reg]
 
 	-- Other things.
@@ -350,7 +354,7 @@ x86_regUsageOfInstr instr
     JXX    _ _		-> mkRU [] []
     JXX_GBL _ _		-> mkRU [] []
     JMP     op		-> mkRUR (use_R op)
-    JMP_TBL op _        -> mkRUR (use_R op)
+    JMP_TBL op _ _ _    -> mkRUR (use_R op)
     CALL (Left _)  params   -> mkRU params callClobberedRegs
     CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
     CLTD   _		-> mkRU [eax] [edx]
@@ -482,7 +486,7 @@ x86_patchRegsOfInstr instr env
     POP  sz op		-> patch1 (POP  sz) op
     SETCC cond op	-> patch1 (SETCC cond) op
     JMP op		-> patch1 JMP op
-    JMP_TBL op ids      -> patch1 JMP_TBL op $ ids
+    JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl
 
     GMOV src dst	-> GMOV (env src) (env dst)
     GLD  sz src dst	-> GLD sz (lookupAddr src) (env dst)
@@ -579,7 +583,7 @@ x86_jumpDestsOfInstr
 x86_jumpDestsOfInstr insn 
   = case insn of
 	JXX _ id	-> [id]
-	JMP_TBL _ ids	-> ids
+	JMP_TBL _ ids _ _ -> [id | Just id <- ids]
 	_		-> []
 
 
@@ -589,7 +593,8 @@ x86_patchJumpInstr
 x86_patchJumpInstr insn patchF
   = case insn of
 	JXX cc id 	-> JXX cc (patchF id)
-	JMP_TBL _ _     -> error "Cannot patch JMP_TBL"
+	JMP_TBL op ids section lbl
+	  -> JMP_TBL op (map (fmap patchF) ids) section lbl
 	_		-> insn
 
 
@@ -741,7 +746,7 @@ i386_insert_ffrees blocks
      where p insn r = case insn of
                         CALL _ _ -> GFREE : insn : r
                         JMP _    -> GFREE : insn : r
-                        JXX_GBL _ _ -> GFREE : insn : r
+                        JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL"
                         _        -> insn : r
 
 -- if you ever add a new FP insn to the fake x86 FP insn set,
@@ -776,6 +781,9 @@ is_G_instr instr
 
 data JumpDest = DestBlockId BlockId | DestImm Imm
 
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
 
 canShortcut :: Instr -> Maybe JumpDest
 canShortcut (JXX ALWAYS id)    = Just (DestBlockId id)
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 5fe78e1..38b6344 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -12,7 +12,6 @@ module X86.Ppr (
         pprSectionHeader,
         pprData,
         pprInstr,
-        pprUserReg,
         pprSize,
         pprImm,
         pprDataItem,
@@ -34,7 +33,6 @@ import PprBase
 
 import OldCmm
 import CLabel
-import Config
 import Unique           ( pprUnique, Uniquable(..) )
 import Pretty
 import FastString
@@ -42,7 +40,6 @@ import qualified Outputable
 import Outputable       (panic, Outputable)
 
 import Data.Word
-import Distribution.System
 
 #if i386_TARGET_ARCH && darwin_TARGET_OS
 import Data.Bits
@@ -87,7 +84,17 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
                       <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
                     else empty
 #endif
+   $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
 
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> Doc
+#if elf_OBJ_FORMAT
+pprSizeDecl lbl =
+    ptext (sLit "\t.size") <+> pprCLabel_asm lbl
+    <> ptext (sLit ", .-") <> pprCLabel_asm lbl
+#else
+pprSizeDecl _ = empty
+#endif
 
 pprBasicBlock :: NatBasicBlock Instr -> Doc
 pprBasicBlock (BasicBlock blockid instrs) =
@@ -162,12 +169,6 @@ instance Outputable Instr where
     ppr instr = Outputable.docToSDoc $ pprInstr instr
 
 
-pprUserReg :: Reg -> Doc
-pprUserReg
- | cTargetArch == I386   = pprReg II32
- | cTargetArch == X86_64 = pprReg II64
- | otherwise             = panic "X86.Ppr.pprUserReg: not defined"
-
 pprReg :: Size -> Reg -> Doc
 
 pprReg s r
@@ -626,7 +627,7 @@ pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
 
 pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
 pprInstr (JMP op)          = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
-pprInstr (JMP_TBL op _)  = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op)
 pprInstr (CALL (Left imm) _)    = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
 pprInstr (CALL (Right reg) _)   = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
 
@@ -641,8 +642,8 @@ pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2
 
 pprInstr (CVTSS2SD from to)      = pprRegReg (sLit "cvtss2sd") from to
 pprInstr (CVTSD2SS from to)      = pprRegReg (sLit "cvtsd2ss") from to
-pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
-pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
+pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to
+pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to
 pprInstr (CVTSI2SS sz from to)   = pprSizeOpReg (sLit "cvtsi2ss") sz from to
 pprInstr (CVTSI2SD sz from to)   = pprSizeOpReg (sLit "cvtsi2sd") sz from to
 
@@ -1093,7 +1094,6 @@ pprSizeOpReg name size op1 reg2
         pprReg archWordSize reg2
     ]
 
-
 pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
 pprCondRegReg name size cond reg1 reg2
   = hcat [
@@ -1115,11 +1115,18 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2
         pprSize size2,
         space,
         pprReg size1 reg1,
-
         comma,
         pprReg size2 reg2
     ]
 
+pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc
+pprSizeSizeOpReg name size1 size2 op1 reg2
+  = hcat [
+        pprMnemonic name size2,
+        pprOperand size1 op1,
+        comma,
+        pprReg size2 reg2
+    ]
 
 pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
 pprSizeRegRegReg name size reg1 reg2 reg3
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 094b74d..28d148c 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -249,7 +249,6 @@ floatregnos = fakeregnos ++ xmmregnos;
 -- argRegs is the set of regs which are read for an n-argument call to C.
 -- For archs which pass all args on the stack (x86), is empty.
 -- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
 argRegs :: RegNo -> [Reg]
 argRegs _	= panic "MachRegs.argRegs(x86): should not be used!"
 
@@ -333,10 +332,24 @@ fake5 = regSingle 21
 
 {-
 AMD x86_64 architecture:
-- Registers 0-16 have 32-bit counterparts (eax, ebx etc.)
-- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
-- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-
+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
+
+  8     16    32    64
+  ---------------------
+  al    ax    eax   rax
+  bl    bx    ebx   rbx
+  cl    cx    ecx   rcx
+  dl    dx    edx   rdx
+  sil   si    esi   rsi
+  dil   si    edi   rdi
+  bpl   bp    ebp   rbp
+  spl   sp    esp   rsp
+  r10b  r10w  r10d  r10
+  r11b  r11w  r11d  r11
+  r12b  r12w  r12d  r12
+  r13b  r13w  r13d  r13
+  r14b  r14w  r14d  r14
+  r15b  r15w  r15d  r15
 -}
 
 rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, 
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index d6b2322..4ca0282 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -69,7 +69,7 @@ import UniqFM
 import DynFlags
 import Module
 import Ctype
-import BasicTypes	( InlineSpec(..), RuleMatchInfo(..) )
+import BasicTypes	( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
 import Util		( readRational )
 
 import Control.Monad
@@ -345,11 +345,6 @@ $tab+         { warn Opt_WarnTabs (text "Warning: Tab character") }
          { token ITcubxparen }
 }
 
-<0> {
-  "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
-  "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
-}
-
 <0,option_prags> {
   \(					{ special IToparen }
   \)					{ special ITcparen }
@@ -551,14 +546,14 @@ data Token
   | ITchar       Char
   | ITstring     FastString
   | ITinteger    Integer
-  | ITrational   Rational
+  | ITrational   FractionalLit
 
   | ITprimchar   Char
   | ITprimstring FastString
   | ITprimint    Integer
   | ITprimword   Integer
-  | ITprimfloat  Rational
-  | ITprimdouble Rational
+  | ITprimfloat  FractionalLit
+  | ITprimdouble FractionalLit
 
   -- Template Haskell extension tokens
   | ITopenExpQuote  		--  [| or [e|
@@ -1078,9 +1073,12 @@ hexadecimal = (16,hexDigit)
 
 -- readRational can understand negative rationals, exponents, everything.
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float        str = ITrational   $! readRational str
-tok_primfloat    str = ITprimfloat  $! readRational str
-tok_primdouble   str = ITprimdouble $! readRational str
+tok_float        str = ITrational   $! readFractionalLit str
+tok_primfloat    str = ITprimfloat  $! readFractionalLit str
+tok_primdouble   str = ITprimdouble $! readFractionalLit str
+
+readFractionalLit :: String -> FractionalLit
+readFractionalLit str = (FL $! str) $! readRational str
 
 -- -----------------------------------------------------------------------------
 -- Layout processing
@@ -1776,8 +1774,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
 -- integer
 
-genericsBit :: Int
-genericsBit = 0 -- {| and |}
+-- The "genericsBit" is now unused, available for others
+-- genericsBit :: Int
+-- genericsBit = 0 -- {|, |} and "generic"
+
 ffiBit :: Int
 ffiBit	   = 1
 parrBit :: Int
@@ -1830,8 +1830,6 @@ hetMetBit = 31
 
 always :: Int -> Bool
 always           _     = True
-genericsEnabled :: Int -> Bool
-genericsEnabled  flags = testBit flags genericsBit
 parrEnabled :: Int -> Bool
 parrEnabled      flags = testBit flags parrBit
 arrowsEnabled :: Int -> Bool
@@ -1885,7 +1883,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
 mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
 mkPState flags buf loc =
   PState {
-      buffer	      = buf,
+      buffer        = buf,
       dflags        = flags,
       messages      = emptyMessages,
       last_loc      = mkSrcSpan loc loc,
@@ -1903,35 +1901,35 @@ mkPState flags buf loc =
       code_type_bracket_depth = 0
     }
     where
-      bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
-	       .|. ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
-	       .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
-	       .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
-	       .|. hetMetBit        `setBitIf` xopt Opt_ModalTypes         flags
-	       .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
-	       .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes	 flags
-	       .|. ipBit             `setBitIf` xopt Opt_ImplicitParams	 flags
-	       .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
-	       .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns flags
-	       .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies flags
-	       .|. haddockBit        `setBitIf` dopt Opt_Haddock      flags
-	       .|. magicHashBit      `setBitIf` xopt Opt_MagicHash    flags
-	       .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures flags
-	       .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo flags
-	       .|. recBit 	     `setBitIf` xopt Opt_DoRec  flags
-	       .|. recBit 	     `setBitIf` xopt Opt_Arrows flags
-	       .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax flags
-	       .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples flags
+      bitmap =     ffiBit            `setBitIf` xopt Opt_ForeignFunctionInterface flags
+               .|. parrBit           `setBitIf` xopt Opt_ParallelArrays  flags
+               .|. arrowsBit         `setBitIf` xopt Opt_Arrows          flags
+	       .|. hetMetBit         `setBitIf` xopt Opt_ModalTypes      flags
+               .|. thBit             `setBitIf` xopt Opt_TemplateHaskell flags
+               .|. qqBit             `setBitIf` xopt Opt_QuasiQuotes     flags
+               .|. ipBit             `setBitIf` xopt Opt_ImplicitParams  flags
+               .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll  flags
+               .|. bangPatBit        `setBitIf` xopt Opt_BangPatterns    flags
+               .|. tyFamBit          `setBitIf` xopt Opt_TypeFamilies    flags
+               .|. haddockBit        `setBitIf` dopt Opt_Haddock         flags
+               .|. magicHashBit      `setBitIf` xopt Opt_MagicHash       flags
+               .|. kindSigsBit       `setBitIf` xopt Opt_KindSignatures  flags
+               .|. recursiveDoBit    `setBitIf` xopt Opt_RecursiveDo     flags
+               .|. recBit            `setBitIf` xopt Opt_DoRec           flags
+               .|. recBit            `setBitIf` xopt Opt_Arrows          flags
+               .|. unicodeSyntaxBit  `setBitIf` xopt Opt_UnicodeSyntax   flags
+               .|. unboxedTuplesBit  `setBitIf` xopt Opt_UnboxedTuples   flags
                .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
                .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
+               .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
                .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
                .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
-               .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+               .|. relaxedLayoutBit  `setBitIf` xopt Opt_RelaxedLayout flags
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
-			| otherwise = 0
+                        | otherwise = 0
 
 addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 26bb4e7..a71323f 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -726,6 +726,11 @@ decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
 decl_cls  : at_decl_cls		        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
 	  | decl                        { $1 }
 
+	  -- A 'default' signature used with the generic-programming extension
+          | 'default' infixexp '::' sigtypedoc
+                    {% do { (TypeSig l ty) <- checkValSig $2 $4
+                          ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
 decls_cls :: { Located (OrdList (LHsDecl RdrName)) }	-- Reversed
 	  : decls_cls ';' decl_cls	{ LL (unLoc $1 `appOL` unLoc $3) }
 	  | decls_cls ';'		{ LL (unLoc $1) }
@@ -1028,8 +1033,6 @@ atype :: { LHsType RdrName }
 	| '$(' exp ')'	      		{ LL $ mkHsSpliceTy $2 }
 	| TH_ID_SPLICE	      		{ LL $ mkHsSpliceTy $ L1 $ HsVar $ 
 					  mkUnqual varName (getTH_ID_SPLICE $1) }
--- Generics
-        | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
 
 -- An inst_type is what occurs in the head of an instance decl
 --	e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1239,10 +1242,11 @@ gdrh :: { LGRHS RdrName }
 	: '|' guardquals '=' exp  	{ sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-	: infixexp '::' sigtypedoc	{% do s <- checkValSig $1 $3 
-				         ; return (LL $ unitOL (LL $ SigD s)) }
-		-- See Note [Declaration/signature overlap] for why we need infixexp here
-
+        : 
+	-- See Note [Declaration/signature overlap] for why we need infixexp here
+	  infixexp '::' sigtypedoc
+                        {% do s <- checkValSig $1 $3 
+                        ; return (LL $ unitOL (LL $ SigD s)) }
 	| var ',' sig_vars '::' sigtypedoc
 				{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
 	| infix prec ops	{ LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
@@ -1296,14 +1300,9 @@ exp10 :: { LHsExpr RdrName }
    	| 'case' exp 'of' altslist		{ LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
 	| '-' fexp				{ LL $ NegApp $2 noSyntaxExpr }
 
-  	| 'do' stmtlist			{% let loc = comb2 $1 $2 in
-					   checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-					   return (L loc (mkHsDo DoExpr stmts body)) }
-  	| 'mdo' stmtlist		{% let loc = comb2 $1 $2 in
-					   checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-                                           return (L loc (mkHsDo MDoExpr
-                                                                 [L loc (mkRecStmt stmts)]
-                                                                 body)) }
+  	| 'do' stmtlist			{ L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }
+  	| 'mdo' stmtlist		{ L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
         | scc_annot exp		    		{ LL $ if opt_SccProfilingOn
 							then HsSCC (unLoc $1) $2
 							else HsPar $2 }
@@ -1483,7 +1482,10 @@ list :: { LHsExpr RdrName }
 	| texp ',' exp '..' 	{ LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
 	| texp '..' exp	 	{ LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
 	| texp ',' exp '..' exp	{ LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-	| texp '|' flattenedpquals	{ sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
+	| texp '|' flattenedpquals	
+             {% checkMonadComp >>= \ ctxt ->
+		return (sL (comb2 $1 $>) $ 
+                        mkHsComp ctxt (unLoc $3) $1) }
 
 lexps :: { Located [LHsExpr RdrName] }
 	: lexps ',' texp 		{ LL (((:) $! $3) $! unLoc $1) }
@@ -1498,7 +1500,7 @@ flattenedpquals :: { Located [LStmt RdrName] }
                     -- We just had one thing in our "parallel" list so 
                     -- we simply return that thing directly
                     
-                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
                 }
@@ -1519,8 +1521,7 @@ squals :: { Located [LStmt RdrName] }	-- In reverse order, because the last
 
 -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
 -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
 
 transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
 			-- Function is applied to a list of stmts *in order*
@@ -1555,7 +1556,7 @@ parr :: { LHsExpr RdrName }
 						       (reverse (unLoc $1)) }
 	| texp '..' exp	 		{ LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
 	| texp ',' exp '..' exp		{ LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-	| texp '|' flattenedpquals	{ LL $ mkHsDo PArrComp (unLoc $3) $1 }
+	| texp '|' flattenedpquals	{ LL $ mkHsComp PArrComp (unLoc $3) $1 }
 
 -- We are reusing `lexps' and `flattenedpquals' from the list case.
 
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 8bf9453..3f2b32a 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -269,7 +269,7 @@ exp	:: { IfaceExpr }
 	| '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
 -- gaw 2004
 	| '%case' '(' ty ')' aexp '%of' id_bndr
-	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $3 $9 }
+	  '{' alts1 '}'		      { IfaceCase $5 (fst $7) $9 }
         | '%cast' aexp aty { IfaceCast $2 $3 }
 -- No InlineMe any more
 -- 	| '%note' STRING exp 	   
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 49036d9..0e265e9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -40,8 +40,7 @@ module RdrHsSyn (
 	checkPattern,	      -- HsExp -> P HsPat
 	bang_RDR,
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
-	checkDo,	      -- [Stmt] -> P [Stmt]
-	checkMDo,	      -- [Stmt] -> P [Stmt]
+	checkMonadComp,       -- P (HsStmtContext RdrName)
 	checkValDef,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	checkValSig,	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	checkDoAndIfThenElse,
@@ -54,6 +53,7 @@ import Class            ( FunDep )
 import TypeRep          ( Kind )
 import RdrName		( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
 			  isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
+import Name             ( Name )
 import BasicTypes	( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import Lexer
@@ -128,7 +128,6 @@ extract_lty (L loc ty) acc
       HsPredTy p		-> extract_pred p acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty               	-> extract_lty ty acc
-      HsNumTy {}                -> acc
       HsCoreTy {}               -> acc  -- The type is closed
       HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
@@ -153,8 +152,7 @@ extractGenericPatTyVars binds
     get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
     get _                                                 acc = acc
 
-    get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
-    get_m _                                        acc = acc
+    get_m _ acc = acc
 \end{code}
 
 
@@ -612,34 +610,6 @@ checkPred (L spn ty)
     check loc _                        _    = parseErrorSDoc loc
                                 (text "malformed class assertion:" <+> ppr ty)
 
----------------------------------------------------------------------------
--- Checking statements in a do-expression
--- 	We parse   do { e1 ; e2 ; }
--- 	as [ExprStmt e1, ExprStmt e2]
--- checkDo (a) checks that the last thing is an ExprStmt
---	   (b) returns it separately
--- same comments apply for mdo as well
-
-checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-
-checkDo	 = checkDoMDo "a " "'do'"
-checkMDo = checkDoMDo "an " "'mdo'"
-
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo _   nm loc []   = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
-checkDoMDo pre nm _   ss   = do
-  check ss
-  where 
-	check  []                     = panic "RdrHsSyn:checkDoMDo"
-	check  [L _ (ExprStmt e _ _)] = return ([], e)
-	check  [L l e] = parseErrorSDoc l
-                         (text ("The last statement in " ++ pre ++ nm ++
-					            " construct must be an expression:")
-                       $$ ppr e)
-	check (s:ss) = do
-	  (ss',e') <-  check ss
-	  return ((s:ss'),e')
-
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
 
@@ -734,8 +704,6 @@ checkAPat dynflags loc e0 = case e0 of
                       -> do fs <- mapM checkPatField fs
                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
--- Generics 
-   HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc e0
 
 placeHolderPunRhs :: LHsExpr RdrName
@@ -816,17 +784,20 @@ checkValSig lhs@(L l _) ty
                        ppr lhs <+> text "::" <+> ppr ty)
                    $$ text hint)
   where
-    hint = if looks_like_foreign lhs
+    hint = if foreign_RDR `looks_like` lhs
            then "Perhaps you meant to use -XForeignFunctionInterface?"
-           else "Should be of form <variable> :: <type>"
+           else if default_RDR `looks_like` lhs
+                then "Perhaps you meant to use -XDefaultSignatures?"
+                else "Should be of form <variable> :: <type>"
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
-    looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
-    looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
-    looks_like_foreign _                   = False
+    looks_like s (L _ (HsVar v))     = v == s
+    looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
+    looks_like _ _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
+    default_RDR = mkUnqual varName (fsLit "default")
 
 checkDoAndIfThenElse :: LHsExpr RdrName
                      -> Bool
@@ -916,6 +887,20 @@ isFunLhs e = go e []
 		 _ -> return Nothing }
    go _ _ = return Nothing
 
+
+---------------------------------------------------------------------------
+-- Check for monad comprehensions
+--
+-- If the flag MonadComprehensions is set, return a `MonadComp' context,
+-- otherwise use the usual `ListComp' context
+
+checkMonadComp :: P (HsStmtContext Name)
+checkMonadComp = do
+    pState <- getPState
+    return $ if xopt Opt_MonadComprehensions (dflags pState)
+                then MonadComp
+                else ListComp
+
 ---------------------------------------------------------------------------
 -- Miscellaneous utilities
 
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index a92cabd..87bb94a 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,7 +13,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (
-	ForeignCall(..),
+        ForeignCall(..), isSafeForeignCall,
 	Safety(..), playSafe, playInterruptible,
 
 	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
   deriving Eq
   {-! derive: Binary !-}
 
+isSafeForeignCall :: ForeignCall -> Bool
+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
+
 -- We may need more clues to distinguish foreign calls
 -- but this simple printer will do for now
 instance Outputable ForeignCall where
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 76ce5ce..aa5de15 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey
 %*                                                                      *
 %************************************************************************
 
-This section tells what the compiler knows about the assocation of
+This section tells what the compiler knows about the association of
 names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
 
@@ -160,6 +160,7 @@ basicKnownKeyNames
 	-- Monad stuff
 	thenIOName, bindIOName, returnIOName, failIOName,
 	failMName, bindMName, thenMName, returnMName,
+        fmapName,
 
 	-- MonadRec stuff
 	mfixName,
@@ -247,10 +248,27 @@ basicKnownKeyNames
 	-- dotnet interop
 	, objectTyConName, marshalObjectName, unmarshalObjectName
 	, marshalStringName, unmarshalStringName, checkDotnetResName
+	
+	-- Generics
+	, genClassName, gen1ClassName
+	, datatypeClassName, constructorClassName, selectorClassName
+	
+        -- Monad comprehensions
+        , guardMName
+        , liftMName
+        , groupMName
+        , mzipName
     ]
 
 genericTyConNames :: [Name]
-genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
+genericTyConNames = [
+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+    compTyConName, rTyConName, pTyConName, dTyConName,
+    cTyConName, sTyConName, rec0TyConName, par0TyConName,
+    d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+    repTyConName, rep1TyConName
+  ]
 
 -- Know names from the DPH package which vary depending on the selected DPH backend.
 --
@@ -282,7 +300,7 @@ pRELUDE		= mkBaseModule_ pRELUDE_NAME
 
 gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
     gHC_MAGIC,
-    gHC_CLASSES, gHC_BASE, gHC_ENUM,
+    gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
     gHC_HETMET_CODETYPES,
     gHC_HETMET_PRIVATE,
@@ -291,8 +309,9 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
     gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
-    dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE,
-    gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module
+    dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
+    aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
+    cONTROL_EXCEPTION_BASE :: Module
 
 gHC_PRIM	= mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
@@ -300,6 +319,7 @@ gHC_UNIT	= mkPrimModule (fsLit "GHC.Unit")
 gHC_ORDERING	= mkPrimModule (fsLit "GHC.Ordering")
 gHC_GENERICS	= mkPrimModule (fsLit "GHC.Generics")
 gHC_MAGIC	= mkPrimModule (fsLit "GHC.Magic")
+gHC_CSTRING	= mkPrimModule (fsLit "GHC.CString")
 
 gHC_CLASSES	= mkBaseModule (fsLit "GHC.Classes")
 gHC_BASE	= mkBaseModule (fsLit "GHC.Base")
@@ -343,6 +363,8 @@ gHC_INT		= mkBaseModule (fsLit "GHC.Int")
 gHC_WORD	= mkBaseModule (fsLit "GHC.Word")
 mONAD		= mkBaseModule (fsLit "Control.Monad")
 mONAD_FIX	= mkBaseModule (fsLit "Control.Monad.Fix")
+mONAD_GROUP     = mkBaseModule (fsLit "Control.Monad.Group")
+mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip")
 aRROW		= mkBaseModule (fsLit "Control.Arrow")
 cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
 gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
@@ -557,12 +579,59 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
 undefined_RDR :: RdrName
 undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
 
+error_RDR :: RdrName
+error_RDR = varQual_RDR gHC_ERR (fsLit "error")
+
+-- Old Generics (constructors and functions)
 crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
 crossDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")
 inlDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Inl")
 inrDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Inr")
 genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit")
 
+-- Generics (constructors and functions)
+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
+  prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR,
+  to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
+  conFixity_RDR, conIsRecord_RDR,
+  noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
+  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
+  rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+
+u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")
+par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")
+rec1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Rec1")
+k1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "K1")
+m1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "M1")
+
+l1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "L1")
+r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")
+
+prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")
+comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
+
+from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from")
+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
+to_RDR    = varQual_RDR gHC_GENERICS (fsLit "to")
+to1_RDR   = varQual_RDR gHC_GENERICS (fsLit "to1")
+
+datatypeName_RDR  = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
+moduleName_RDR    = varQual_RDR gHC_GENERICS (fsLit "moduleName")
+selName_RDR       = varQual_RDR gHC_GENERICS (fsLit "selName")
+conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")
+conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")
+conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
+
+noArityDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
+arityDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Arity")
+prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
+infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")
+leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
+rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
+notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+
+
 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
 fmap_RDR 		= varQual_RDR gHC_BASE (fsLit "fmap")
 pure_RDR 		= varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
@@ -608,19 +677,48 @@ eitherTyConName	  = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey
 leftDataConName   = conName dATA_EITHER (fsLit "Left")   leftDataConKey
 rightDataConName  = conName dATA_EITHER (fsLit "Right")  rightDataConKey
 
--- Generics
-crossTyConName, plusTyConName, genUnitTyConName :: Name
-crossTyConName     = tcQual   gHC_GENERICS (fsLit ":*:") crossTyConKey
-plusTyConName      = tcQual   gHC_GENERICS (fsLit ":+:") plusTyConKey
-genUnitTyConName   = tcQual   gHC_GENERICS (fsLit "Unit") genUnitTyConKey
+-- Generics (types)
+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+  compTyConName, rTyConName, pTyConName, dTyConName, 
+  cTyConName, sTyConName, rec0TyConName, par0TyConName,
+  d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+  repTyConName, rep1TyConName :: Name
+
+v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
+u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
+par1TyConName  = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
+rec1TyConName  = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
+k1TyConName  = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
+m1TyConName  = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
+
+sumTyConName    = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey
+prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
+compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
+
+rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey
+pTyConName  = tcQual gHC_GENERICS (fsLit "P") pTyConKey
+dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey
+cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey
+sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey
+
+rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
+par0TyConName  = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
+d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
+c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
+s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
+noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
+
+repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey
+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
 
 -- Base strings Strings
 unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
     unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
-unpackCStringName       = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName  = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name   = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
+unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name   = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
 eqStringName	 	= varQual gHC_BASE (fsLit "eqString")  eqStringIdKey
 stringTyConName         = tcQual  gHC_BASE (fsLit "String") stringTyConKey
 
@@ -629,12 +727,13 @@ inlineIdName :: Name
 inlineIdName	 	= varQual gHC_MAGIC (fsLit "inline") inlineIdKey
 
 -- Base classes (Eq, Ord, Functor)
-eqClassName, eqName, ordClassName, geName, functorClassName :: Name
+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
 eqClassName	  = clsQual  gHC_CLASSES (fsLit "Eq")      eqClassKey
 eqName		  = methName gHC_CLASSES (fsLit "==")      eqClassOpKey
 ordClassName	  = clsQual  gHC_CLASSES (fsLit "Ord")     ordClassKey
 geName		  = methName gHC_CLASSES (fsLit ">=")      geClassOpKey
 functorClassName  = clsQual  gHC_BASE (fsLit "Functor") functorClassKey
+fmapName          = methName gHC_BASE (fsLit "fmap")    fmapClassOpKey
 
 -- Class Monad
 monadClassName, thenMName, bindMName, returnMName, failMName :: Name
@@ -787,6 +886,16 @@ showClassName	  = clsQual gHC_SHOW (fsLit "Show")       showClassKey
 readClassName :: Name
 readClassName	   = clsQual gHC_READ (fsLit "Read") readClassKey
 
+-- Classes Generic and Generic1, Datatype, Constructor and Selector
+genClassName, gen1ClassName, datatypeClassName, constructorClassName,
+  selectorClassName :: Name
+genClassName  = clsQual gHC_GENERICS (fsLit "Generic")  genClassKey
+gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey
+
+datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
+constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
+selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
+
 -- parallel array types and functions
 enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
     singletonPName, replicatePName, mapPName, filterPName,
@@ -922,6 +1031,14 @@ appAName	   = varQual aRROW (fsLit "app")	  appAIdKey
 choiceAName	   = varQual aRROW (fsLit "|||")	  choiceAIdKey
 loopAName	   = varQual aRROW (fsLit "loop")  loopAIdKey
 
+-- Monad comprehensions
+guardMName, liftMName, groupMName, mzipName :: Name
+guardMName         = varQual mONAD (fsLit "guard") guardMIdKey
+liftMName          = varQual mONAD (fsLit "liftM") liftMIdKey
+groupMName         = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey
+mzipName           = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey
+
+
 -- Annotation type checking
 toAnnotationWrapperName :: Name
 toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey
@@ -1032,6 +1149,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique
 applicativeClassKey	= mkPreludeClassUnique 34
 foldableClassKey	= mkPreludeClassUnique 35
 traversableClassKey	= mkPreludeClassUnique 36
+
+genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
+  selectorClassKey :: Unique
+genClassKey   = mkPreludeClassUnique 37
+gen1ClassKey  = mkPreludeClassUnique 38
+
+datatypeClassKey    = mkPreludeClassUnique 39
+constructorClassKey = mkPreludeClassUnique 40
+selectorClassKey    = mkPreludeClassUnique 41
 \end{code}
 
 %************************************************************************
@@ -1091,11 +1217,12 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
-    funPtrTyConKey, tVarPrimTyConKey :: Unique
+    funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique
 statePrimTyConKey			= mkPreludeTyConUnique 50
 stableNamePrimTyConKey			= mkPreludeTyConUnique 51
-stableNameTyConKey		        = mkPreludeTyConUnique 52
-mutVarPrimTyConKey			= mkPreludeTyConUnique 55
+stableNameTyConKey                      = mkPreludeTyConUnique 52
+eqPredPrimTyConKey                      = mkPreludeTyConUnique 53
+mutVarPrimTyConKey                      = mkPreludeTyConUnique 55
 ioTyConKey				= mkPreludeTyConUnique 56
 wordPrimTyConKey			= mkPreludeTyConUnique 58
 wordTyConKey				= mkPreludeTyConUnique 59
@@ -1117,12 +1244,6 @@ ptrTyConKey				= mkPreludeTyConUnique 74
 funPtrTyConKey				= mkPreludeTyConUnique 75
 tVarPrimTyConKey		    	= mkPreludeTyConUnique 76
 
--- Generic Type Constructors
-crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
-crossTyConKey		      		= mkPreludeTyConUnique 79
-plusTyConKey		      		= mkPreludeTyConUnique 80
-genUnitTyConKey				= mkPreludeTyConUnique 81
-
 -- Parallel array type constructor
 parrTyConKey :: Unique
 parrTyConKey				= mkPreludeTyConUnique 82
@@ -1135,9 +1256,8 @@ eitherTyConKey :: Unique
 eitherTyConKey				= mkPreludeTyConUnique 84
 
 -- Super Kinds constructors
-tySuperKindTyConKey, coSuperKindTyConKey :: Unique
+tySuperKindTyConKey :: Unique
 tySuperKindTyConKey                    = mkPreludeTyConUnique 85
-coSuperKindTyConKey                    = mkPreludeTyConUnique 86
 
 -- Kind constructors
 liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
@@ -1174,9 +1294,41 @@ opaqueTyConKey                          = mkPreludeTyConUnique 133
 stringTyConKey :: Unique
 stringTyConKey				= mkPreludeTyConUnique 134
 
--- Heterogeneous Metaprogramming code type constructor
-hetMetCodeTypeTyConKey :: Unique
-hetMetCodeTypeTyConKey			= mkPreludeTyConUnique 135
+-- Generics (Unique keys)
+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
+  compTyConKey, rTyConKey, pTyConKey, dTyConKey,
+  cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+  d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
+  repTyConKey, rep1TyConKey :: Unique
+
+v1TyConKey    = mkPreludeTyConUnique 135
+u1TyConKey    = mkPreludeTyConUnique 136
+par1TyConKey  = mkPreludeTyConUnique 137
+rec1TyConKey  = mkPreludeTyConUnique 138
+k1TyConKey    = mkPreludeTyConUnique 139
+m1TyConKey    = mkPreludeTyConUnique 140
+
+sumTyConKey   = mkPreludeTyConUnique 141
+prodTyConKey  = mkPreludeTyConUnique 142
+compTyConKey  = mkPreludeTyConUnique 143
+
+rTyConKey = mkPreludeTyConUnique 144
+pTyConKey = mkPreludeTyConUnique 145
+dTyConKey = mkPreludeTyConUnique 146
+cTyConKey = mkPreludeTyConUnique 147
+sTyConKey = mkPreludeTyConUnique 148
+
+rec0TyConKey  = mkPreludeTyConUnique 149
+par0TyConKey  = mkPreludeTyConUnique 150
+d1TyConKey    = mkPreludeTyConUnique 151
+c1TyConKey    = mkPreludeTyConUnique 152
+s1TyConKey    = mkPreludeTyConUnique 153
+noSelTyConKey = mkPreludeTyConUnique 154
+
+repTyConKey  = mkPreludeTyConUnique 155
+rep1TyConKey = mkPreludeTyConUnique 156
+>>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5
 
 ---------------- Template Haskell -------------------
 --	USES TyConUniques 200-299
@@ -1334,6 +1486,9 @@ mapIdKey	      = mkPreludeMiscIdUnique 69
 groupWithIdKey        = mkPreludeMiscIdUnique 70
 dollarIdKey           = mkPreludeMiscIdUnique 71
 
+coercionTokenIdKey :: Unique
+coercionTokenIdKey    = mkPreludeMiscIdUnique 72
+
 -- Parallel array functions
 singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
     filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
@@ -1376,7 +1531,8 @@ unboundKey		      = mkPreludeMiscIdUnique 101
 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
     enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
     enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
-    failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey
+    failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+    fmapClassOpKey
     :: Unique
 fromIntegerClassOpKey	      = mkPreludeMiscIdUnique 102
 minusClassOpKey		      = mkPreludeMiscIdUnique 103
@@ -1391,6 +1547,7 @@ negateClassOpKey	      = mkPreludeMiscIdUnique 111
 failMClassOpKey		      = mkPreludeMiscIdUnique 112
 bindMClassOpKey		      = mkPreludeMiscIdUnique 113 -- (>>=)
 thenMClassOpKey		      = mkPreludeMiscIdUnique 114 -- (>>)
+fmapClassOpKey                = mkPreludeMiscIdUnique 115
 returnMClassOpKey	      = mkPreludeMiscIdUnique 117
 
 -- Recursive do notation
@@ -1421,11 +1578,17 @@ realToFracIdKey      = mkPreludeMiscIdUnique 128
 toIntegerClassOpKey  = mkPreludeMiscIdUnique 129
 toRationalClassOpKey = mkPreludeMiscIdUnique 130
 
+-- Monad comprehensions
+guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique
+guardMIdKey     = mkPreludeMiscIdUnique 131
+liftMIdKey      = mkPreludeMiscIdUnique 132
+groupMIdKey     = mkPreludeMiscIdUnique 133
+mzipIdKey       = mkPreludeMiscIdUnique 134
+
 -- code types
-hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
-hetmet_brak_key    = mkPreludeMiscIdUnique 131
-hetmet_esc_key     = mkPreludeMiscIdUnique 132
-hetmet_csp_key     = mkPreludeMiscIdUnique 133
+hetMetCodeTypeTyConKey :: Unique
+hetMetCodeTypeTyConKey			= mkPreludeTyConUnique 135
+
 hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique
 hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
 hetmet_guest_string_literal_key  = mkPreludeMiscIdUnique 135
@@ -1476,6 +1639,10 @@ hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159
 hetmet_PGArrow_exponent_key :: Unique
 hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160
 
+hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
+hetmet_brak_key    = mkPreludeMiscIdUnique 161
+hetmet_esc_key     = mkPreludeMiscIdUnique 162
+hetmet_csp_key     = mkPreludeMiscIdUnique 163
 
 
 ---------------- Template Haskell -------------------
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b37556b..93cc576 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
 like that, so we use a BuiltinRule instead, so that we
 can match in any two literal values.  So the rule is really
 more like
-        (Lit 4) +# (Lit y) = Lit (x+#y)
+        (Lit x) +# (Lit y) = Lit (x+#y)
 where the (+#) on the rhs is done at compile time
 
 That is why these rules are built in here.  Other rules
@@ -527,7 +527,7 @@ For dataToTag#, we can reduce if either
 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
   | tag_to_enum `hasKey` tagToEnumKey
-  , ty1 `coreEqType` ty2
+  , ty1 `eqType` ty2
   = Just tag  -- dataToTag (tagToEnum x)   ==>   x
 
 dataToTagRule id_unf [_, val_arg]
@@ -600,7 +600,7 @@ match_append_lit _ [Type ty1,
                    ]
   | unpk `hasKey` unpackCStringFoldrIdKey &&
     c1 `cheapEqExpr` c2
-  = ASSERT( ty1 `coreEqType` ty2 )
+  = ASSERT( ty1 `eqType` ty2 )
     Just (Var unpk `App` Type ty1
                    `App` Lit (MachStr (s1 `appendFS` s2))
                    `App` c1
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 8c532ff..29c5644 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -18,8 +18,8 @@ module PrimOp (
 
 	tagToEnumKey,
 
-	primOpOutOfLine, primOpNeedsWrapper, 
-	primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
+        primOpOutOfLine, primOpCodeSize,
+        primOpOkForSpeculation, primOpIsCheap,
 
 	getPrimOpResultInfo,  PrimOpResultInfo(..),
 
@@ -363,18 +363,23 @@ primOpIsCheap op = primOpOkForSpeculation op
 -- even if primOpIsCheap sometimes says 'True'.
 \end{code}
 
-primOpIsDupable
-~~~~~~~~~~~~~~~
-primOpIsDupable means that the use of the primop is small enough to
-duplicate into different case branches.  See CoreUtils.exprIsDupable.
+primOpCodeSize
+~~~~~~~~~~~~~~
+Gives an indication of the code size of a primop, for the purposes of
+calculating unfolding sizes; see CoreUnfold.sizeExpr.
 
 \begin{code}
-primOpIsDupable :: PrimOp -> Bool
-	-- See comments with CoreUtils.exprIsDupable
-	-- We say it's dupable it isn't implemented by a C call with a wrapper
-primOpIsDupable op = not (primOpNeedsWrapper op)
-\end{code}
+primOpCodeSize :: PrimOp -> Int
+#include "primop-code-size.hs-incl"
+
+primOpCodeSizeDefault :: Int
+primOpCodeSizeDefault = 1
+  -- CoreUnfold.primOpSize already takes into account primOpOutOfLine
+  -- and adds some further costs for the args in that case.
 
+primOpCodeSizeForeignCall :: Int
+primOpCodeSizeForeignCall = 4
+\end{code}
 
 \begin{code}
 primOpCanFail :: PrimOp -> Bool
@@ -421,14 +426,6 @@ primOpHasSideEffects :: PrimOp -> Bool
 #include "primop-has-side-effects.hs-incl"
 \end{code}
 
-Inline primitive operations that perform calls need wrappers to save
-any live variables that are stored in caller-saves registers.
-
-\begin{code}
-primOpNeedsWrapper :: PrimOp -> Bool
-#include "primop-needs-wrapper.hs-incl"
-\end{code}
-
 \begin{code}
 primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead
 primOpType op
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index a5d9335..4c70bcb 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -14,7 +14,22 @@ module TysPrim(
 	openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
         argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
 
-	primTyCons,
+        -- Kind constructors...
+        tySuperKindTyCon, tySuperKind,
+        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+        argTypeKindTyCon, ubxTupleKindTyCon,
+
+        tySuperKindTyConName, liftedTypeKindTyConName,
+        openTypeKindTyConName, unliftedTypeKindTyConName,
+        ubxTupleKindTyConName, argTypeKindTyConName,
+
+        -- Kinds
+	liftedTypeKind, unliftedTypeKind, openTypeKind,
+        argTypeKind, ubxTupleKind,
+        mkArrowKind, mkArrowKinds, isCoercionKind,
+
+        funTyCon, funTyConName,
+        primTyCons,
 
 	charPrimTyCon, 		charPrimTy,
 	intPrimTyCon,		intPrimTy,
@@ -44,7 +59,9 @@ module TysPrim(
 	word32PrimTyCon,	word32PrimTy,
 
 	int64PrimTyCon,		int64PrimTy,
-	word64PrimTyCon,	word64PrimTy,
+        word64PrimTyCon,        word64PrimTy,
+
+        eqPredPrimTyCon,            -- ty1 ~ ty2
 
 	-- * Any
 	anyTyCon, anyTyConOfKind, anyTypeOfKind
@@ -54,11 +71,10 @@ module TysPrim(
 
 import Var		( TyVar, mkTyVar )
 import Name		( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName		( mkTcOcc )
-import OccName		( mkTyVarOccFS, mkTcOccFS )
-import TyCon		( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
+import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import TyCon
+import TypeRep
 import Type
-import TypeRep          ( ecKind )
 import Coercion
 import SrcLoc
 import Unique		( mkAlphaTyVarUnique )
@@ -103,6 +119,7 @@ primTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , anyTyCon
+    , eqPredPrimTyCon
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
@@ -112,7 +129,7 @@ mkPrimTc fs unique tycon
 		  (ATyCon tycon)	-- Relevant TyCon
 		  UserSyntax		-- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name
 charPrimTyConName    	      = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName     	      = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName	      = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -123,8 +140,9 @@ word64PrimTyConName  	      = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word
 addrPrimTyConName    	      = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
 floatPrimTyConName   	      = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
 doublePrimTyConName  	      = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
-statePrimTyConName   	      = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-realWorldTyConName   	      = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
+statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
+eqPredPrimTyConName           = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon
+realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
 arrayPrimTyConName   	      = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
 byteArrayPrimTyConName	      = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
 mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
@@ -197,109 +215,95 @@ argBetaTy  = mkTyVarTy argBetaTyVar
 
 %************************************************************************
 %*									*
-		Any
+                FunTyCon
 %*									*
 %************************************************************************
 
-Note [Any types]
-~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
-
-  * It is defined in module GHC.Prim, and exported so that it is 
-    available to users.  For this reason it's treated like any other 
-    primitive type:
-      - has a fixed unique, anyTyConKey, 
-      - lives in the global name cache
-      - built with TyCon.PrimTyCon
-
-  * It is lifted, and hence represented by a pointer
-
-  * It is inhabited by at least one value, namely bottom
-
-  * You can unsafely coerce any lifted type to Ayny, and back.
-
-  * It does not claim to be a *data* type, and that's important for
-    the code generator, because the code gen may *enter* a data value
-    but never enters a function value. 
-
-  * It is used to instantiate otherwise un-constrained type variables of kind *
-    For example   	length Any []
-    See Note [Strangely-kinded void TyCons]
-
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *.  This is a bit
-like tuples; there is a potentially-infinite family.  They have slightly
-different characteristics to Any::*:
-  
-  * They are built with TyCon.AnyTyCon
-  * They have non-user-writable names like "Any(*->*)" 
-  * They are not exported by GHC.Prim
-  * They are uninhabited (of course; not kind *)
-  * They have a unique derived from their OccName (see Note [Uniques of Any])
-  * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique.  Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead.  That should be unique, 
-  - both wrt each other, because their strings differ
-
-  - and wrt any other Name, because Names get uniques with 
-    various 'char' tags, but the OccName of Any will 
-    get a Unique built with mkTcOccUnique, which has a particular 'char' 
-    tag; see Unique.mkTcOccUnique!
-
-Note [Strangely-kinded void TyCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #959 for more examples
+\begin{code}
+funTyConName :: Name
+funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+
+funTyCon :: TyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
+        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+	-- But if we do that we get kind errors when saying
+	--	instance Control.Arrow (->)
+	-- becuase the expected kind is (*->*->*).  The trouble is that the
+	-- expected/actual stuff in the unifier does not go contra-variant, whereas
+	-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
+	-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
+        -- because they are never in scope in the source
+\end{code}
 
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void.  Eg.
 
-	length []
-===>
-	length Any (Nil Any)
+%************************************************************************
+%*									*
+                Kinds
+%*									*
+%************************************************************************
 
-But in really obscure programs, the type variable might have a kind
-other than *, so we need to invent a suitably-kinded type.
+\begin{code}
+-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
+tySuperKindTyCon, liftedTypeKindTyCon,
+      openTypeKindTyCon, unliftedTypeKindTyCon,
+      ubxTupleKindTyCon, argTypeKindTyCon
+   :: TyCon
+tySuperKindTyConName, liftedTypeKindTyConName,
+      openTypeKindTyConName, unliftedTypeKindTyConName,
+      ubxTupleKindTyConName, argTypeKindTyConName
+   :: Name
+
+tySuperKindTyCon      = mkSuperKindTyCon tySuperKindTyConName
+liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
+openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName     tySuperKind
+argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName      tySuperKind
+
+--------------------------
+-- ... and now their names
+
+tySuperKindTyConName      = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+liftedTypeKindTyConName   = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
+openTypeKindTyConName     = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
+unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
+ubxTupleKindTyConName     = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
+argTypeKindTyConName      = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
+
+mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
+mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) 
+					      key 
+					      (ATyCon tycon)
+					      BuiltInSyntax
+	-- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
+	-- because they are never in scope in the source
+\end{code}
 
-This commit uses
-	Any for kind *
-	Any(*->*) for kind *->*
-	etc
 
 \begin{code}
-anyTyConName :: Name
-anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+kindTyConType :: TyCon -> Type
+kindTyConType kind = TyConApp kind []
 
-anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
 
-anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+liftedTypeKind   = kindTyConType liftedTypeKindTyCon
+unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
+openTypeKind     = kindTyConType openTypeKindTyCon
+argTypeKind      = kindTyConType argTypeKindTyCon
+ubxTupleKind	 = kindTyConType ubxTupleKindTyCon
 
-anyTyConOfKind :: Kind -> TyCon
--- Map all superkinds of liftedTypeKind to liftedTypeKind
-anyTyConOfKind kind 
-  | liftedTypeKind `isSubKind` kind = anyTyCon
-  | otherwise                       = tycon
-  where
-	  -- Derive the name from the kind, thus:
-	  --     Any(*->*), Any(*->*->*)
-	  -- These are names that can't be written by the user,
-	  -- and are not allocated in the global name cache
-    str = "Any" ++ showSDoc (pprParendKind kind)
+-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
+mkArrowKind :: Kind -> Kind -> Kind
+mkArrowKind k1 k2 = FunTy k1 k2
 
-    occ   = mkTcOcc str
-    uniq  = getUnique occ  -- See Note [Uniques of Any]
-    name  = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
-    tycon = mkAnyTyCon name kind 
-\end{code}
+-- | Iterated application of 'mkArrowKind'
+mkArrowKinds :: [Kind] -> Kind -> Kind
+mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
 
+tySuperKind :: SuperKind
+tySuperKind = kindTyConType tySuperKindTyCon 
+\end{code}
 
 %************************************************************************
 %*									*
@@ -380,6 +384,22 @@ doublePrimTyCon	= pcPrimTyCon0 doublePrimTyConName DoubleRep
 %*									*
 %************************************************************************
 
+Note [The (~) TyCon)
+~~~~~~~~~~~~~~~~~~~~
+There is a perfectly ordinary type constructor (~) that represents the type
+of coercions (which, remember, are values).  For example
+   Refl Int :: Int ~ Int
+
+Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
+   Refl Maybe :: Maybe ~ Maybe
+
+So the true kind of (~) :: forall k. k -> k -> #.  But we don't have
+polymorphic kinds (yet). However, (~) really only appears saturated in
+which case there is no problem in finding the kind of (ty1 ~ ty2). So
+we check that in CoreLint (and, in an assertion, in Kind.typeKind).
+
+Note [The State# TyCon]
+~~~~~~~~~~~~~~~~~~~~~~~
 State# is the primitive, unlifted type of states.  It has one type parameter,
 thus
 	State# RealWorld
@@ -392,8 +412,13 @@ keep different state threads separate.  It is represented by nothing at all.
 \begin{code}
 mkStatePrimTy :: Type -> Type
 mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
-statePrimTyCon :: TyCon
+
+statePrimTyCon :: TyCon   -- See Note [The State# TyCon]
 statePrimTyCon	 = pcPrimTyCon statePrimTyConName 1 VoidRep
+
+eqPredPrimTyCon :: TyCon  -- The representation type for equality predicates
+		   	  -- See Note [The (~) TyCon]
+eqPredPrimTyCon  = pcPrimTyCon eqPredPrimTyConName 2 VoidRep
 \end{code}
 
 RealWorld is deeply magical.  It is *primitive*, but it is not
@@ -412,7 +437,6 @@ realWorldStatePrimTy = mkStatePrimTy realWorldTy	-- State# RealWorld
 Note: the ``state-pairing'' types are not truly primitive, so they are
 defined in \tr{TysWiredIn.lhs}, not here.
 
-
 %************************************************************************
 %*									*
 \subsection[TysPrim-arrays]{The primitive array types}
@@ -555,3 +579,110 @@ threadIdPrimTy    = mkTyConTy threadIdPrimTyCon
 threadIdPrimTyCon :: TyCon
 threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
 \end{code}
+
+
+
+%************************************************************************
+%*									*
+		Any
+%*									*
+%************************************************************************
+
+Note [Any types]
+~~~~~~~~~~~~~~~~
+The type constructor Any::* has these properties
+
+  * It is defined in module GHC.Prim, and exported so that it is 
+    available to users.  For this reason it's treated like any other 
+    primitive type:
+      - has a fixed unique, anyTyConKey, 
+      - lives in the global name cache
+      - built with TyCon.PrimTyCon
+
+  * It is lifted, and hence represented by a pointer
+
+  * It is inhabited by at least one value, namely bottom
+
+  * You can unsafely coerce any lifted type to Ayny, and back.
+
+  * It does not claim to be a *data* type, and that's important for
+    the code generator, because the code gen may *enter* a data value
+    but never enters a function value. 
+
+  * It is used to instantiate otherwise un-constrained type variables of kind *
+    For example   	length Any []
+    See Note [Strangely-kinded void TyCons]
+
+In addition, we have a potentially-infinite family of types, one for
+each kind /other than/ *, needed to instantiate otherwise
+un-constrained type variables of kinds other than *.  This is a bit
+like tuples; there is a potentially-infinite family.  They have slightly
+different characteristics to Any::*:
+  
+  * They are built with TyCon.AnyTyCon
+  * They have non-user-writable names like "Any(*->*)" 
+  * They are not exported by GHC.Prim
+  * They are uninhabited (of course; not kind *)
+  * They have a unique derived from their OccName (see Note [Uniques of Any])
+  * Their Names do not live in the global name cache
+
+Note [Uniques of Any]
+~~~~~~~~~~~~~~~~~~~~~
+Although Any(*->*), say, doesn't have a binding site, it still needs
+to have a Unique.  Unlike tuples (which are also an infinite family)
+there is no convenient way to index them, so we use the Unique from
+their OccName instead.  That should be unique, 
+  - both wrt each other, because their strings differ
+
+  - and wrt any other Name, because Names get uniques with 
+    various 'char' tags, but the OccName of Any will 
+    get a Unique built with mkTcOccUnique, which has a particular 'char' 
+    tag; see Unique.mkTcOccUnique!
+
+Note [Strangely-kinded void TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #959 for more examples
+
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void.  Eg.
+
+	length []
+===>
+	length Any (Nil Any)
+
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
+
+This commit uses
+	Any for kind *
+	Any(*->*) for kind *->*
+	etc
+
+\begin{code}
+anyTyConName :: Name
+anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+
+anyTyCon :: TyCon
+anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+
+anyTypeOfKind :: Kind -> Type
+anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+
+anyTyConOfKind :: Kind -> TyCon
+-- Map all superkinds of liftedTypeKind to liftedTypeKind
+anyTyConOfKind kind 
+  | isLiftedTypeKind kind = anyTyCon
+  | otherwise             = tycon
+  where
+	  -- Derive the name from the kind, thus:
+	  --     Any(*->*), Any(*->*->*)
+	  -- These are names that can't be written by the user,
+	  -- and are not allocated in the global name cache
+    str = "Any" ++ showSDoc (pprParendKind kind)
+
+    occ   = mkTcOcc str
+    uniq  = getUnique occ  -- See Note [Uniques of Any]
+    name  = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
+    tycon = mkAnyTyCon name kind 
+\end{code}
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 2f1b637..bc45028 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -70,23 +70,14 @@ import TysPrim
 -- others:
 import Constants	( mAX_TUPLE_SIZE )
 import Module		( Module )
+import DataCon          ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
+import Var
+import TyCon
+import TypeRep
 import RdrName
 import Name
-import DataCon		( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
-import Var
-import TyCon		( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
-			  mkTupleTyCon, mkAlgTyCon, tyConName,
-			  TyConParent(NoParentTyCon) )
-
-import BasicTypes	( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
-
-import Type		( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
-			  TyThing(..) )
-import Coercion         ( unsafeCoercionTyCon, symCoercionTyCon,
-                          transCoercionTyCon, leftCoercionTyCon, 
-                          rightCoercionTyCon, instCoercionTyCon )
-import TypeRep          ( mkArrowKinds, liftedTypeKind, ubxTupleKind )
-import Unique		( incrUnique, mkTupleTyConUnique,
+import BasicTypes       ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
+import Unique           ( incrUnique, mkTupleTyConUnique,
 			  mkTupleDataConUnique, mkPArrDataConUnique )
 import Data.Array
 import FastString
@@ -131,12 +122,6 @@ wiredInTyCons = [ unitTyCon	-- Not treated like other tuples, because
     	      , listTyCon
 	      , parrTyCon
 	      , hetMetCodeTypeTyCon
-              , unsafeCoercionTyCon
-              , symCoercionTyCon
-              , transCoercionTyCon
-              , leftCoercionTyCon
-              , rightCoercionTyCon
-              , instCoercionTyCon
     	      ]
 \end{code}
 
@@ -225,7 +210,6 @@ pcTyCon is_enum is_rec name tyvars cons
 		(DataTyCon cons is_enum)
 		NoParentTyCon
                 is_rec
-		True		-- All the wired-in tycons have generics
 		False		-- Not in GADT syntax
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
@@ -290,7 +274,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA
 mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
 mk_tuple boxity arity = (tycon, tuple_con)
   where
-	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info 
+	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity 
 	modu	= mkTupleModule boxity arity
 	tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
 				(ATyCon tycon) BuiltInSyntax
@@ -307,8 +291,6 @@ mk_tuple boxity arity = (tycon, tuple_con)
 				  (ADataCon tuple_con) BuiltInSyntax
  	tc_uniq   = mkTupleTyConUnique   boxity arity
 	dc_uniq   = mkTupleDataConUnique boxity arity
-	gen_info  = True		-- Tuples all have generics..
-					-- hmm: that's a *lot* of code
 
 unitTyCon :: TyCon
 unitTyCon     = tupleTyCon Boxed 0
@@ -625,7 +607,6 @@ isPArrFakeCon      :: DataCon -> Bool
 isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)
 \end{code}
 
-
 Heterogeneous Metaprogramming
 
 \begin{code}
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 7d80db4..4dfe019 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -43,7 +43,7 @@ defaults
    has_side_effects = False
    out_of_line      = False
    commutable       = False
-   needs_wrapper    = False
+   code_size        = { primOpCodeSizeDefault }
    can_fail         = False
    strictness       = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
 
@@ -155,6 +155,7 @@ primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Bool
 primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Bool
 
 primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#
+   with code_size = 0
 
 ------------------------------------------------------------------------
 section "Int#"
@@ -212,9 +213,12 @@ primop   IntNegOp    "negateInt#"    Monadic   Int# -> Int#
 primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
 	 {Add with carry.  First member of result is (wrapped) sum; 
           second member is 0 iff no overflow occured.}
+   with code_size = 2
+
 primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
 	 {Subtract with carry.  First member of result is (wrapped) difference; 
           second member is 0 iff no overflow occured.}
+   with code_size = 2
 
 primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Bool
 primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Bool
@@ -231,8 +235,11 @@ primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Bool
 primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Bool
 
 primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#
+   with code_size = 0
 
 primop   Int2WordOp "int2Word#" GenPrimOp Int# -> Word#
+   with code_size = 0
+
 primop   Int2FloatOp   "int2Float#"      GenPrimOp  Int# -> Float#
 primop   Int2DoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#
 
@@ -286,6 +293,7 @@ primop   SrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#
           in the range 0 to word size - 1 inclusive.}
 
 primop   Word2IntOp   "word2Int#"   GenPrimOp   Word# -> Int#
+   with code_size = 0
 
 primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Bool
 primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Bool
@@ -396,63 +404,72 @@ primop   Double2FloatOp   "double2Float#" GenPrimOp Double# -> Float#
 
 primop   DoubleExpOp   "expDouble#"      Monadic
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleLogOp   "logDouble#"      Monadic         
    Double# -> Double#
    with
-   needs_wrapper = True
+   code_size = { primOpCodeSizeForeignCall }
    can_fail = True
 
 primop   DoubleSqrtOp   "sqrtDouble#"      Monadic  
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleSinOp   "sinDouble#"      Monadic          
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleCosOp   "cosDouble#"      Monadic          
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleTanOp   "tanDouble#"      Monadic          
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleAsinOp   "asinDouble#"      Monadic 
    Double# -> Double#
    with
-   needs_wrapper = True
+   code_size = { primOpCodeSizeForeignCall }
    can_fail = True
 
 primop   DoubleAcosOp   "acosDouble#"      Monadic  
    Double# -> Double#
    with
-   needs_wrapper = True
+   code_size = { primOpCodeSizeForeignCall }
    can_fail = True
 
 primop   DoubleAtanOp   "atanDouble#"      Monadic  
    Double# -> Double#
    with
-   needs_wrapper = True
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleSinhOp   "sinhDouble#"      Monadic  
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleCoshOp   "coshDouble#"      Monadic  
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleTanhOp   "tanhDouble#"      Monadic  
    Double# -> Double#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoublePowerOp   "**##" Dyadic  
    Double# -> Double# -> Double#
    {Exponentiation.}
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp    
    Double# -> (# Int#, Word#, Word#, Int# #)
@@ -506,58 +523,71 @@ primop   Float2IntOp   "float2Int#"      GenPrimOp  Float# -> Int#
 
 primop   FloatExpOp   "expFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatLogOp   "logFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
-        can_fail = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
+   can_fail = True
 
 primop   FloatSqrtOp   "sqrtFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatSinOp   "sinFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatCosOp   "cosFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatTanOp   "tanFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatAsinOp   "asinFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
-        can_fail = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
+   can_fail = True
 
 primop   FloatAcosOp   "acosFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
-        can_fail = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
+   can_fail = True
 
 primop   FloatAtanOp   "atanFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatSinhOp   "sinhFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatCoshOp   "coshFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatTanhOp   "tanhFloat#"      Monadic          
    Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   FloatPowerOp   "powerFloat#"      Dyadic   
    Float# -> Float# -> Float#
-   with needs_wrapper = True
+   with
+   code_size = { primOpCodeSizeForeignCall }
 
 primop   Float2DoubleOp   "float2Double#" GenPrimOp  Float# -> Double#
 
@@ -599,6 +629,7 @@ primop  WriteArrayOp "writeArray#" GenPrimOp
    {Write to specified index of mutable array.}
    with
    has_side_effects = True
+   code_size = 2 -- card update too
 
 primop  SizeofArrayOp "sizeofArray#" GenPrimOp
    Array# a -> Int#
@@ -626,6 +657,55 @@ primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+primop  CopyArrayOp "copyArray#" GenPrimOp
+  Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the Array# to the specified region in the MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.
+   The two arrays must not be the same array in different states, but this is not checked either.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop  CloneArrayOp "cloneArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> Array# a
+  {Return a newly allocated Array# with the specified subrange of the provided Array#. 
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided Array#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop  FreezeArrayOp "freezeArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop  ThawArrayOp "thawArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+  code_size = { primOpCodeSizeForeignCall + 4 }
+
 ------------------------------------------------------------------------
 section "Byte Arrays"
 	{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
@@ -888,8 +968,10 @@ primop	 AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#
 #if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
 primop   Addr2IntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#
 	{Coerce directly from address to int. Strongly deprecated.}
+   with code_size = 0
 primop   Int2AddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#
 	{Coerce directly from int to address. Strongly deprecated.}
+   with code_size = 0
 #endif
 
 primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Bool
@@ -1106,6 +1188,7 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
    {Write contents of {\tt MutVar\#}.}
    with
    has_side_effects = True
+   code_size = { primOpCodeSizeForeignCall } -- for the write barrier
 
 primop  SameMutVarOp "sameMutVar#" GenPrimOp
    MutVar# s a -> MutVar# s a -> Bool
@@ -1338,7 +1421,6 @@ primop  DelayOp "delay#" GenPrimOp
    Int# -> State# s -> State# s
    {Sleep specified number of microseconds.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1346,7 +1428,6 @@ primop  WaitReadOp "waitRead#" GenPrimOp
    Int# -> State# s -> State# s
    {Block until input is available on specified file descriptor.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1354,7 +1435,6 @@ primop  WaitWriteOp "waitWrite#" GenPrimOp
    Int# -> State# s -> State# s
    {Block until output is possible on specified file descriptor.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1363,7 +1443,6 @@ primop  AsyncReadOp "asyncRead#" GenPrimOp
    Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
    {Asynchronously read bytes from specified file descriptor.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1371,7 +1450,6 @@ primop  AsyncWriteOp "asyncWrite#" GenPrimOp
    Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
    {Asynchronously write bytes from specified file descriptor.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1379,7 +1457,6 @@ primop  AsyncDoProcOp "asyncDoProc#" GenPrimOp
    Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
    {Asynchronously perform procedure (first arg), passing it 2nd arg.}
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1496,6 +1573,7 @@ primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp
 primop TouchOp "touch#" GenPrimOp
    o -> State# RealWorld -> State# RealWorld
    with
+   code_size = { 0 }
    has_side_effects = True
 
 ------------------------------------------------------------------------
@@ -1515,7 +1593,6 @@ primop  MakeStablePtrOp "makeStablePtr#" GenPrimOp
 primop  DeRefStablePtrOp "deRefStablePtr#" GenPrimOp
    StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1527,7 +1604,6 @@ primop  EqStablePtrOp "eqStablePtr#" GenPrimOp
 primop  MakeStableNameOp "makeStableName#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
    with
-   needs_wrapper    = True
    has_side_effects = True
    out_of_line      = True
 
@@ -1555,6 +1631,7 @@ primop  ParOp "par#" GenPrimOp
       -- Note that Par is lazy to avoid that the sparked thing
       -- gets evaluted strictly, which it should *not* be
    has_side_effects = True
+   code_size = { primOpCodeSizeForeignCall }
 
 primop GetSparkOp "getSpark#" GenPrimOp
    State# s -> (# State# s, Int#, a #)
@@ -1644,6 +1721,8 @@ primtype BCO#
 primop   AddrToHValueOp "addrToHValue#" GenPrimOp
    Addr# -> (# a #)
    {Convert an {\tt Addr\#} to a followable type.}
+   with
+   code_size = 0
 
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
    BCO# -> (# a #)
@@ -1738,9 +1817,19 @@ primtype Any a
 	    but never enters a function value.  
 
 	It's also used to instantiate un-constrained type variables after type
-	checking.  For example
+	checking.  For example, {\tt length} has type
+
+	{\tt length :: forall a. [a] -> Int}
+
+	and the list datacon for the empty list has type
+
+	{\tt [] :: forall a. [a]}
+
+	In order to compose these two terms as {\tt length []} a type
+	application is required, but there is no constraint on the
+	choice.  In this situation GHC uses {\tt Any}:
 
-	{\tt length Any []}
+	{\tt length Any ([] Any)}
 
 	Annoyingly, we sometimes need {\tt Any}s of other kinds, such as {\tt (* -> *)} etc.
 	This is a bit like tuples.   We define a couple of useful ones here,
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index df3b12d..80a47a4 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -26,7 +26,6 @@ module RnBinds (
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn
-import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
 import RnTypes        ( rnHsSigType, rnLHsType, checkPrecMatch)
@@ -458,7 +457,7 @@ rnBind :: (Name -> [Name])		-- Signature tyvar function
 rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
                                    , pat_rhs = grhss 
                                       -- pat fvs were stored in bind_fvs
-                                      -- after processing the LHS          
+                                      -- after processing the LHS
                                    , bind_fvs = pat_fvs }))
   = setSrcSpan loc $ 
     do	{ let bndrs = collectPatBinders pat
@@ -478,7 +477,7 @@ rnBind sig_fn trim
                             , fun_infix = is_infix 
                             , fun_matches = matches })) 
        -- invariant: no free vars here when it's a FunBind
-  = setSrcSpan loc $ 
+  = setSrcSpan loc $
     do	{ let plain_name = unLoc name
 
 	; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
@@ -586,23 +585,33 @@ a binder.
 \begin{code}
 rnMethodBinds :: Name			-- Class name
 	      -> (Name -> [Name])	-- Signature tyvar function
-	      -> [Name]			-- Names for generic type variables
 	      -> LHsBinds RdrName
 	      -> RnM (LHsBinds Name, FreeVars)
 
-rnMethodBinds cls sig_fn gen_tyvars binds
-  = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+rnMethodBinds cls sig_fn binds
+  = do { checkDupRdrNames meth_names
+	     -- Check that the same method is not given twice in the
+	     -- same instance decl	instance C T where
+	     --			      f x = ...
+	     --			      g y = ...
+	     --			      f x = ...
+	     -- We must use checkDupRdrNames because the Name of the
+	     -- method is the Name of the class selector, whose SrcSpan
+	     -- points to the class declaration; and we use rnMethodBinds
+	     -- for instance decls too
+
+       ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
   where 
+    meth_names  = collectMethodBinders binds
     do_one (binds,fvs) bind 
-       = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
+       = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
 	    ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
 
 rnMethodBind :: Name
 	      -> (Name -> [Name])
-	      -> [Name]
 	      -> LHsBindLR RdrName RdrName
 	      -> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars 
+rnMethodBind cls sig_fn 
              (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
 				  , fun_matches = MatchGroup matches _ }))
   = setSrcSpan loc $ do
@@ -611,7 +620,7 @@ rnMethodBind cls sig_fn gen_tyvars
         -- We use the selector name as the binder
 
     (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-                          mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
+                          mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
     let new_group = MatchGroup new_matches placeHolderType
 
     when is_infix $ checkPrecMatch plain_name new_group
@@ -620,24 +629,13 @@ rnMethodBind cls sig_fn gen_tyvars
                                  , bind_fvs    = fvs })),
              fvs `addOneFV` plain_name)
         -- The 'fvs' field isn't used for method binds
-  where
-	-- Truly gruesome; bring into scope the correct members of the generic 
-	-- type variables.  See comments in RnSource.rnSourceDecl(ClassDecl)
-    rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
-	= extendTyVarEnvFVRn gen_tvs 	$
-	  rnMatch info match
-	where
-	  tvs     = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
-	  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
-
-    rn_match info match = rnMatch info match
 
 -- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
     addErrAt loc (methodBindErr bind)
     return (emptyBag, emptyFVs)
 
-rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
 \end{code}
 
 
@@ -668,7 +666,12 @@ renameSigs mb_names ok_sig sigs
 	  	-- Check for duplicates on RdrName version, 
 		-- because renamed version has unboundName for
 		-- not-in-scope binders, which gives bogus dup-sig errors
-
+		-- NB: in a class decl, a 'generic' sig is not considered 
+		--     equal to an ordinary sig, so we allow, say
+		--     	     class C a where
+		--	       op :: a -> a
+ 		--             default op :: Eq a => a -> a
+		
 	; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
 
 	; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
@@ -695,6 +698,13 @@ renameSig mb_names sig@(TypeSig v ty)
 	; new_ty <- rnHsSigType (quotes (ppr v)) ty
 	; return (TypeSig new_v new_ty) }
 
+renameSig mb_names sig@(GenericSig v ty)
+  = do	{ defaultSigs_on <- xoptM Opt_DefaultSignatures
+        ; unless defaultSigs_on (addErr (defaultSigErr sig))
+        ; new_v <- lookupSigOccRn mb_names sig v
+	; new_ty <- rnHsSigType (quotes (ppr v)) ty
+	; return (GenericSig new_v new_ty) }
+
 renameSig _ (SpecInstSig ty)
   = do	{ new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
 	; return (SpecInstSig new_ty) }
@@ -789,9 +799,9 @@ rnGRHS' ctxt (GRHS guards rhs)
 	-- Standard Haskell 1.4 guards are just a single boolean
 	-- expression, rather than a list of qualifiers as in the
 	-- Glasgow extension
-    is_standard_guard []                     = True
-    is_standard_guard [L _ (ExprStmt _ _ _)] = True
-    is_standard_guard _                      = False
+    is_standard_guard []                       = True
+    is_standard_guard [L _ (ExprStmt _ _ _ _)] = True
+    is_standard_guard _                        = False
 \end{code}
 
 %************************************************************************
@@ -816,6 +826,11 @@ misplacedSigErr (L loc sig)
   = addErrAt loc $
     sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
 
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+                              2 (ppr sig)
+                         , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ] 
+
 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
 methodBindErr mbind
  =  hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
@@ -830,4 +845,5 @@ nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
 nonStdGuardErr guards
   = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
        4 (interpp'SP guards)
+
 \end{code}
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 1b7eef0..9b1f08e 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -41,7 +41,7 @@ import RdrName
 import LoadIface	( loadInterfaceForName )
 import UniqSet
 import Data.List
-import Util		( isSingleton )
+import Util		( isSingleton, snocView )
 import ListSetOps	( removeDups )
 import Outputable
 import SrcLoc
@@ -247,10 +247,9 @@ rnExpr (HsLet binds expr)
     rnLExpr expr			 `thenM` \ (expr',fvExpr) ->
     return (HsLet binds' expr', fvExpr)
 
-rnExpr (HsDo do_or_lc stmts body _)
-  = do  { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
-				    rnLExpr body
-	; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
+rnExpr (HsDo do_or_lc stmts _)
+  = do 	{ ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
+	; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
 
 rnExpr (ExplicitList _ exps)
   = rnExprs exps		 	`thenM` \ (exps', fvs) ->
@@ -464,9 +463,9 @@ convertOpFormsCmd (HsIf f exp c1 c2)
 convertOpFormsCmd (HsLet binds cmd)
   = HsLet binds (convertOpFormsLCmd cmd)
 
-convertOpFormsCmd (HsDo ctxt stmts body ty)
-  = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
-	      (convertOpFormsLCmd body) ty
+convertOpFormsCmd (HsDo DoExpr stmts ty)
+  = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
+    -- Mark the HsDo as begin the body of an arrow command
 
 -- Anything else is unchanged.  This includes HsArrForm (already done),
 -- things with no sub-commands, and illegal commands (which will be
@@ -476,8 +475,8 @@ convertOpFormsCmd c = c
 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 convertOpFormsStmt (BindStmt pat cmd _ _)
   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
-convertOpFormsStmt (ExprStmt cmd _ _)
-  = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (ExprStmt cmd _ _ _)
+  = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
 convertOpFormsStmt stmt = stmt
@@ -518,14 +517,10 @@ methodNamesCmd (HsPar c) = methodNamesLCmd c
 methodNamesCmd (HsIf _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
-methodNamesCmd (HsLet _ c) = methodNamesLCmd c
-
-methodNamesCmd (HsDo _ stmts body _) 
-  = methodNamesStmts stmts `plusFV` methodNamesLCmd body
-
-methodNamesCmd (HsApp c _) = methodNamesLCmd c
-
-methodNamesCmd (HsLam match) = methodNamesMatch match
+methodNamesCmd (HsLet _ c)      = methodNamesLCmd c
+methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts 
+methodNamesCmd (HsApp c _)      = methodNamesLCmd c
+methodNamesCmd (HsLam match)    = methodNamesMatch match
 
 methodNamesCmd (HsCase _ matches)
   = methodNamesMatch matches `addOneFV` choiceAName
@@ -561,14 +556,14 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
 methodNamesLStmt = methodNamesStmt . unLoc
 
 methodNamesStmt :: StmtLR Name Name -> FreeVars
-methodNamesStmt (ExprStmt cmd _ _)               = methodNamesLCmd cmd
+methodNamesStmt (LastStmt cmd _)                 = methodNamesLCmd cmd
+methodNamesStmt (ExprStmt cmd _ _ _)             = methodNamesLCmd cmd
 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
 methodNamesStmt (LetStmt _)                      = emptyFVs
-methodNamesStmt (ParStmt _)                      = emptyFVs
-methodNamesStmt (TransformStmt {})               = emptyFVs
-methodNamesStmt (GroupStmt {})                   = emptyFVs
-   -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error 
+methodNamesStmt (ParStmt _ _ _ _)                = emptyFVs
+methodNamesStmt (TransStmt {})                   = emptyFVs
+   -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error 
    -- here so we just do what's convenient
 \end{code}
 
@@ -611,14 +606,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 
 \begin{code}
 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rnBracket (VarBr n) = do { name <- lookupOccRn n
-			 ; this_mod <- getModule
-			 ; unless (nameIsLocalOrFrom this_mod name) $	-- Reason: deprecation checking asumes the
-			   do { _ <- loadInterfaceForName msg name	-- home interface is loaded, and this is the
-			      ; return () }				-- only way that is going to happen
-			 ; return (VarBr name, unitFV name) }
-		    where
-		      msg = ptext (sLit "Need interface for Template Haskell quoted Name")
+rnBracket (VarBr n) 
+  = do { name <- lookupOccRn n
+       ; this_mod <- getModule
+       ; unless (nameIsLocalOrFrom this_mod name) $  -- Reason: deprecation checking assumes
+         do { _ <- loadInterfaceForName msg name     -- the home interface is loaded, and
+            ; return () }			     -- this is the only way that is going
+	      	     				     -- to happen
+       ; return (VarBr name, unitFV name) }
+  where
+    msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 
 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 			 ; return (ExpBr e', fvs) }
@@ -648,7 +645,8 @@ rnBracket (DecBrL decls)
 			      rnSrcDecls group      
 
 	      -- Discard the tcg_env; it contains only extra info about fixity
-        ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
+        ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ 
+                   ppr (duUses (tcg_dus tcg_env))))
 	; return (DecBrG group', duUses (tcg_dus tcg_env)) }
 
 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
@@ -662,44 +660,74 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 
 \begin{code}
 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
-	      -> ([Name] -> RnM (thing, FreeVars))
-	      -> RnM (([LStmt Name], thing), FreeVars)	
+	-> ([Name] -> RnM (thing, FreeVars))
+	-> RnM (([LStmt Name], thing), FreeVars)	
 -- Variables bound by the Stmts, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
---
--- Renaming a single RecStmt can give a sequence of smaller Stmts
 
-rnStmts _ [] thing_inside
-  = do { (res, fvs) <- thing_inside []
-       ; return (([], res), fvs) }
+rnStmts ctxt [] thing_inside
+  = do { checkEmptyStmts ctxt
+       ; (thing, fvs) <- thing_inside []
+       ; return (([], thing), fvs) }
+
+rnStmts MDoExpr stmts thing_inside    -- Deal with mdo
+  = -- Behave like do { rec { ...all but last... }; last }
+    do { ((stmts1, (stmts2, thing)), fvs) 
+    	   <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
+    	      do { last_stmt' <- checkLastStmt MDoExpr last_stmt
+    	         ; rnStmt MDoExpr last_stmt' thing_inside }
+	; return (((stmts1 ++ stmts2), thing), fvs) }
+  where
+    Just (all_but_last, last_stmt) = snocView stmts
+
+rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
+  | null lstmts
+  = setSrcSpan loc $
+    do { lstmt' <- checkLastStmt ctxt lstmt
+       ; rnStmt ctxt lstmt' thing_inside }
 
-rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+  | otherwise
   = do { ((stmts1, (stmts2, thing)), fvs) 
-            <- setSrcSpan loc           $
-               rnStmt ctxt stmt         $ \ bndrs1 ->
-               rnStmts ctxt stmts $ \ bndrs2 ->
-               thing_inside (bndrs1 ++ bndrs2)
+            <- setSrcSpan loc                         $
+               do { checkStmt ctxt lstmt
+                  ; rnStmt ctxt lstmt    $ \ bndrs1 ->
+                    rnStmts ctxt lstmts  $ \ bndrs2 ->
+                    thing_inside (bndrs1 ++ bndrs2) }
 	; return (((stmts1 ++ stmts2), thing), fvs) }
 
-
-rnStmt :: HsStmtContext Name -> LStmt RdrName
+----------------------
+rnStmt :: HsStmtContext Name 
+       -> LStmt RdrName
        -> ([Name] -> RnM (thing, FreeVars))
        -> RnM (([LStmt Name], thing), FreeVars)
 -- Variables bound by the Stmt, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
 
-rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
+rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
   = do	{ (expr', fv_expr) <- rnLExpr expr
-	; (then_op, fvs1)  <- lookupSyntaxName thenMName
-	; (thing, fvs2)    <- thing_inside []
-	; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
-		  fv_expr `plusFV` fvs1 `plusFV` fvs2) }
+	; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName
+	; (thing,  fvs3)   <- thing_inside []
+	; return (([L loc (LastStmt expr' ret_op)], thing),
+		  fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
+  = do	{ (expr', fv_expr) <- rnLExpr expr
+	; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
+	; (guard_op, fvs2) <- if isListCompExpr ctxt
+                              then lookupStmtName ctxt guardMName
+			      else return (noSyntaxExpr, emptyFVs)
+			      -- Only list/parr/monad comprehensions use 'guard'
+			      -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
+			      -- Here "gd" is a guard
+	; (thing, fvs3)    <- thing_inside []
+	; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
+		  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 
 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
   = do	{ (expr', fv_expr) <- rnLExpr expr
 		-- The binders do not scope over the expression
-	; (bind_op, fvs1) <- lookupSyntaxName bindMName
-	; (fail_op, fvs2) <- lookupSyntaxName failMName
+	; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+	; (fail_op, fvs2) <- lookupStmtName ctxt failMName
 	; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 	{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
 	; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
@@ -707,15 +735,13 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 	-- but it does not matter because the names are unique
 
-rnStmt ctxt (L loc (LetStmt binds)) thing_inside 
-  = do	{ checkLetStmt ctxt binds
-	; rnLocalBindsAndThen binds $ \binds' -> do
+rnStmt _ (L loc (LetStmt binds)) thing_inside 
+  = do	{ rnLocalBindsAndThen binds $ \binds' -> do
 	{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 
 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
-  = do	{ checkRecStmt ctxt
-
+  = do	{ 
 	-- Step1: Bring all the binders of the mdo into scope
 	-- (Remember that this also removes the binders from the
 	-- finally-returned free-vars.)
@@ -730,9 +756,9 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 	{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) 
                                             emptyNameSet segs
         ; (thing, fvs_later) <- thing_inside bndrs
-	; (return_op, fvs1)  <- lookupSyntaxName returnMName
-	; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
-	; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
+	; (return_op, fvs1)  <- lookupStmtName ctxt returnMName
+	; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
+	; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
 	; let
 		-- Step 2: Fill in the fwd refs.
 		-- 	   The segments are all singletons, but their fwd-ref
@@ -757,57 +783,51 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 
 	; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 
-rnStmt ctxt (L loc (ParStmt segs)) thing_inside
-  = do	{ checkParStmt ctxt
-	; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
-	; return (([L loc (ParStmt segs')], thing), fvs) }
-
-rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
-  = do { checkTransformStmt ctxt
-    
-       ; (using', fvs1) <- rnLExpr using
-
-       ; ((stmts', (by', used_bndrs, thing)), fvs2)
-             <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
-                do { (by', fvs_by) <- case by of
-                                        Nothing -> return (Nothing, emptyFVs)
-                                        Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
-                   ; (thing, fvs_thing) <- thing_inside bndrs
-                   ; let fvs        = fvs_by `plusFV` fvs_thing
-                         used_bndrs = filter (`elemNameSet` fvs) bndrs
-                         -- The paper (Fig 5) has a bug here; we must treat any free varaible of
-                         -- the "thing inside", **or of the by-expression**, as used
-                   ; return ((by', used_bndrs, thing), fvs) }
-
-       ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), 
-                 fvs1 `plusFV` fvs2) }
-        
-rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
-  = do { checkTransformStmt ctxt
-    
-         -- Rename the 'using' expression in the context before the transform is begun
-       ; (using', fvs1) <- case using of
-                             Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
-			     Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
-                                           ; return (Right e', fvs) }
+rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
+  = do	{ (mzip_op, fvs1)   <- lookupStmtName ctxt mzipName
+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+	; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
+	; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+                              , trS_using = using })) thing_inside
+  = do { -- Rename the 'using' expression in the context before the transform is begun
+         (using', fvs1) <- case form of
+                             GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
+                                              ; return (noLoc e, fvs) }
+			     _          -> rnLExpr using
 
          -- Rename the stmts and the 'by' expression
 	 -- Keep track of the variables mentioned in the 'by' expression
        ; ((stmts', (by', used_bndrs, thing)), fvs2) 
-             <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+             <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
                    ; (thing, fvs_thing) <- thing_inside bndrs
                    ; let fvs = fvs_by `plusFV` fvs_thing
                          used_bndrs = filter (`elemNameSet` fvs) bndrs
+                         -- The paper (Fig 5) has a bug here; we must treat any free varaible
+                         -- of the "thing inside", **or of the by-expression**, as used
                    ; return ((by', used_bndrs, thing), fvs) }
 
-       ; let all_fvs  = fvs1 `plusFV` fvs2 
+       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
+       ; (fmap_op,   fvs5) <- case form of
+                                ThenForm -> return (noSyntaxExpr, emptyFVs)
+                                _        -> lookupStmtName ctxt fmapName
+
+       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3 
+                             `plusFV` fvs4 `plusFV` fvs5
              bndr_map = used_bndrs `zip` used_bndrs
-	     -- See Note [GroupStmt binder map] in HsExpr
+	     -- See Note [TransStmt binder map] in HsExpr
 
        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
-       ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
-
+       ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+                                    , trS_by = by', trS_using = using', trS_form = form
+                                    , trS_ret = return_op, trS_bind = bind_op
+                                    , trS_fmap = fmap_op })], thing), all_fvs) }
 
 type ParSeg id = ([LStmt id], [id])	   -- The Names are bound by the Stmts
 
@@ -843,6 +863,27 @@ rnParallelStmts ctxt segs thing_inside
     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
                     <+> quotes (ppr (head vs)))
+
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
+-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+lookupStmtName ctxt n 
+  = case ctxt of
+      ListComp        -> not_rebindable
+      PArrComp        -> not_rebindable
+      ArrowExpr       -> not_rebindable
+      PatGuard {}     -> not_rebindable
+
+      DoExpr          -> rebindable
+      MDoExpr         -> rebindable
+      MonadComp       -> rebindable
+      GhciStmt        -> rebindable   -- I suppose?
+
+      ParStmtCtxt   c -> lookupStmtName c n	-- Look inside to
+      TransStmtCtxt c -> lookupStmtName c n	-- the parent context
+  where
+    rebindable     = lookupSyntaxName n
+    not_rebindable = return (HsVar n, emptyFVs)
 \end{code}
 
 Note [Renaming parallel Stmts]
@@ -924,9 +965,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv
                    -- so we don't bother to compute it accurately in the other cases
                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 
-rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), 
-                                                       -- this is actually correct
-                                                       emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) 
+  = return [(L loc (ExprStmt expr a b c), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) 
+  = return [(L loc (LastStmt expr a), emptyFVs)]
 
 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) 
   = do 
@@ -949,13 +992,10 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))	-- Flatten Rec inside Rec
     = rn_rec_stmts_lhs fix_env stmts
 
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))	-- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt" (ppr stmt)
-  
-rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {}))	-- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _))	-- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt" (ppr stmt)
   
-rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))	-- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))	-- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt" (ppr stmt)
 
 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
@@ -980,11 +1020,17 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt
 	-- Rename a Stmt that is inside a RecStmt (or mdo)
 	-- Assumes all binders are already in scope
 	-- Turns each stmt into a singleton Stmt
-rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
+rn_rec_stmt _ (L loc (LastStmt expr _)) _
+  = do	{ (expr', fv_expr) <- rnLExpr expr
+	; (ret_op, fvs1)   <- lookupSyntaxName returnMName
+	; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+                   L loc (LastStmt expr' ret_op))] }
+
+rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
   = rnLExpr expr `thenM` \ (expr', fvs) ->
     lookupSyntaxName thenMName	`thenM` \ (then_op, fvs1) ->
     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
-	      L loc (ExprStmt expr' then_op placeHolderType))]
+	      L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
 
 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
   = rnLExpr expr		`thenM` \ (expr', fv_expr) ->
@@ -1014,11 +1060,8 @@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _	-- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
 
-rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _	-- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
-
-rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _	-- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
+rn_rec_stmt _ stmt@(L _ (TransStmt {})) _	-- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
 
 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
@@ -1164,44 +1207,151 @@ program.
 %************************************************************************
 
 \begin{code}
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt 
+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
 
----------------------- 
--- Checking when a particular Stmt is ok
-checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
-checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-checkLetStmt _ctxt 	     _binds	       = return ()
-  	-- We do not allow implicit-parameter bindings in a parallel
-	-- list comprehension.  I'm not sure what it might mean.
+okEmpty :: HsStmtContext a -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _             = False
 
----------
-checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt MDoExpr = return ()      -- Recursive stmt ok in 'mdo'
-checkRecStmt DoExpr  = return ()      -- and in 'do'
-checkRecStmt ctxt    = addErr msg
-  where
-    msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {})   = ptext (sLit "Empty statement group in parallel comprehension")
+emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
+emptyErr ctxt               = ptext (sLit "Empty") <+> pprStmtContext ctxt
 
----------
-checkParStmt :: HsStmtContext Name -> RnM ()
-checkParStmt _
-  = do	{ parallel_list_comp <- xoptM Opt_ParallelListComp
-	; checkErr parallel_list_comp msg }
+---------------------- 
+checkLastStmt :: HsStmtContext Name
+              -> LStmt RdrName 
+              -> RnM (LStmt RdrName)
+checkLastStmt ctxt lstmt@(L loc stmt)
+  = case ctxt of 
+      ListComp  -> check_comp
+      MonadComp -> check_comp
+      PArrComp  -> check_comp
+      ArrowExpr	-> check_do
+      DoExpr	-> check_do
+      MDoExpr   -> check_do
+      _         -> check_other
   where
-    msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
+    check_do	-- Expect ExprStmt, and change it to LastStmt
+      = case stmt of 
+          ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
+	  	   	      	     	     -- LastStmt directly (unlike the parser)
+	  _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+    last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
+                  <+> ptext (sLit "must be an expression"))
+
+    check_comp	-- Expect LastStmt; this should be enforced by the parser!
+      = case stmt of 
+          LastStmt {} -> return lstmt
+          _           -> pprPanic "checkLastStmt" (ppr lstmt)
+
+    check_other	-- Behave just as if this wasn't the last stmt
+      = do { checkStmt ctxt lstmt; return lstmt }
 
----------
-checkTransformStmt :: HsStmtContext Name -> RnM ()
-checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
-			     -- desugarer will break when we come to operate on a parallel array
-  = do	{ transform_list_comp <- xoptM Opt_TransformListComp
-	; checkErr transform_list_comp msg }
-  where
-    msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
-checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt	-- Ok to nest inside a parallel comprehension
-checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt	-- Ok to nest inside a parallel comprehension
-checkTransformStmt ctxt = addErr msg
+-- Checking when a particular Stmt is ok
+checkStmt :: HsStmtContext Name
+          -> LStmt RdrName 
+          -> RnM ()
+checkStmt ctxt (L _ stmt)
+  = do { dflags <- getDOpts
+       ; case okStmt dflags ctxt stmt of 
+           Nothing    -> return ()
+           Just extra -> addErr (msg $$ extra) }
   where
-    msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
+   msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
+             , ptext (sLit "in") <+> pprAStmtContext ctxt ]
+
+pprStmtCat :: Stmt a -> SDoc
+pprStmtCat (TransStmt {})     = ptext (sLit "transform")
+pprStmtCat (LastStmt {})      = ptext (sLit "return expression")
+pprStmtCat (ExprStmt {})      = ptext (sLit "exprssion")
+pprStmtCat (BindStmt {})      = ptext (sLit "binding")
+pprStmtCat (LetStmt {})       = ptext (sLit "let")
+pprStmtCat (RecStmt {})       = ptext (sLit "rec")
+pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
+
+------------
+isOK, notOK :: Maybe SDoc
+isOK  = Nothing
+notOK = Just empty
+
+okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+   :: DynFlags -> HsStmtContext Name
+   -> Stmt RdrName -> Maybe SDoc
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to an generic error message
+
+okStmt dflags ctxt stmt 
+  = case ctxt of
+      PatGuard {}      	 -> okPatGuardStmt stmt
+      ParStmtCtxt ctxt 	 -> okParStmt  dflags ctxt stmt
+      DoExpr           	 -> okDoStmt   dflags ctxt stmt
+      MDoExpr          	 -> okDoStmt   dflags ctxt stmt
+      ArrowExpr        	 -> okDoStmt   dflags ctxt stmt
+      GhciStmt         	 -> okDoStmt   dflags ctxt stmt
+      ListComp         	 -> okCompStmt dflags ctxt stmt
+      MonadComp        	 -> okCompStmt dflags ctxt stmt
+      PArrComp         	 -> okPArrStmt dflags ctxt stmt
+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+
+-------------
+okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
+okPatGuardStmt stmt
+  = case stmt of
+      ExprStmt {} -> isOK
+      BindStmt {} -> isOK
+      LetStmt {}  -> isOK
+      _           -> notOK
+
+-------------
+okParStmt dflags ctxt stmt
+  = case stmt of
+      LetStmt (HsIPBinds {}) -> notOK
+      _                      -> okStmt dflags ctxt stmt
+
+----------------
+okDoStmt dflags ctxt stmt
+  = case stmt of
+       RecStmt {}
+         | Opt_DoRec `xopt` dflags -> isOK
+         | ArrowExpr <- ctxt       -> isOK	-- Arrows allows 'rec'
+         | otherwise               -> Just (ptext (sLit "Use -XDoRec"))
+       BindStmt {} -> isOK
+       LetStmt {}  -> isOK
+       ExprStmt {} -> isOK
+       _           -> notOK
+
+----------------
+okCompStmt dflags _ stmt
+  = case stmt of
+       BindStmt {} -> isOK
+       LetStmt {}  -> isOK
+       ExprStmt {} -> isOK
+       ParStmt {} 
+         | Opt_ParallelListComp `xopt` dflags -> isOK
+         | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+       TransStmt {} 
+         | Opt_TransformListComp `xopt` dflags -> isOK
+         | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+       RecStmt {}  -> notOK
+       LastStmt {} -> notOK  -- Should not happen (dealt with by checkLastStmt)
+
+----------------
+okPArrStmt dflags _ stmt
+  = case stmt of
+       BindStmt {} -> isOK
+       LetStmt {}  -> isOK
+       ExprStmt {} -> isOK
+       ParStmt {} 
+         | Opt_ParallelListComp `xopt` dflags -> isOK
+         | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+       TransStmt {} -> notOK
+       RecStmt {}   -> notOK
+       LastStmt {}  -> notOK  -- Should not happen (dealt with by checkLastStmt)
 
 ---------
 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 535aca2..b958f9d 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -11,9 +11,7 @@ module RnHsSyn(
         extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
 
         -- Free variables
-        hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs,
-
-        maybeGenericMatch
+        hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
   ) where
 
 #include "HsVersions.h"
@@ -69,7 +67,6 @@ extractHsTyNames ty
     get (HsParTy ty)           = getl ty
     get (HsBangTy _ ty)        = getl ty
     get (HsRecTy flds)         = extractHsTyNames_s (map cd_fld_type flds)
-    get (HsNumTy _)            = emptyNameSet
     get (HsTyVar tv)           = unitNameSet tv
     get (HsSpliceTy _ fvs _)   = fvs
     get (HsQuasiQuoteTy {})    = emptyNameSet
@@ -123,10 +120,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars
 hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
 
 hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty)   = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
-hsSigFVs _                = emptyFVs
+hsSigFVs (TypeSig _ ty)    = extractHsTyNames ty
+hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
+hsSigFVs (SpecInstSig ty)  = extractHsTyNames ty
+hsSigFVs (SpecSig _ ty _)  = extractHsTyNames ty
+hsSigFVs _                 = emptyFVs
 
 ----------------
 conDeclFVs :: LConDecl Name -> FreeVars
@@ -147,24 +145,3 @@ conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details))
 bangTyFVs :: LHsType Name -> FreeVars
 bangTyFVs bty = extractHsTyNames (getBangType bty)
 \end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{A few functions on generic defintions
-%*                                                                      *
-%************************************************************************
-
-These functions on generics are defined over Matches Name, which is
-why they are here and not in HsMatches.
-
-\begin{code}
-maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name)
-  -- Tells whether a Match is for a generic definition
-  -- and extract the type from a generic match and put it at the front
-
-maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss))
-  = Just (ty, L loc (Match pats sig_ty grhss))
-
-maybeGenericMatch _ = Nothing
-\end{code}
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 3a20ac4..46058c4 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -18,7 +18,7 @@ import HsSyn
 import TcEnv            ( isBrackStage )
 import RnEnv
 import RnHsDoc          ( rnHsDoc )
-import IfaceEnv         ( ifaceExportNames )
+import IfaceEnv		( ifaceExportNames )
 import LoadIface        ( loadSrcInterface )
 import TcRnMonad
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 76be451..844a1f9 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -367,10 +367,6 @@ rnPatAndThen mk (TuplePat pats boxed _)
        ; pats' <- rnLPatsAndThen mk pats
        ; return (TuplePat pats' boxed placeHolderType) }
 
-rnPatAndThen _ (TypePat ty)
-  = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty
-       ; return (TypePat ty') }
-
 #ifndef GHCI
 rnPatAndThen _ p@(QuasiQuotePat {}) 
   = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 725baeb..54dc378 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -17,14 +17,14 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
 
 import HsSyn
 import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
-import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
+import RdrHsSyn		( extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
 import RnBinds		( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
                                 makeMiniFixityEnv)
 import RnEnv		( lookupLocalDataTcNames, lookupLocatedOccRn,
 			  lookupTopBndrRn, lookupLocatedTopBndrRn,
-			  lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
+			  lookupOccRn, bindLocalNamesFV,
 			  bindLocatedLocalsFV, bindPatSigTyVarsFV,
 			  bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
 			  bindLocalNames, checkDupRdrNames, mapFvRn
@@ -443,24 +443,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the bindings are for the right class
     let
-	meth_names  = collectMethodBinders mbinds
 	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
     in
-    checkDupRdrNames meth_names 	`thenM_`
-	-- Check that the same method is not given twice in the
-	-- same instance decl	instance C T where
-	--			      f x = ...
-	--			      g y = ...
-	--			      f x = ...
-	-- We must use checkDupRdrNames because the Name of the
-	-- method is the Name of the class selector, whose SrcSpan
-	-- points to the class declaration
-
     extendTyVarEnvForMethodBinds inst_tyvars (		
 	-- (Slightly strangely) the forall-d tyvars scope over
 	-- the method bindings too
 	rnMethodBinds cls (\_ -> []) 	-- No scoped tyvars
-		      [] mbinds
+		      mbinds
     )						`thenM` \ (mbinds', meth_fvs) ->
 	-- Rename the associated types
 	-- The typechecker (not the renamer) checks that all 
@@ -826,15 +815,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 	-- we want to name both "x" tyvars with the same unique, so that they are
 	-- easy to group together in the typechecker.  
 	; (mbinds', meth_fvs) 
-	    <- extendTyVarEnvForMethodBinds tyvars' $ do
-	    { name_env <- getLocalRdrEnv
-	    ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
-	    		 		         not (unLoc tv `elemLocalRdrEnv` name_env) ]
+	    <- extendTyVarEnvForMethodBinds tyvars' $
 		-- No need to check for duplicate method signatures
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
 		-- and the methods are already in scope
-	    ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
-	    ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+	         rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
 
   -- Haddock docs 
 	; docs' <- mapM (wrapLocM rnDocDecl) docs
@@ -1252,4 +1237,4 @@ add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 8405e8c..31382c2 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -31,7 +31,7 @@ import RnEnv
 import TcRnMonad
 import RdrName
 import PrelNames
-import TypeRep		( funTyConName )
+import TysPrim          ( funTyConName )
 import Name
 import SrcLoc
 import NameSet
@@ -139,13 +139,6 @@ rnHsType doc (HsRecTy flds)
   = do { flds' <- rnConDeclFields doc flds
        ; return (HsRecTy flds') }
 
-rnHsType _ (HsNumTy i)
-  | i == 1    = return (HsNumTy i)
-  | otherwise = addErr err_msg >> return (HsNumTy i)
-  where
-    err_msg = ptext (sLit "Only unit numeric type pattern is valid")
-			   
-
 rnHsType doc (HsFunTy ty1 ty2) = do
     ty1' <- rnLHsType doc ty1
 	-- Might find a for-all as the arg of a function type
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 523431f..5bec8f0 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -207,6 +207,7 @@ do_one env (id, rhs)
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
 tryForCSE _   (Type t) = Type t
+tryForCSE _   (Coercion c) = Coercion c
 tryForCSE env expr     = case lookupCSEnv env expr' of
 			    Just smaller_expr -> smaller_expr
  			    Nothing  	      -> expr'
@@ -215,6 +216,7 @@ tryForCSE env expr     = case lookupCSEnv env expr' of
 
 cseExpr :: CSEnv -> CoreExpr -> CoreExpr
 cseExpr _   (Type t)               = Type t
+cseExpr _   (Coercion co)          = Coercion co
 cseExpr _   (Lit lit)              = Lit lit
 cseExpr env (Var v)		   = Var (lookupSubst env v)
 cseExpr env (App f a)        	   = App (cseExpr env f) (tryForCSE env a)
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index c527d82..6ddcff2 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -370,13 +370,21 @@ getCoreToDo dflags
 
     simpl_phase phase names iter
       = CoreDoPasses
-          [ maybe_strictness_before phase
+      $   [ maybe_strictness_before phase
           , CoreDoSimplify iter
                 (base_mode { sm_phase = Phase phase
                            , sm_names = names })
 
-          , maybe_rule_check (Phase phase)
-          ]
+          , maybe_rule_check (Phase phase) ]
+
+          -- Vectorisation can introduce a fair few common sub expressions involving 
+          --  DPH primitives. For example, see the Reverse test from dph-examples.
+          --  We need to eliminate these common sub expressions before their definitions
+          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings, 
+          --  so we also run simpl_gently to inline them.
+      ++  (if dopt Opt_Vectorise dflags && phase == 3
+	    then [CoreCSE, simpl_gently]
+	    else [])
 
     vectorisation
       = runWhen (dopt Opt_Vectorise dflags) $
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index b9f44c9..48daf78 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -126,14 +126,15 @@ fiExpr :: FloatingBinds		-- Binds we're trying to drop
        -> CoreExprWithFVs	-- Input expr
        -> CoreExpr		-- Result
 
-fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
-
-fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
-				 Type ty
-fiExpr to_drop (_, AnnCast expr co)
-  = Cast (fiExpr to_drop expr) co	-- Just float in past coercion
-
-fiExpr _ (_, AnnLit lit) = Lit lit
+fiExpr to_drop (_, AnnLit lit)     = ASSERT( null to_drop ) Lit lit
+fiExpr to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty
+fiExpr to_drop (_, AnnVar v)       = mkCoLets' to_drop (Var v)
+fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co)
+fiExpr to_drop (_, AnnCast expr (fvs_co, co))
+  = mkCoLets' (drop_here ++ co_drop) $
+    Cast (fiExpr e_drop expr) co
+  where
+    [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop
 \end{code}
 
 Applications: we do float inside applications, mainly because we
@@ -198,7 +199,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
 
     go seen_one_shot_id [] = seen_one_shot_id
     go seen_one_shot_id (b:bs)
-      | isTyCoVar       b = go seen_one_shot_id bs
+      | isTyVar       b = go seen_one_shot_id bs
       | isOneShotBndr b = go True bs
       | otherwise       = False	 -- Give up at a non-one-shot Id
 \end{code}
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index 2a51a21..e5db7d9 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -225,6 +225,7 @@ floatRhs lvl arg	-- Used for nested non-rec rhss, and fn args
 -----------------
 floatExpr _ (Var v)   = (zeroStats, emptyFloats, Var v)
 floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co)
 floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
 	  
 floatExpr lvl (App e a)
diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 2b19062..fe1f758 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -199,6 +199,7 @@ libCase :: LibCaseEnv
 libCase env (Var v)             = libCaseId env v
 libCase _   (Lit lit)           = Lit lit
 libCase _   (Type ty)           = Type ty
+libCase _   (Coercion co)       = Coercion co
 libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
 libCase env (Note note body)    = Note note (libCase env body)
 libCase env (Cast e co)         = Cast (libCase env e) co
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 7692b62..ba7d192 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -19,17 +19,18 @@ module OccurAnal (
 
 import CoreSyn
 import CoreFVs
-import Type		( tyVarsOfType )
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
-import Coercion		( CoercionI(..), mkSymCoI )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
 import Id
 import NameEnv
 import NameSet
 import Name		( Name, localiseName )
 import BasicTypes
+import Coercion
+
 import VarSet
 import VarEnv
-import Var              ( varUnique )
+import Var
+
 import Maybes           ( orElse )
 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
 import PrelNames        ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
@@ -97,7 +98,7 @@ occAnalBind :: OccEnv 		-- The incoming OccEnv
                 [CoreBind])
 
 occAnalBind env _ (NonRec binder rhs) body_usage
-  | isTyCoVar binder			-- A type let; we don't gather usage info
+  | isTyVar binder	-- A type let; we don't gather usage info
   = (body_usage, [NonRec binder rhs])
 
   | not (binder `usedIn` body_usage)    -- It's not mentioned
@@ -381,7 +382,7 @@ occAnalBind _ env (Rec pairs) body_usage
     
     make_node (bndr, rhs)
         = (details, varUnique bndr, keysUFM out_edges)
-	where
+        where
           details = ND { nd_bndr = bndr, nd_rhs = rhs'
                        , nd_uds = rhs_usage3, nd_inl = inl_fvs}
 
@@ -872,33 +873,27 @@ occAnal :: OccEnv
         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
             CoreExpr)
 
-occAnal _   (Type t)  = (emptyDetails, Type t)
-occAnal env (Var v)   = (mkOneOcc env v False, Var v)
+occAnal _   expr@(Type _) = (emptyDetails, 	   expr)
+occAnal _   expr@(Lit _)  = (emptyDetails, 	   expr)   
+occAnal env expr@(Var v)  = (mkOneOcc env v False, expr)
     -- At one stage, I gathered the idRuleVars for v here too,
     -- which in a way is the right thing to do.
     -- But that went wrong right after specialisation, when
     -- the *occurrences* of the overloaded function didn't have any
     -- rules in them, so the *specialised* versions looked as if they
     -- weren't used at all.
-\end{code}
 
-We regard variables that occur as constructor arguments as "dangerousToDup":
-
-\begin{verbatim}
-module A where
-f x = let y = expensive x in
-      let z = (True,y) in
-      (case z of {(p,q)->q}, case z of {(p,q)->q})
-\end{verbatim}
-
-We feel free to duplicate the WHNF (True,y), but that means
-that y may be duplicated thereby.
+occAnal _ (Coercion co) 
+  = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
+	-- See Note [Gather occurrences of coercion veriables]
+\end{code}
 
-If we aren't careful we duplicate the (expensive x) call!
-Constructors are rather like lambdas in this way.
+Note [Gather occurrences of coercion veriables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather info about what coercion variables appear, so that
+we can sort them into the right place when doing dependency analysis.
 
 \begin{code}
-occAnal _   expr@(Lit _) = (emptyDetails, expr)
 \end{code}
 
 \begin{code}
@@ -914,7 +909,10 @@ occAnal env (Note note body)
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
-      (markManyIf (isRhsEnv env) usage, Cast expr' co)
+    let usage1 = markManyIf (isRhsEnv env) usage
+        usage2 = addIdOccs usage1 (coVarsOfCo co)
+          -- See Note [Gather occurrences of coercion veriables]
+    in (usage2, Cast expr' co)
         -- If we see let x = y `cast` co
         -- then mark y as 'Many' so that we don't
         -- immediately inline y again.
@@ -929,7 +927,7 @@ occAnal env app@(App _ _)
 --   (a) occurrences inside type lambdas only not marked as InsideLam
 --   (b) type variables not in environment
 
-occAnal env (Lam x body) | isTyCoVar x
+occAnal env (Lam x body) | isTyVar x
   = case occAnal env body of { (body_usage, body') ->
     (body_usage, Lam x body')
     }
@@ -1021,6 +1019,18 @@ occAnalArgs env args
 Applications are dealt with specially because we want
 the "build hack" to work.
 
+Note [Arguments of let-bound constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    f x = let y = expensive x in
+          let z = (True,y) in
+          (case z of {(p,q)->q}, case z of {(p,q)->q})
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
 \begin{code}
 occAnalApp :: OccEnv
            -> (Expr CoreBndr, [Arg CoreBndr])
@@ -1036,6 +1046,7 @@ occAnalApp env (Var fun, args)
 	  -- arguments are just variables, or trivial expressions.
 	  --
 	  -- This is the *whole point* of the isRhsEnv predicate
+	  -- See Note [Arguments of let-bound constructors]
     in
     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
   where
@@ -1146,7 +1157,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
   where
     (body_usg', tagged_bndr) = tagBinder body_usg bndr
     rhs_usg = unitVarEnv rhs_var NoOccInfo	-- We don't need exact info
-    rhs = mkCoerceI co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+    rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
 \end{code}
 
 
@@ -1355,7 +1366,7 @@ extendFvs env s
 data ProxyEnv	-- See Note [ProxyEnv]
    = PE (IdEnv	-- Domain = scrutinee variables
            (Id,                  -- The scrutinee variable again
-            [(Id,CoercionI)])) 	 -- The case binders that it maps to
+            [(Id,Coercion)])) 	 -- The case binders that it maps to
         VarSet	-- Free variables of both range and domain
 \end{code}
 
@@ -1572,7 +1583,7 @@ binder-swap unconditionally and still get occurrence analysis
 information right.
 
 \begin{code}
-extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
+extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
 -- (extendPE x co y) typically arises from 
 --		  case (x |> co) of y { ... }
 -- It extends the proxy env with the binding 
@@ -1585,7 +1596,7 @@ extendProxyEnv pe scrut co case_bndr
     env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
     single cb_co = (scrut1, [cb_co]) 
     add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
-    fvs2 = fvs1 `unionVarSet`  freeVarsCoI co
+    fvs2 = fvs1 `unionVarSet`  tyCoVarsOfCo co
 		`extendVarSet` case_bndr
 		`extendVarSet` scrut1
 
@@ -1596,7 +1607,7 @@ extendProxyEnv pe scrut co case_bndr
 	-- Also we don't want any INLINE or NOINLINE pragmas!
 
 -----------
-type ProxyBind = (Id, Id, CoercionI)
+type ProxyBind = (Id, Id, Coercion)
      -- (scrut variable, case-binder variable, coercion)
 
 getProxies :: OccEnv -> Id -> Bag ProxyBind
@@ -1607,7 +1618,7 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
   = -- pprTrace "wrapProxies" (ppr case_bndr) $
     go_fwd case_bndr
   where
-    fwd_pe :: IdEnv (Id, CoercionI)
+    fwd_pe :: IdEnv (Id, Coercion)
     fwd_pe = foldVarEnv add1 emptyVarEnv pe
            where
              add1 (x,ycos) env = foldr (add2 x) env ycos
@@ -1621,23 +1632,23 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
 
     go_fwd' case_bndr
         | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
-        = unitBag (scrut,  case_bndr, mkSymCoI co)
+        = unitBag (scrut,  case_bndr, mkSymCo co)
 	  `unionBags` go_fwd scrut
           `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
                                        , cb /= case_bndr]
         | otherwise 
         = emptyBag
 
-    lookup_bwd :: Id -> [(Id, CoercionI)]
+    lookup_bwd :: Id -> [(Id, Coercion)]
 	-- Return case_bndrs that are connected to scrut 
     lookup_bwd scrut = case lookupVarEnv pe scrut of
           		  Nothing          -> []
 	  		  Just (_, cb_cos) -> cb_cos
 
-    go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
+    go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
     go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
 
-    go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
+    go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
     go_bwd1 scrut (case_bndr, co) 
        = -- pprTrace "go_bwd1" (ppr case_bndr) $
          unitBag (case_bndr, scrut, co)
@@ -1652,9 +1663,9 @@ mkAltEnv env scrut cb
   where
     pe  = occ_proxy env
     pe' = case scrut of
-             Var v           -> extendProxyEnv pe v (IdCo (idType v)) cb
-             Cast (Var v) co -> extendProxyEnv pe v (ACo co)          cb
-	     _other          -> trimProxyEnv pe [cb]
+             Var v           -> extendProxyEnv pe v (mkReflCo (idType v)) cb
+             Cast (Var v) co -> extendProxyEnv pe v co                    cb
+             _other          -> trimProxyEnv pe [cb]
 
 -----------
 trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
@@ -1675,12 +1686,7 @@ trimProxyEnv (PE pe fvs) bndrs
     trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
 			 | otherwise = (scrut, filterOut discard cb_cos)
     discard (cb,co) = bndr_set `intersectsVarSet` 
-                      extendVarSet (freeVarsCoI co) cb
-                             
------------
-freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI (IdCo t) = tyVarsOfType t
-freeVarsCoI (ACo co) = tyVarsOfType co
+                      extendVarSet (tyCoVarsOfCo co) cb
 \end{code}
 
 
@@ -1747,7 +1753,7 @@ tagBinder usage binder
 
 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 setBinderOcc usage bndr
-  | isTyCoVar bndr    = bndr
+  | isTyVar bndr      = bndr
   | isExportedId bndr = case idOccInfo bndr of
                           NoOccInfo -> bndr
                           _         -> setIdOccInfo bndr NoOccInfo
diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs
index d398055..6118289 100644
--- a/compiler/simplCore/SAT.lhs
+++ b/compiler/simplCore/SAT.lhs
@@ -56,6 +56,7 @@ import Var
 import CoreSyn
 import CoreUtils
 import Type
+import Coercion
 import Id
 import Name
 import VarEnv
@@ -112,7 +113,7 @@ satBind (Rec pairs) interesting_ids = do
     return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
 \end{code}
 \begin{code}
-data App = VarApp Id | TypeApp Type
+data App = VarApp Id | TypeApp Type | CoApp Coercion
 data Staticness a = Static a | NotStatic
 
 type IdAppInfo = (Id, SATInfo)
@@ -133,6 +134,7 @@ pprSATInfo staticness = hcat $ map pprStaticness staticness
 pprStaticness :: Staticness App -> SDoc
 pprStaticness (Static (VarApp _))  = ptext (sLit "SV") 
 pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") 
+pprStaticness (Static (CoApp _))   = ptext (sLit "SC")
 pprStaticness NotStatic            = ptext (sLit "NS")
 
 
@@ -142,7 +144,8 @@ mergeSATInfo _  [] = []
 mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps
 mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps
 mergeSATInfo ((Static (VarApp v)):statics)  ((Static (VarApp v')):apps)  = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps
-mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `coreEqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps)     = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps
 mergeSATInfo l  r  = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ")
                                             <> ptext (sLit "Right:") <> pprSATInfo r
 
@@ -154,9 +157,9 @@ mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
 
 bindersToSATInfo :: [Id] -> SATInfo
 bindersToSATInfo vs = map (Static . binderToApp) vs
-    where binderToApp v = if isId v
-                          then VarApp v
-                          else TypeApp $ mkTyVarTy v
+    where binderToApp v | isId v    = VarApp v
+                        | isTyVar v = TypeApp $ mkTyVarTy v
+                        | otherwise = CoApp $ mkCoVarCo v
 
 finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
 finalizeApp Nothing id_sat_info = id_sat_info
@@ -195,9 +198,10 @@ satExpr (App fn arg) interesting_ids = do
             -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
             let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
             in case arg of
-                Type t -> satRemainderWithStaticness $ Static (TypeApp t)
-                Var v  -> satRemainderWithStaticness $ Static (VarApp v)
-                _      -> satRemainderWithStaticness $ NotStatic
+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)
+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)
+                _          -> satRemainderWithStaticness $ NotStatic
   where
     boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
     boring fn' sat_info_fn app_info = 
@@ -229,6 +233,9 @@ satExpr (Note note expr) interesting_ids = do
 
 satExpr ty@(Type _) _ = do
     return (ty, emptyIdSATInfo, Nothing)
+    
+satExpr co@(Coercion _) _ = do
+    return (co, emptyIdSATInfo, Nothing)
 
 satExpr (Cast expr coercion) interesting_ids = do
     (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 6871faa..21dca61 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -243,6 +243,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well.
 
 \begin{code}
 lvlExpr _ _ (  _, AnnType ty) = return (Type ty)
+lvlExpr _ _ ( _, AnnCoercion co) = return (Coercion co)
 lvlExpr _ env (_, AnnVar v)   = return (lookupVar env v)
 lvlExpr _ _   (_, AnnLit lit) = return (Lit lit)
 
@@ -287,7 +288,7 @@ lvlExpr ctxt_lvl env (_, AnnNote note expr) = do
     expr' <- lvlExpr ctxt_lvl env expr
     return (Note note expr')
 
-lvlExpr ctxt_lvl env (_, AnnCast expr co) = do
+lvlExpr ctxt_lvl env (_, AnnCast expr (_, co)) = do
     expr' <- lvlExpr ctxt_lvl env expr
     return (Cast expr' co)
 
@@ -414,7 +415,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e)
   = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
        ; return (Note n e') }
 
-lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e (_, co))
   = do	{ e' <- lvlMFE strict_ctxt ctxt_lvl env e
 	; return (Cast e' co) }
 
@@ -423,7 +424,9 @@ lvlMFE True ctxt_lvl env e@(_, AnnCase {})
   = lvlExpr ctxt_lvl env e     -- Don't share cases
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
-  |  isUnLiftedType ty			-- Can't let-bind it; see Note [Unlifted MFEs]
+  |  isUnLiftedType ty		-- Can't let-bind it; see Note [Unlifted MFEs]
+     		    		-- This includes coercions, which we don't
+				-- want to float anyway
   || notWorthFloating ann_expr abs_vars
   || not good_destination
   = 	-- Don't float it out
@@ -491,6 +494,7 @@ notWorthFloating e abs_vars
     go (_, AnnCast e _)  n = go e n
     go (_, AnnApp e arg) n 
        | (_, AnnType {}) <- arg = go e n
+       | (_, AnnCoercion {}) <- arg = go e n
        | n==0                   = False
        | is_triv arg       	= go e (n-1)
        | otherwise         	= False
@@ -500,6 +504,7 @@ notWorthFloating e abs_vars
     is_triv (_, AnnVar {})   	       	  = True	-- (ie not worth floating)
     is_triv (_, AnnCast e _) 	       	  = is_triv e
     is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
+    is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
     is_triv _                             = False     
 \end{code}
 
@@ -563,7 +568,7 @@ lvlBind :: TopLevelFlag		-- Used solely to decide whether to clone
 	-> LvlM (LevelledBind, LevelEnv)
 
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-  |  isTyCoVar bndr 		-- Don't do anything for TyVar binders
+  |  isTyVar bndr 		-- Don't do anything for TyVar binders
 				--   (simplifier gets rid of them pronto)
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
@@ -883,7 +888,7 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
 		   (False, True) -> False
 		   _    	 -> v1 <= v2	-- Same family
 
-    is_tv v = isTyCoVar v && not (isCoVar v)
+    is_tv v = isTyVar v 
 
     uniq :: [Var] -> [Var]
 	-- Remove adjacent duplicates; the sort will have brought them together
@@ -914,9 +919,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
 absVarsOf id_env v 
   | isId v    = [av2 | av1 <- lookup_avs v
 		     , av2 <- add_tyvars av1]
-  | isCoVar v = add_tyvars v
-  | otherwise = [v]
-
+  | otherwise = ASSERT( isTyVar v ) [v]
   where
     lookup_avs v = case lookupVarEnv id_env v of
 			Just (abs_vars, _) -> abs_vars
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index d9eea39..677a1e9 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -16,7 +16,7 @@ module SimplEnv (
 
 	-- Environments
 	SimplEnv(..), StaticEnv, pprSimplEnv,	-- Temp not abstract
-	mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
+        mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
 	zapSubstEnv, setSubstEnv, 
 	getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
         getSimplRules,
@@ -24,8 +24,10 @@ module SimplEnv (
 	SimplSR(..), mkContEx, substId, lookupRecBndr,
 
 	simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
- 	simplBinder, simplBinders, addBndrRules,
-	substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
+ 	simplBinder, simplBinders, addBndrRules, 
+	substExpr, substTy, substTyVar, getTvSubst, 
+	getCvSubst, substCo, substCoVar,
+	mkCoreSubst,
 
 	-- Floats
   	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -49,9 +51,10 @@ import Id
 import MkCore
 import TysWiredIn
 import qualified CoreSubst
-import qualified Type		( substTy, substTyVarBndr, substTyVar )
+import qualified Type
 import Type hiding		( substTy, substTyVarBndr, substTyVar )
-import Coercion
+import qualified Coercion
+import Coercion hiding          ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
 import BasicTypes	
 import MonadUtils
 import Outputable
@@ -107,8 +110,9 @@ data SimplEnv
         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 
 	-- The current substitution
-	seTvSubst   :: TvSubstEnv,	-- InTyVar |--> OutType
-	seIdSubst   :: SimplIdSubst,	-- InId    |--> OutExpr
+	seTvSubst   :: TvSubstEnv,	-- InTyVar   |--> OutType
+        seCvSubst   :: CvSubstEnv,      -- InTyCoVar |--> OutCoercion
+	seIdSubst   :: SimplIdSubst,	-- InId      |--> OutExpr
 
      ----------- Dynamic part of the environment -----------
      -- Dynamic in the sense of describing the setup where
@@ -143,13 +147,14 @@ data SimplSR
   = DoneEx OutExpr		-- Completed term
   | DoneId OutId		-- Completed term variable
   | ContEx TvSubstEnv	 	-- A suspended substitution
+           CvSubstEnv
 	   SimplIdSubst
 	   InExpr 	 
 
 instance Outputable SimplSR where
   ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
   ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
-  ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
+  ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
 				ppr (filter_env tv), ppr (filter_env id) -}]
 	-- where
 	-- fvs = exprFreeVars e
@@ -227,6 +232,7 @@ mkSimplEnv mode
              , seInScope = init_in_scope
              , seFloats = emptyFloats
              , seTvSubst = emptyVarEnv
+             , seCvSubst = emptyVarEnv 
              , seIdSubst = emptyVarEnv }
 	-- The top level "enclosing CC" is "SUBSUMED".
 
@@ -273,12 +279,17 @@ setEnclosingCC env cc = env {seCC = cc}
 ---------------------
 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
-  = env {seIdSubst = extendVarEnv subst var res}
+  = ASSERT2( isId var && not (isCoVar var), ppr var )
+    env {seIdSubst = extendVarEnv subst var res}
 
 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
   = env {seTvSubst = extendVarEnv subst var res}
 
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
+  = env {seCvSubst = extendVarEnv subst var res}
+
 ---------------------
 getInScope :: SimplEnv -> InScopeSet
 getInScope env = seInScope env
@@ -318,13 +329,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v
 
 ---------------------
 zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 
-setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
-setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
 
 mkContEx :: SimplEnv -> InExpr -> SimplSR
-mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
 \end{code}
 
 
@@ -503,7 +514,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 	Just (DoneId v)       -> DoneId (refine in_scope v)
 	Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
 	Just res	      -> res	-- DoneEx non-var, or ContEx
-  where
 
 	-- Get the most up-to-date thing from the in-scope set
 	-- Even though it isn't in the substitution, it may be in
@@ -549,7 +559,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- The substitution is extended only if the variable is cloned, because
 -- we *don't* need to use it to track occurrence info.
 simplBinder env bndr
-  | isTyCoVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
+  | isTyVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
 			; seqTyVar tv `seq` return (env', tv) }
   | otherwise     = do	{ let (env', id) = substIdBndr env bndr
 			; seqId id `seq` return (env', id) }
@@ -586,9 +596,17 @@ simplRecBndrs env@(SimplEnv {}) ids
 	; seqIds ids1 `seq` return env1 }
 
 ---------------
-substIdBndr :: SimplEnv 	
-	    -> InBndr 	-- Env and binder to transform
-	    -> (SimplEnv, OutBndr)
+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr env bndr
+  | isCoVar bndr  = substCoVarBndr env bndr
+  | otherwise     = substNonCoVarIdBndr env bndr
+
+---------------
+substNonCoVarIdBndr 
+   :: SimplEnv 	
+   -> InBndr 	-- Env and binder to transform
+   -> (SimplEnv, OutBndr)
 -- Clone Id if necessary, substitute its type
 -- Return an Id with its 
 --	* Type substituted
@@ -606,10 +624,10 @@ substIdBndr :: SimplEnv
 -- Similar to CoreSubst.substIdBndr, except that 
 --	the type of id_subst differs
 --	all fragile info is zapped
-
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) 
-	       old_id
-  = (env { seInScope = in_scope `extendInScopeSet` new_id, 
+substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+                    old_id
+  = ASSERT2( not (isCoVar old_id), ppr old_id )
+    (env { seInScope = in_scope `extendInScopeSet` new_id, 
 	   seIdSubst = new_subst }, new_id)
   where
     id1	   = uniqAway in_scope old_id
@@ -714,6 +732,10 @@ getTvSubst :: SimplEnv -> TvSubst
 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
   = mkTvSubst in_scope tv_env
 
+getCvSubst :: SimplEnv -> CvSubst
+getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+  = CvSubst in_scope tv_env cv_env
+
 substTy :: SimplEnv -> Type -> Type 
 substTy env ty = Type.substTy (getTvSubst env) ty
 
@@ -724,7 +746,19 @@ substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 substTyVarBndr env tv
   = case Type.substTyVarBndr (getTvSubst env) tv of
 	(TvSubst in_scope' tv_env', tv') 
-	   -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+	   -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+  = case Coercion.substCoVarBndr (getCvSubst env) cv of
+	(CvSubst in_scope' tv_env' cv_env', cv') 
+	   -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
+
+substCo :: SimplEnv -> Coercion -> Coercion
+substCo env co = Coercion.substCo (getCvSubst env) co
 
 -- When substituting in rules etc we can get CoreSubst to do the work
 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
@@ -732,19 +766,19 @@ substTyVarBndr env tv
 -- the substitutions are typically small, and laziness will avoid work in many cases.
 
 mkCoreSubst  :: SDoc -> SimplEnv -> CoreSubst.Subst
-mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
-  = mk_subst tv_env id_env
+mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
+  = mk_subst tv_env cv_env id_env
   where
-    mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
+    mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
 
-    fiddle (DoneEx e)       = e
-    fiddle (DoneId v)       = Var v
-    fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
+    fiddle (DoneEx e)          = e
+    fiddle (DoneId v)          = Var v
+    fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
     	   	      	      			-- Don't shortcut here
 
 ------------------
 substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
+substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env }) id
   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
   | otherwise	= Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 		-- The tyVarsOfType is cheaper than it looks
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7e9a010..7d5d764 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -36,6 +36,7 @@ import StaticFlags
 import CoreSyn
 import qualified CoreSubst
 import PprCore
+import DataCon	( dataConCannotMatch )
 import CoreFVs
 import CoreUtils
 import CoreArity
@@ -45,17 +46,16 @@ import Id
 import Var
 import Demand
 import SimplMonad
-import TcType	( isDictLikeTy )
 import Type	hiding( substTy )
-import Coercion ( coercionKind )
+import Coercion hiding( substCo )
 import TyCon
-import Unify	( dataConCannotMatch )
 import VarSet
 import BasicTypes
 import Util
 import MonadUtils
 import Outputable
 import FastString
+import Pair
 
 import Data.List
 \end{code}
@@ -99,6 +99,7 @@ data SimplCont
 
   | CoerceIt 		-- C `cast` co
 	OutCoercion		-- The coercion simplified
+				-- Invariant: never an identity coercion
 	SimplCont
 
   | ApplyTo  		-- C arg
@@ -208,6 +209,7 @@ contIsDupable _                          = False
 contIsTrivial :: SimplCont -> Bool
 contIsTrivial (Stop {})                   = True
 contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
+contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont
 contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
 contIsTrivial _                           = False
 
@@ -216,17 +218,19 @@ contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
 contResultType env ty cont
   = go cont ty
   where
-    subst_ty se ty = substTy (se `setInScope` env) ty
+    subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
+    subst_co se co = SimplEnv.substCo (se `setInScope` env) co
 
     go (Stop {})                      ty = ty
-    go (CoerceIt co cont)             _  = go cont (snd (coercionKind co))
+    go (CoerceIt co cont)             _  = go cont (pSnd (coercionKind co))
     go (StrictBind _ bs body se cont) _  = go cont (subst_ty se (exprType (mkLams bs body)))
     go (StrictArg ai _ cont)          _  = go cont (funResultTy (argInfoResultTy ai))
     go (Select _ _ alts se cont)      _  = go cont (subst_ty se (coreAltsType alts))
     go (ApplyTo _ arg se cont)        ty = go cont (apply_to_arg ty arg se)
 
-    apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
-    apply_to_arg ty _             _  = funResultTy ty
+    apply_to_arg ty (Type ty_arg)     se = applyTy ty (subst_ty se ty_arg)
+    apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
+    apply_to_arg ty _                 _  = funResultTy ty
 
 argInfoResultTy :: ArgInfo -> OutType
 argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
@@ -235,6 +239,7 @@ argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
 -------------------
 countValArgs :: SimplCont -> Int
 countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
 countValArgs (ApplyTo _ _        _ cont) = 1 + countValArgs cont
 countValArgs _                           = 0
 
@@ -784,6 +789,11 @@ Don't inline top-level Ids that are bottoming, even if they are used just
 once, because FloatOut has gone to some trouble to extract them out.
 Inlining them won't make the program run faster!
 
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and have a separate
+substitution, so don't inline them via the IdSubst!
+
 \begin{code}
 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 preInlineUnconditionally env top_lvl bndr rhs
@@ -791,6 +801,7 @@ preInlineUnconditionally env top_lvl bndr rhs
   | isStableUnfolding (idUnfolding bndr)     = False    -- Note [InlineRule and preInlineUnconditionally]
   | isTopLevel top_lvl && isBottomingId bndr = False	-- Note [Top-level bottoming Ids]
   | opt_SimplNoPreInlining                   = False
+  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
   | otherwise = case idOccInfo bndr of
 		  IAmDead	     	     -> True	-- Happens in ((\x.1) v)
 	  	  OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
@@ -888,6 +899,7 @@ story for now.
 postInlineUnconditionally 
     :: SimplEnv -> TopLevelFlag
     -> OutId		-- The binder (an InId would be fine too)
+       			--            (*not* a CoVar)
     -> OccInfo 		-- From the InId
     -> OutExpr
     -> Unfolding
@@ -1032,9 +1044,9 @@ mkLam _env bndrs body
       | not (any bad bndrs)
 	-- Note [Casts and lambdas]
       = do { lam <- mkLam' dflags bndrs body
-	   ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+           ; return (mkCoerce (mkPiCos bndrs co) lam) }
       where
-	co_vars  = tyVarsOfType co
+        co_vars  = tyCoVarsOfCo co
 	bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      
 
     mkLam' dflags bndrs body@(Lam {})
@@ -1048,7 +1060,7 @@ mkLam _env bndrs body
       = do { tick (EtaReduction (head bndrs))
 	   ; return etad_lam }
 
-      | otherwise 
+      | otherwise
       = return (mkLams bndrs body)
 \end{code}
 
@@ -1091,9 +1103,6 @@ because the latter is not well-kinded.
 %*									*
 %************************************************************************
 
-When we meet a let-binding we try eta-expansion.  To find the 
-arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis]
-
 \begin{code}
 tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
 -- See Note [Eta-expanding at let bindings]
@@ -1336,9 +1345,7 @@ abstractFloats main_tvs body_env body
 	   ; return (subst', (NonRec poly_id poly_rhs)) }
       where
 	rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
-	tvs_here | any isCoVar main_tvs = main_tvs	-- Note [Abstract over coercions]
-		 | otherwise 
-		 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
+	tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
 	
 		-- Abstract only over the type variables free in the rhs
 		-- wrt which the new binding is abstracted.  But the naive
@@ -1550,9 +1557,8 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
 	[con] -> 	-- It matches exactly one constructor, so fill it in
 		 do { tick (FillInCaseDefault case_bndr)
                     ; us <- getUniquesM
-                    ; let (ex_tvs, co_tvs, arg_ids) =
-                              dataConRepInstPat us con inst_tys
-                    ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
+                    ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+                    ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] }
 
 	_ -> return [(DEFAULT, [], deflt_rhs)]
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index db84c90..b187897 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -17,10 +17,9 @@ import FamInstEnv	( FamInstEnv )
 import Id
 import MkId		( seqId, realWorldPrimId )
 import MkCore		( mkImpossibleExpr )
-import Var
 import IdInfo
 import Name		( mkSystemVarName, isExternalName )
-import Coercion
+import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion	( optCoercion )
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
@@ -42,6 +41,7 @@ import Maybes           ( orElse, isNothing )
 import Data.List        ( mapAccumL )
 import Outputable
 import FastString
+import Pair
 \end{code}
 
 
@@ -369,8 +369,11 @@ simplNonRecX :: SimplEnv
              -> SimplM SimplEnv
 
 simplNonRecX env bndr new_rhs
-  | isDeadBinder bndr	-- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
-  = return env		-- 		 Here b is dead, and we avoid creating
+  | isDeadBinder bndr	-- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+  = return env		-- 		 Here c is dead, and we avoid creating
+    	   		--               the binding c = (a,b)
+  | Coercion co <- new_rhs    
+  = return (extendCvSubst env bndr co)
   | otherwise		--		 the binding b = (a,b)
   = do  { (env', bndr') <- simplBinder env bndr
         ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
@@ -438,7 +441,7 @@ That's what the 'go' loop in prepareRhs does
 prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Adds new floats to the env iff that allows us to return a good RHS
 prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
-  | (ty1, _ty2) <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
+  | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
   = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
         ; return (env', Cast rhs' co) }
@@ -626,6 +629,12 @@ completeBind :: SimplEnv
 --      * or by adding to the floats in the envt
 
 completeBind env top_lvl old_bndr new_bndr new_rhs
+ | isCoVar old_bndr
+ = case new_rhs of
+     Coercion co -> return (extendCvSubst env old_bndr co)
+     _           -> return (addNonRec env new_bndr new_rhs)
+
+ | otherwise
  = ASSERT( isId new_bndr )
    do { let old_info = idInfo old_bndr
 	    old_unf  = unfoldingInfo old_info
@@ -641,9 +650,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
       ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
 	                -- Inline and discard the binding
 	then do  { tick (PostInlineUnconditionally old_bndr)
-	         ; -- pprTrace "postInlineUnconditionally" 
-                   --         (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
-                   return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
+	         ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
 	        -- Use the substitution to make quite, quite sure that the
 	        -- substitution will happen, since we are going to discard the binding
 	else
@@ -658,7 +665,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
 
             final_id = new_bndr `setIdInfo` info3
 
-      ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
         return (addNonRec env final_id final_rhs) } }
 		-- The addNonRec adds it to the in-scope set too
 
@@ -870,18 +877,21 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont
 
 simplExprF env e cont
   = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
-    simplExprF' env e cont
+    simplExprF1 env e cont
 
-simplExprF' :: SimplEnv -> InExpr -> SimplCont
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
             -> SimplM (SimplEnv, OutExpr)
-simplExprF' env (Var v)        cont = simplVarF env v cont
-simplExprF' env (Lit lit)      cont = rebuild env (Lit lit) cont
-simplExprF' env (Note n expr)  cont = simplNote env n expr cont
-simplExprF' env (Cast body co) cont = simplCast env body co cont
-simplExprF' env (App fun arg)  cont = simplExprF env fun $
+simplExprF1 env (Var v)        cont = simplIdF env v cont
+simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
+simplExprF1 env (Note n expr)  cont = simplNote env n expr cont
+simplExprF1 env (Cast body co) cont = simplCast env body co cont
+simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont
+simplExprF1 env (Type ty)      cont = ASSERT( contIsRhsOrArg cont )
+                                      rebuild env (Type (substTy env ty)) cont
+simplExprF1 env (App fun arg)  cont = simplExprF env fun $
                                       ApplyTo NoDup arg env cont
 
-simplExprF' env expr@(Lam _ _) cont
+simplExprF1 env expr@(Lam {}) cont
   = simplLam env zapped_bndrs body cont
         -- The main issue here is under-saturated lambdas
         --   (\x1. \x2. e) arg1
@@ -898,17 +908,12 @@ simplExprF' env expr@(Lam _ _) cont
     n_args = countArgs cont
         -- NB: countArgs counts all the args (incl type args)
         -- and likewise drop counts all binders (incl type lambdas)
-        
-    zappable_bndr b = isId b && not (isOneShotBndr b)
-    zap b | isTyCoVar b = b
-          | otherwise   = zapLamIdInfo b
 
-simplExprF' env (Type ty) cont
-  = ASSERT( contIsRhsOrArg cont )
-    do  { ty' <- simplCoercion env ty
-        ; rebuild env (Type ty') cont }
+    zappable_bndr b = isId b && not (isOneShotBndr b)
+    zap b | isTyVar b = b
+          | otherwise = zapLamIdInfo b
 
-simplExprF' env (Case scrut bndr _ alts) cont
+simplExprF1 env (Case scrut bndr _ alts) cont
   | sm_case_case (getMode env)
   =     -- Simplify the scrutinee with a Select continuation
     simplExprF env scrut (Select NoDup bndr alts env cont)
@@ -920,7 +925,7 @@ simplExprF' env (Case scrut bndr _ alts) cont
                              (Select NoDup bndr alts env mkBoringStop)
         ; rebuild env case_expr' cont }
 
-simplExprF' env (Let (Rec pairs) body) cont
+simplExprF1 env (Let (Rec pairs) body) cont
   = do  { env' <- simplRecBndrs env (map fst pairs)
                 -- NB: bndrs' don't have unfoldings or rules
                 -- We add them as we go down
@@ -928,7 +933,7 @@ simplExprF' env (Let (Rec pairs) body) cont
         ; env'' <- simplRecBind env' NotTopLevel pairs
         ; simplExprF env'' body cont }
 
-simplExprF' env (Let (NonRec bndr rhs) body) cont
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
   = simplNonRecE env bndr (rhs, env) ([], body) cont
 
 ---------------------------------
@@ -941,13 +946,30 @@ simplType env ty
     new_ty = substTy env ty
 
 ---------------------------------
-simplCoercion :: SimplEnv -> InType -> SimplM OutType
--- The InType isn't *necessarily* a coercion, but it might be
--- (in a type application, say) and optCoercion is a no-op on types
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+               -> SimplM (SimplEnv, OutExpr)
+-- We are simplifying a term of form (Coercion co)
+-- Simplify the InCoercion, and then try to combine with the 
+-- context, to implememt the rule
+--     (Coercion co) |> g
+--  =  Coercion (syn (nth 0 g) ; co ; nth 1 g) 
+simplCoercionF env co cont 
+  = do { co' <- simplCoercion env co
+       ; simpl_co co' cont }
+  where
+    simpl_co co (CoerceIt g cont)
+       = simpl_co new_co cont
+     where
+       new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1
+       [g0, g1] = decomposeCo 2 g
+
+    simpl_co co cont
+       = seqCo co `seq` rebuild env (Coercion co) cont
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
 simplCoercion env co
-  = seqType new_co `seq` return new_co
-  where 
-    new_co = optCoercion (getTvSubst env) co
+  = let opt_co = optCoercion (getCvSubst env) co
+    in opt_co `seq` return opt_co
 \end{code}
 
 
@@ -964,7 +986,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 rebuild env expr cont
   = case cont of
       Stop {}                      -> return (env, expr)
-      CoerceIt co cont             -> rebuild env (mkCoerce co expr) cont
+      CoerceIt co cont             -> rebuild env (Cast expr co) cont
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
@@ -991,11 +1013,11 @@ simplCast env body co0 cont0
   where
        addCoerce co cont = add_coerce co (coercionKind co) cont
 
-       add_coerce _co (s1, k1) cont     -- co :: ty~ty
-         | s1 `coreEqType` k1 = cont    -- is a no-op
+       add_coerce _co (Pair s1 k1) cont     -- co :: ty~ty
+         | s1 `eqType` k1 = cont    -- is a no-op
 
-       add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
-         | (_l1, t1) <- coercionKind co2
+       add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
+         | (Pair _l1 t1) <- coercionKind co2
 		-- 	e |> (g1 :: S1~L) |> (g2 :: L~T1)
                 -- ==>
                 --      e,                       if S1=T1
@@ -1005,28 +1027,40 @@ simplCast env body co0 cont0
                 -- we may find  (coerce T (coerce S (\x.e))) y
                 -- and we'd like it to simplify to e[y/x] in one round
                 -- of simplification
-         , s1 `coreEqType` t1  = cont            -- The coerces cancel out
-         | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
+         , s1 `eqType` t1  = cont            -- The coerces cancel out
+         | otherwise       = CoerceIt (mkTransCo co1 co2) cont
 
-       add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
+       add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
-                -- This implements the PushT and PushC rules from the paper
+                -- This implements the PushT rule from the paper
          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
-         = let 
-             (new_arg_ty, new_cast)
-               | isCoVar tyvar = (new_arg_co, mkCselRCoercion co)       -- PushC rule
-               | otherwise     = (ty',        mkInstCoercion co ty')    -- PushT rule
-           in 
-           ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
+         = ASSERT( isTyVar tyvar )
+           ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
+         where
+           new_cast = mkInstCo co arg_ty'
+           arg_ty' | isSimplified dup = arg_ty
+                   | otherwise        = substTy (arg_se `setInScope` env) arg_ty
+
+{-
+       add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont)
+                -- This implements the PushC rule from the paper
+         | Just (covar,_) <- splitForAllTy_maybe s1s2
+         = ASSERT( isCoVar covar )
+           ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont)
          where
-           ty' = substTy (arg_se `setInScope` env) arg_ty
-	   new_arg_co = mkCsel1Coercion co  `mkTransCoercion`
-                              ty'           `mkTransCoercion`
-                        mkSymCoercion (mkCsel2Coercion co)
-
-       add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
-         | not (isTypeArg arg)  -- This implements the Push rule from the paper
-         , isFunTy s1s2   -- t1t2 must be a function type, becuase it's applied
+           [co0, co1]   = decomposeCo 2 co
+           [co00, co01] = decomposeCo 2 co0
+
+           arg_co' | isSimplified dup = arg_co
+                   | otherwise        = substCo (arg_se `setInScope` env) arg_co
+           new_arg_co = co00    `mkTransCo`
+                        arg_co' `mkTransCo`
+                        mkSymCo co01
+-}
+
+       add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
+         | isFunTy s1s2   -- This implements the Push rule from the paper
+         , isFunTy t1t2   -- Check t1t2 to ensure 'arg' is a value arg
                 --      (e |> (g :: s1s2 ~ t1->t2)) f
                 -- ===>
                 --      (e (f |> (arg g :: t1~s1))
@@ -1047,7 +1081,7 @@ simplCast env body co0 cont0
            -- t2 ~ s2 with left and right on the curried form:
            --    (->) t1 t2 ~ (->) s1 s2
            [co1, co2] = decomposeCo 2 co
-           new_arg    = mkCoerce (mkSymCoercion co1) arg'
+           new_arg    = mkCoerce (mkSymCo co1) arg'
            arg'       = substExpr (text "move-cast") (arg_se `setInScope` env) arg
 
        add_coerce co _ cont = CoerceIt co cont
@@ -1120,7 +1154,7 @@ simplNonRecE :: SimplEnv
 	-- First deal with type applications and type lets
 	--   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
-  = ASSERT( isTyCoVar bndr )
+  = ASSERT( isTyVar bndr )
     do	{ ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
 	; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 
@@ -1130,12 +1164,12 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
         ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
           simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
 
-  | isStrictId bndr
+  | isStrictId bndr		  -- Includes coercions
   = do  { simplExprF (rhs_se `setFloats` env) rhs
                      (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = ASSERT( not (isTyCoVar bndr) )
+  = ASSERT( not (isTyVar bndr) )
     do  { (env1, bndr1) <- simplNonRecBndr env bndr
         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
@@ -1177,20 +1211,20 @@ simplNote env (CoreNote s) e cont
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
-  | isTyCoVar var 
-  = return (Type (substTyVar env var))
+  | isTyVar var = return (Type (substTyVar env var))
+  | isCoVar var = return (Coercion (substCoVar env var))
   | otherwise
   = case substId env var of
-        DoneId var1      -> return (Var var1)
-        DoneEx e         -> return e
-        ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
+        DoneId var1          -> return (Var var1)
+        DoneEx e             -> return e
+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
 
-simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
-simplVarF env var cont
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplIdF env var cont
   = case substId env var of
-        DoneEx e         -> simplExprF (zapSubstEnv env) e cont
-        ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
-        DoneId var1      -> completeCall env var1 cont
+        DoneEx e             -> simplExprF (zapSubstEnv env) e cont
+        ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+        DoneId var1          -> completeCall env var1 cont
                 -- Note [zapSubstEnv]
                 -- The template is already simplified, so don't re-substitute.
                 -- This is VITAL.  Consider
@@ -1266,13 +1300,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
     res     = mkApps (Var fun) (reverse rev_args)
     res_ty  = exprType res
     cont_ty = contResultType env res_ty cont
-    co      = mkUnsafeCoercion res_ty cont_ty
-    mk_coerce expr | cont_ty `coreEqType` res_ty = expr
+    co      = mkUnsafeCo res_ty cont_ty
+    mk_coerce expr | cont_ty `eqType` res_ty = expr
                    | otherwise = mkCoerce co expr
 
-rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
-  = do  { ty' <- simplCoercion (se `setInScope` env) arg_ty
-        ; rebuildCall env (info `addArgTo` Type ty') cont }
+rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
+  = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
+                    else simplType (se `setInScope` env) arg_ty
+       ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
 
 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
                               , ai_strs = str:strs, ai_discs = disc:discs })
@@ -1280,7 +1315,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
   = rebuildCall env (addArgTo info' arg) cont
 
-  | str 	        -- Strict argument
+  | str                 -- Strict argument
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
     simplExprF (arg_se `setFloats` env) arg
                (StrictArg info' cci cont)
@@ -1771,7 +1806,7 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
   | not (isDeadBinder case_bndr)	-- Not a pure seq!  See Note [Improving seq]
   , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
   = do { case_bndr2 <- newId (fsLit "nt") ty2
-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }
 
@@ -1834,7 +1869,7 @@ simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)
         = go vs the_strs
         where
           go [] [] = []
-          go (v:vs') strs | isTyCoVar v = v : go vs' strs
+          go (v:vs') strs | isTyVar v = v : go vs' strs
           go (v:vs') (str:strs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
@@ -1933,7 +1968,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
     bind_args env' [] _  = return env'
 
     bind_args env' (b:bs') (Type ty : args)
-      = ASSERT( isTyCoVar b )
+      = ASSERT( isTyVar b )
         bind_args (extendTvSubst env' b ty) bs' args
 
     bind_args env' (b:bs') (arg : args)
@@ -2151,7 +2186,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
 			  | otherwise		   = bndrs' ++ [case_bndr_w_unf]
 	      
               abstract_over bndr
-                  | isTyCoVar bndr = True -- Abstract over all type variables just in case
+                  | isTyVar bndr = True -- Abstract over all type variables just in case
                   | otherwise    = not (isDeadBinder bndr)
                         -- The deadness info on the new Ids is preserved by simplBinders
 
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 3205542..f9d02e5 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -37,10 +37,10 @@ import CoreUtils        ( exprType, eqExpr )
 import PprCore		( pprRules )
 import Type             ( Type )
 import TcType		( tcSplitTyConApp_maybe )
+import Coercion
 import CoreTidy		( tidyRules )
 import Id
 import IdInfo		( SpecInfo( SpecInfo ) )
-import Var		( Var )
 import VarEnv
 import VarSet
 import Name		( Name, NamedThing(..) )
@@ -56,7 +56,6 @@ import Util
 import Data.List
 \end{code}
 
-
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * After the desugarer:
@@ -184,8 +183,9 @@ roughTopNames args = map roughTopName args
 
 roughTopName :: CoreExpr -> Maybe Name
 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
-			  Just (tc,_) -> Just (getName tc)
-			  Nothing     -> Nothing
+                               Just (tc,_) -> Just (getName tc)
+                               Nothing     -> Nothing
+roughTopName (Coercion _) = Nothing 
 roughTopName (App f _) = roughTopName f
 roughTopName (Var f)   | isGlobalId f	-- Note [Care with roughTopName]
                        , isDataConWorkId f || idArity f > 0
@@ -625,10 +625,7 @@ match :: RuleEnv
 -- succeed in matching what looks like the template variable 'a' against 3.
 
 -- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1) e2
-  | Just subst <- match_var renv subst v1 e2
-  = Just subst
-
+match renv subst (Var v1)    e2 = match_var renv subst v1 e2
 match renv subst (Note _ e1) e2 = match renv subst e1 e2
 match renv subst e1 (Note _ e2) = match renv subst e1 e2
       -- Ignore notes in both template and thing to be matched
@@ -714,15 +711,29 @@ match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 
 match renv subst (Type ty1) (Type ty2)
   = match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+  = match_co renv subst co1 co2
 
 match renv subst (Cast e1 co1) (Cast e2 co2)
-  = do	{ subst1 <- match_ty renv subst co1 co2
+  = do	{ subst1 <- match_co renv subst co1 co2
 	; match renv subst1 e1 e2 }
 
 -- Everything else fails
 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
                     Nothing
 
+-------------
+match_co :: RuleEnv
+      	 -> RuleSubst
+      	 -> Coercion
+      	 -> Coercion
+      	 -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+  = match_var renv subst cv (Coercion co)
+match_co _ _ co1 _ 
+  = pprTrace "match_co baling out" (ppr co1) Nothing
+
+-------------
 rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
 rnMatchBndr2 renv subst x1 x2
   = renv { rv_lcl  = rnBndr2 rn_env x1 x2
@@ -1038,6 +1049,7 @@ ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 ruleCheck _   (Var _) 	    = emptyBag
 ruleCheck _   (Lit _) 	    = emptyBag
 ruleCheck _   (Type _)      = emptyBag
+ruleCheck _   (Coercion _)  = emptyBag
 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 ruleCheck env (Note _ e)    = ruleCheck env e
 ruleCheck env (Cast e _)    = ruleCheck env e
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 4fa4204..6cc05a3 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -33,9 +33,9 @@ import CoreMonad
 import HscTypes         ( ModGuts(..) )
 import WwLib		( mkWorkerArgs )
 import DataCon
-import Coercion	
+import Coercion		hiding( substTy, substCo )
 import Rules
-import Type		hiding( substTy )
+import Type		hiding ( substTy )
 import Id
 import MkCore		( mkImpossibleExpr )
 import Var
@@ -50,6 +50,7 @@ import Demand
 import DmdAnal		( both )
 import Serialized       ( deserializeWithData )
 import Util
+import Pair
 import UniqSupply
 import Outputable
 import FastString
@@ -699,6 +700,9 @@ scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
 scSubstTy :: ScEnv -> Type -> Type
 scSubstTy env ty = substTy (sc_subst env) ty
 
+scSubstCo :: ScEnv -> Coercion -> Coercion
+scSubstCo env co = substCo (sc_subst env) co
+
 zapScSubst :: ScEnv -> ScEnv
 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
 
@@ -777,7 +781,7 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
 		       	vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
 				       varsToCoreExprs alt_bndrs
 
-   zap v | isTyCoVar v = v		-- See NB2 above
+   zap v | isTyVar v = v		-- See NB2 above
          | otherwise = zapIdOccInfo v
 
 
@@ -997,11 +1001,12 @@ scExpr' env (Var v)     = case scSubstId env v of
 		            e'     -> scExpr (zapScSubst env) e'
 
 scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
 scExpr' _   e@(Lit {})  = return (nullUsage, e)
 scExpr' env (Note n e)  = do (usg,e') <- scExpr env e
                              return (usg, Note n e')
 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
-                             return (usg, Cast e' (scSubstTy env co))
+                             return (usg, Cast e' (scSubstCo env co))
 scExpr' env e@(App _ _) = scApp env (collectArgs e)
 scExpr' env (Lam b e)   = do let (env', b') = extendBndr env b
                              (usg, e') <- scExpr env' e
@@ -1047,7 +1052,7 @@ scExpr' env (Case scrut b ty alts)
 	   ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
-  | isTyCoVar bndr	-- Type-lets may be created by doBeta
+  | isTyVar bndr	-- Type-lets may be created by doBeta
   = scExpr' (extendScSubst env bndr rhs) body
 
   | otherwise	
@@ -1308,8 +1313,10 @@ specialise env bind_calls (RI fn _ arg_bndrs body arg_occs)
               spec_count' = n_pats + spec_count
 	; case sc_count env of
 	    Just max | not (sc_force env) && spec_count' > max
-		-> pprTrace "SpecConstr" msg $  
-                   return (nullUsage, spec_info)
+		-> if (debugIsOn || opt_PprStyle_Debug)	 -- Suppress this scary message for
+                   then pprTrace "SpecConstr" msg $  	 -- ordinary users!  Trac #5125
+                        return (nullUsage, spec_info)
+                   else return (nullUsage, spec_info)
 		where
 		   msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
 		       	            , nest 2 (ptext (sLit "has") <+> 
@@ -1417,6 +1424,7 @@ calcSpecStrictness fn qvars pats
     dmd_env = go emptyVarEnv dmds pats
 
     go env ds (Type {} : pats) = go env ds pats
+    go env ds (Coercion {} : pats) = go env ds pats
     go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
     go env _      _            = env
 
@@ -1517,7 +1525,7 @@ callToPats env bndr_occs (con_env, args)
 		-- at the call site
 		-- See Note [Shadowing] at the top
 		
-	      (tvs, ids) = partition isTyCoVar qvars
+	      (tvs, ids) = partition isTyVar qvars
 	      qvars'     = tvs ++ ids
 		-- Put the type variables first; the type of a term
 		-- variable may mention a type variable
@@ -1552,6 +1560,9 @@ argToPat :: ScEnv
 
 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
   = return (False, arg)
+    
+argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ
+  = return (False, arg)
 
 argToPat env in_scope val_env (Note _ arg) arg_occ
   = argToPat env in_scope val_env arg arg_occ
@@ -1577,8 +1588,8 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
 -}
 
 argToPat env in_scope val_env (Cast arg co) arg_occ
-  | isIdentityCoercion co     -- Substitution in the SpecConstr itself
-                              -- can lead to identity coercions
+  | isReflCo co     -- Substitution in the SpecConstr itself
+                    -- can lead to identity coercions
   = argToPat env in_scope val_env arg arg_occ
   | not (ignoreType env ty2)
   = do	{ (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
@@ -1588,10 +1599,10 @@ argToPat env in_scope val_env (Cast arg co) arg_occ
 	{ -- Make a wild-card pattern for the coercion
 	  uniq <- getUniqueUs
 	; let co_name = mkSysTvName uniq (fsLit "sg")
-	      co_var = mkCoVar co_name (mkCoKind ty1 ty2)
-	; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
+	      co_var = mkCoVar co_name (mkCoType ty1 ty2)
+	; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
   where
-    (ty1, ty2) = coercionKind co
+    Pair ty1 ty2 = coercionKind co
 
     
 
@@ -1699,7 +1710,7 @@ isValue env (Var v)
 	-- as well, for let-bound constructors!
 
 isValue env (Lam b e)
-  | isTyCoVar b = case isValue env e of
+  | isTyVar b = case isValue env e of
 		  Just _  -> Just LambdaVal
 		  Nothing -> Nothing
   | otherwise = Just LambdaVal
@@ -1734,6 +1745,7 @@ samePat (vs1, as1) (vs2, as2)
     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
 
     same (Type {}) (Type {}) = True	-- Note [Ignore type differences]
+    same (Coercion {}) (Coercion {}) = True
     same (Note _ e1) e2	= same e1 e2	-- Ignore casts and notes
     same (Cast e1 _) e2	= same e1 e2
     same e1 (Note _ e2) = same e1 e2
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 415378a..c192b3f 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -709,11 +709,12 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 
 ---------------- First the easy cases --------------------
 specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs)
+specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs)
 specExpr subst (Var v)   = return (specVar subst v,         emptyUDs)
 specExpr _     (Lit lit) = return (Lit lit,                 emptyUDs)
 specExpr subst (Cast e co) = do
     (e', uds) <- specExpr subst e
-    return ((Cast e' (CoreSubst.substTy subst co)), uds)
+    return ((Cast e' (CoreSubst.substCo subst co)), uds)
 specExpr subst (Note note body) = do
     (body', uds) <- specExpr subst body
     return (Note (specNote subst note) body', uds)
@@ -1518,7 +1519,7 @@ instance Ord CallKey where
 		  cmp Nothing   Nothing   = EQ
 		  cmp Nothing   (Just _)  = LT
 		  cmp (Just _)  Nothing   = GT
-		  cmp (Just t1) (Just t2) = tcCmpType t1 t2
+		  cmp (Just t1) (Just t2) = cmpType t1 t2
 
 unionCalls :: CallDetails -> CallDetails -> CallDetails
 unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2
@@ -1603,7 +1604,9 @@ interestingDict :: CoreExpr -> Bool
 interestingDict (Var v) =  hasSomeUnfolding (idUnfolding v)
 			|| isDataConWorkId v
 interestingDict (Type _)	  = False
+interestingDict (Coercion _)      = False
 interestingDict (App fn (Type _)) = interestingDict fn
+interestingDict (App fn (Coercion _)) = interestingDict fn
 interestingDict (Note _ a)	  = interestingDict a
 interestingDict (Cast e _)	  = interestingDict e
 interestingDict _                 = True
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 2059937..df8fabe 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -18,8 +18,8 @@ import StgSyn
 
 import Type
 import TyCon
+import MkId		( coercionTokenId )
 import Id
-import Var              ( Var )
 import IdInfo
 import DataCon
 import CostCentre       ( noCCS )
@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
 -- floated out a binding, in which case it will be approximate.
 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
 consistentCafInfo id bind
-  = WARN( not (exact || is_sat_thing) , ppr id )
+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
     safe
   where
     safe  = id_marked_caffy || not binding_is_caffy
@@ -312,8 +312,9 @@ on these components, but it in turn is not scrutinised as the basis for any
 decisions.  Hence no black holes.
 
 \begin{code}
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
-coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
 
 coreToStgExpr expr@(App _ _)
   = coreToStgApp Nothing f args
@@ -572,6 +573,10 @@ coreToStgArgs (Type _ : args) = do     -- Type argument
     (args', fvs) <- coreToStgArgs args
     return (args', fvs)
 
+coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
+  = do { (args', fvs) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', fvs) }
+
 coreToStgArgs (arg : args) = do         -- Non-type argument
     (stg_args, args_fvs) <- coreToStgArgs args
     (arg', arg_fvs, _escs) <- coreToStgExpr arg
@@ -1124,7 +1129,7 @@ myCollectArgs expr
     go (Cast e _)       as = go e as
     go (Note _ e)       as = go e as
     go (Lam b e)        as
-       | isTyCoVar b         = go e as  -- Note [Collect args]
+       | isTyVar b         = go e as  -- Note [Collect args]
     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}
 
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index 3bce281..dd026eb 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -68,7 +68,8 @@ import FastString
 
 #if mingw32_TARGET_OS
 import Packages		( isDllName )
-
+import Type		( typePrimRep )
+import TyCon		( PrimRep(..) )
 #endif
 \end{code}
 
@@ -118,8 +119,27 @@ isDllConApp this_pkg con args
   = isDllName this_pkg (dataConName con) || any is_dll_arg args
   where
     is_dll_arg ::StgArg -> Bool
-    is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v)
+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
+                             && isDllName this_pkg (idName v)
     is_dll_arg _             = False
+
+isAddrRep :: PrimRep -> Bool
+-- True of machine adddresses; these are the things that don't
+-- work across DLLs.
+-- The key point here is that VoidRep comes out False, so that
+-- a top level nullary GADT construtor is False for isDllConApp
+--    data T a where
+--      T1 :: T Int
+-- gives
+--    T1 :: forall a. (a~Int) -> T a
+-- and hence the top-level binding
+--    $WT1 :: T Int
+--    $WT1 = T1 Int (Coercion (Refl Int))
+-- The coercion argument here gets VoidRep
+isAddrRep AddrRep = True
+isAddrRep PtrRep  = True
+isAddrRep _       = False
+
 #else
 isDllConApp _ _ _ = False
 #endif
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 192d06f..afa722f 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -18,6 +18,7 @@ import StaticFlags	( opt_MaxWorkerArgs )
 import Demand	-- All of it
 import CoreSyn
 import PprCore	
+import Coercion		( isCoVarType )
 import CoreUtils	( exprIsHNF, exprIsTrivial )
 import CoreArity	( exprArity )
 import DataCon		( dataConTyCon, dataConRepStrictness )
@@ -28,19 +29,20 @@ import Id		( Id, idType, idInlineActivation,
 			  setIdStrictness, idDemandInfo, idUnfolding,
 			  idDemandInfo_maybe, setIdDemandInfo
 			)
-import Var		( Var )
+import Var		( Var, isTyVar )
 import VarEnv
 import TysWiredIn	( unboxedPairDataCon )
 import TysPrim		( realWorldStatePrimTy )
 import UniqFM		( addToUFM_Directly, lookupUFM_Directly,
 			  minusUFM, filterUFM )
-import Type		( isUnLiftedType, coreEqType, splitTyConApp_maybe )
+import Type		( isUnLiftedType, eqType, splitTyConApp_maybe )
 import Coercion         ( coercionKind )
 import Util		( mapAndUnzip, lengthIs, zipEqual )
 import BasicTypes	( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
 			  RecFlag(..), isRec, isMarkedStrict )
 import Maybes		( orElse, expectJust )
 import Outputable
+import Pair
 import Data.List
 import FastString
 \end{code}
@@ -144,6 +146,7 @@ dmdAnal env dmd e
 
 dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
 dmdAnal _ _ (Type ty) = (topDmdType, Type ty)	-- Doesn't happen, in fact
+dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co)
 
 dmdAnal env dmd (Var var)
   = (dmdTransform env var dmd, Var var)
@@ -152,7 +155,7 @@ dmdAnal env dmd (Cast e co)
   = (dmd_ty, Cast e' co)
   where
     (dmd_ty, e') = dmdAnal env dmd' e
-    to_co        = snd (coercionKind co)
+    to_co        = pSnd (coercionKind co)
     dmd'
       | Just (tc, _) <- splitTyConApp_maybe to_co
       , isRecursiveTyCon tc = evalDmd
@@ -173,6 +176,11 @@ dmdAnal env dmd (App fun (Type ty))
   where
     (fun_ty, fun') = dmdAnal env dmd fun
 
+dmdAnal sigs dmd (App fun (Coercion co))
+  = (fun_ty, App fun' (Coercion co))
+  where
+    (fun_ty, fun') = dmdAnal sigs dmd fun
+
 -- Lots of the other code is there to make this
 -- beautiful, compositional, application rule :-)
 dmdAnal env dmd (App fun arg)	-- Non-type arguments
@@ -184,7 +192,7 @@ dmdAnal env dmd (App fun arg)	-- Non-type arguments
     (res_ty `bothType` arg_ty, App fun' arg')
 
 dmdAnal env dmd (Lam var body)
-  | isTyCoVar var
+  | isTyVar var
   = let   
 	(body_ty, body') = dmdAnal env dmd body
     in
@@ -328,7 +336,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs)
 	--	   ; print len }
 
 	io_hack_reqd = con == DataAlt unboxedPairDataCon &&
-		       idType (head bndrs) `coreEqType` realWorldStatePrimTy
+		       idType (head bndrs) `eqType` realWorldStatePrimTy
     in	
     (final_alt_ty, (con, bndrs', rhs'))
 
@@ -838,7 +846,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
 -- The returned var is annotated with demand info
 -- No effect on the argument demands
 annotateBndr dmd_ty@(DmdType fv ds res) var
-  | isTyCoVar var = (dmd_ty, var)
+  | isTyVar var = (dmd_ty, var)
   | otherwise   = (DmdType fv' ds res, setIdDemandInfo var dmd)
   where
     (fv', dmd) = removeFV fv var res
@@ -888,10 +896,15 @@ removeFV fv id res = (fv', zapUnlifted id dmd)
 zapUnlifted :: Id -> Demand -> Demand
 -- For unlifted-type variables, we are only 
 -- interested in Bot/Abs/Box Abs
-zapUnlifted _  Bot = Bot
-zapUnlifted _  Abs = Abs
-zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
-		   | otherwise			= dmd
+zapUnlifted id dmd
+  = case dmd of
+      _ | isCoVarType ty    -> lazyDmd	-- For coercions, ignore str/abs totally
+      Bot                   -> Bot
+      Abs                   -> Abs
+      _ | isUnLiftedType ty -> lazyDmd	-- For unlifted types, ignore strictness
+	| otherwise	    -> dmd
+  where
+    ty = idType id
 \end{code}
 
 Note [Lamba-bound unfoldings]
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 5cf5e92..ac10b1b 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -100,6 +100,7 @@ matching by looking for strict arguments of the correct type.
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
 wwExpr e@(Type {}) = return e
+wwExpr e@(Coercion {}) = return e
 wwExpr e@(Lit  {}) = return e
 wwExpr e@(Var  {}) = return e
 
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index e7d0edf..391c07c 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -23,10 +23,9 @@ import MkId		( realWorldPrimId, voidArgId,
 import TysPrim		( realWorldStatePrimTy )
 import TysWiredIn	( tupleCon )
 import Type
-import Coercion         ( mkSymCoercion, splitNewTypeRepCo_maybe )
+import Coercion         ( mkSymCo, splitNewTypeRepCo_maybe )
 import BasicTypes	( Boxity(..) )
 import Literal		( absentLiteralOf )
-import Var              ( Var )
 import UniqSupply
 import Unique
 import Util		( zipWithEqual )
@@ -244,7 +243,7 @@ mkWWargs subst fun_ty arg_info
   = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
 	    <-  mkWWargs subst rep_ty arg_info
  	; return (wrap_args,
-	     	  \e -> Cast (wrap_fn_args e) (mkSymCoercion co),
+	     	  \e -> Cast (wrap_fn_args e) (mkSymCo co),
      		  \e -> work_fn_args (Cast e co),
      		  res_ty) } 
 
@@ -271,7 +270,7 @@ mkWWargs subst fun_ty arg_info
 	      <- mkWWargs subst fun_ty' arg_info'
 	; return (id : wrap_args,
 	          Lam id . wrap_fn_args,
-        	  work_fn_args . (`App` Var id),
+        	  work_fn_args . (`App` varToCoreExpr id),
         	  res_ty) }
 
   | otherwise
@@ -291,18 +290,12 @@ mk_wrap_arg uniq ty dmd one_shot
 
 Note [Freshen type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-mkWWargs may be given a type like  (a~b) => <blah>
-Which really means                 forall (co:a~b). <blah>
-Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
-nested coercion foralls may all use the same variable; and sometimes do
-see Var.mkWildCoVar.
-
-However, when we do a worker/wrapper split, we must not use shadowed names,
+Wen we do a worker/wrapper split, we must not use shadowed names,
 else we'll get
-   f = /\ co /\co. fw co co
-which is obviously wrong.  Actually, the same is true of type variables, which
-can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
-But type variables *are* mentioned in <blah>, so we must substitute.
+   f = /\ a /\a. fw a a
+which is obviously wrong.  Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a).  But type
+variables *are* mentioned in <blah>, so we must substitute.
 
 That's why we carry the TvSubst through mkWWargs
 	
@@ -339,7 +332,7 @@ mkWWstr (arg : args) = do
 --	  brings into scope wrap_arg (via lets)
 mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 mkWWstr_one arg
-  | isTyCoVar arg
+  | isTyVar arg
   = return ([arg],  nop_fn, nop_fn)
 
   | otherwise
@@ -525,7 +518,7 @@ mk_absent_let arg
   | Just (tc, _) <- splitTyConApp_maybe arg_ty
   , Just lit <- absentLiteralOf tc
   = Just (Let (NonRec arg (Lit lit)))
-  | arg_ty `coreEqType` realWorldStatePrimTy 
+  | arg_ty `eqType` realWorldStatePrimTy 
   = Just (Let (NonRec arg (Var realWorldPrimId)))
   | otherwise
   = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 45584d9..ccdbf57 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -7,6 +7,7 @@ module FamInst (
 
 import HscTypes
 import FamInstEnv
+import LoadIface
 import TcMType
 import TcRnMonad
 import TyCon
@@ -82,20 +83,17 @@ checkFamInstConsistency famInstMods directlyImpMods
        ; (eps, hpt) <- getEpsAndHpt
 
        ; let { -- Fetch the iface of a given module.  Must succeed as
- 	       -- all imported modules must already have been loaded.
+ 	       -- all directly imported modules must already have been loaded.
 	       modIface mod = 
 	         case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
                    Nothing    -> panic "FamInst.checkFamInstConsistency"
                    Just iface -> iface
 
              ; hmiModule     = mi_module . hm_iface
-	     ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
-	     ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
-             ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi) 
-			       | hmi <- eltsUFM hpt]
-             ; modInstsEnv   = eps_mod_fam_inst_env eps	-- external modules
-			       `extendModuleEnvList`	-- plus
-			       hptModInsts		-- home package modules
+	     ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv 
+                               . md_fam_insts . hm_details
+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) 
+			                   | hmi <- eltsUFM hpt]
 	     ; groups        = map (dep_finsts . mi_deps . modIface) 
 				   directlyImpMods
 	     ; okPairs       = listToSet $ concatMap allPairs groups
@@ -106,22 +104,27 @@ checkFamInstConsistency famInstMods directlyImpMods
 	         -- the difference gives us the pairs we need to check now
 	     }
 
-       ; mapM_ (check modInstsEnv) toCheckPairs
+       ; mapM_ (check hpt_fam_insts) toCheckPairs
        }
   where
     allPairs []     = []
     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
 
-    -- The modules are guaranteed to be in the environment, as they are either
-    -- already loaded in the EPS or they are in the HPT.
-    --
-    check modInstsEnv (ModulePair m1 m2)
-      = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
-	    ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
-	    ; insts1   = famInstEnvElts instEnv1
-	    }
-        in
-	mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+    check hpt_fam_insts (ModulePair m1 m2)
+      = do { env1 <- getFamInsts hpt_fam_insts m1
+           ; env2 <- getFamInsts hpt_fam_insts m2
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))   
+                   (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+                   ; eps <- getEps
+                   ; return (expectJust "checkFamInstConsistency" $
+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+  where
+    doc = ppr mod <+> ptext (sLit "is a family-instance module")
 \end{code}
 
 %************************************************************************
@@ -196,17 +199,11 @@ addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst
-\end{code} 
-
-\begin{code} 
 
 tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
 -- Gets both the external-package inst-env
 -- and the home-pkg inst env (includes module being compiled)
 tcGetFamInstEnvs 
   = do { eps <- getEps; env <- getGblEnv
-       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) 
-       }
-
-
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
 \end{code}
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index bbdf21b..378bbd6 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -46,11 +46,10 @@ import TcMType
 import TcType
 import Class
 import Unify
-import Coercion
 import HscTypes
 import Id
 import Name
-import Var
+import Var      ( Var, TyVar, EvVar, varType, setVarType )
 import VarEnv
 import VarSet
 import PrelNames
@@ -212,11 +211,8 @@ instCallConstraints _ [] = return idHsWrapper
 
 instCallConstraints origin (EqPred ty1 ty2 : preds)	-- Try short-cut
   = do  { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
-	; coi   <- unifyType ty1 ty2
+        ; co    <- unifyType ty1 ty2
 	; co_fn <- instCallConstraints origin preds
-	; let co = case coi of
-                       IdCo ty -> ty
-                       ACo  co -> co
         ; return (co_fn <.> WpEvApp (EvCoercion co)) }
 
 instCallConstraints origin (pred : preds)
@@ -551,7 +547,7 @@ tidyFlavoredEvVar env (EvVarX v fl)
   = EvVarX (tidyEvVar env v) (tidyFlavor env fl)
 
 tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
-tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
+tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
 tidyFlavor _   fl          = fl
 
 tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
@@ -595,8 +591,8 @@ substFlavoredEvVar subst (EvVarX v fl)
   = EvVarX (substEvVar subst v) (substFlavor subst fl)
 
 substFlavor :: TvSubst -> CtFlavor -> CtFlavor
-substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
-substFlavor _     fl          = fl
+substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
+substFlavor _     fl             = fl
 
 substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
 substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
@@ -605,4 +601,4 @@ substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
 substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
 substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
 substSkolemInfo _     info            = info
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index ae4a1e8..7ce5fc1 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -7,7 +7,7 @@ Typecheck arrow notation
 \begin{code}
 module TcArrows ( tcProc ) where
 
-import {-# SOURCE #-}	TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
+import {-# SOURCE #-}	TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
 
 import HsSyn
 import TcMatches
@@ -17,7 +17,9 @@ import TcBinds
 import TcPat
 import TcUnify
 import TcRnMonad
+import TcEnv
 import Coercion
+import Id( mkLocalId )
 import Inst
 import Name
 import TysWiredIn
@@ -41,17 +43,17 @@ import Control.Monad
 \begin{code}
 tcProc :: InPat Name -> LHsCmdTop Name		-- proc pat -> expr
        -> TcRhoType				-- Expected type of whole proc expression
-       -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI)
+       -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
     do	{ (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
 	; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
 	; let cmd_env = CmdEnv { cmd_arr = arr_ty }
-	; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
+        ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
 			  tcCmdTop cmd_env cmd [] res_ty
-        ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty))
-	; return (pat', cmd', res_coi) }
+        ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty))
+        ; return (pat', cmd', res_coi) }
 \end{code}
 
 
@@ -83,20 +85,12 @@ tcCmdTop :: CmdEnv
 
 tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
   = setSrcSpan loc $
-    do	{ cmd'   <- tcGuardedCmd env cmd cmd_stk res_ty
+    do	{ cmd'   <- tcCmd env cmd (cmd_stk, res_ty)
 	; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
 	; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
 
 
 ----------------------------------------
-tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
-	     -> TcTauType -> TcM (LHsExpr TcId)
--- A wrapper that deals with the refinement (if any)
-tcGuardedCmd env expr stk res_ty
-  = do	{ body <- tcCmd env expr (stk, res_ty)
-	; return body 
-        }
-
 tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
 	-- The main recursive function
 tcCmd env (L loc expr) res_ty
@@ -123,7 +117,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
-    mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
+    mc_body body res_ty' = tcCmd env body (stk, res_ty')
 
 tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
   = do 	{ pred_ty <- newFlexiTyVarTy openTypeKind
@@ -187,8 +181,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
 
 		-- Check the patterns, and the GRHSs inside
 	; (pats', grhss') <- setSrcSpan mtch_loc		$
-			     tcPats LambdaExpr pats cmd_stk	$
-			     tc_grhss grhss res_ty
+                             tcPats LambdaExpr pats cmd_stk     $
+                             tc_grhss grhss res_ty
 
 	; let match' = L mtch_loc (Match pats' Nothing grhss')
 	; return (HsLam (MatchGroup [match'] res_ty))
@@ -206,22 +200,18 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
 	     ; return (GRHSs grhss' binds') }
 
     tc_grhs res_ty (GRHS guards body)
-	= do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
-				  tcGuardedCmd env body stk'
+	= do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+				  \ res_ty -> tcCmd env body (stk', res_ty)
 	     ; return (GRHS guards' rhs') }
 
 -------------------------------------------
 -- 		Do notation
 
-tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
   = do 	{ checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
-	; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $
-			     tcGuardedCmd env body []
-	; return (HsDo do_or_lc stmts' body' res_ty) }
+	; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty 
+	; return (HsDo do_or_lc stmts' res_ty) }
   where
-    tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
-		    ; rhs' <- tcCmd env rhs ([], ty)
-		    ; return (rhs', ty) }
 
 
 -----------------------------------------------------------------
@@ -249,7 +239,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 			      e_res_ty
 
 		-- Check expr
-	; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
+        ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
                                  escapeArrowScope (tcMonoExpr expr e_ty)
 
 		-- OK, now we are in a position to unscramble 
@@ -279,7 +269,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 		-- Check that it has the right shape:
 		-- 	((w,s1) .. sn)
 		-- where the si do not mention w
-	   ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv && 
+	   ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && 
 		      not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
 		     (badFormFun i tup_ty')
 
@@ -307,6 +297,69 @@ tc_cmd _ cmd _
 
 %************************************************************************
 %*									*
+		Stmts
+%*									*
+%************************************************************************
+
+\begin{code}
+--------------------------------
+--	Mdo-notation
+-- The distinctive features here are
+--	(a) RecStmts, and
+--	(b) no rebindable syntax
+
+tcArrDoStmt :: CmdEnv -> TcStmtChecker
+tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
+  = do	{ rhs' <- tcCmd env rhs ([], res_ty)
+	; thing <- thing_inside (panic "tcArrDoStmt")
+	; return (LastStmt rhs' noSyntaxExpr, thing) }
+
+tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside
+  = do	{ (rhs', elt_ty) <- tc_arr_rhs env rhs
+	; thing 	 <- thing_inside res_ty
+	; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
+
+tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+  = do	{ (rhs', pat_ty) <- tc_arr_rhs env rhs
+	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
+                            thing_inside res_ty
+	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
+                            , recS_rec_ids = recNames }) res_ty thing_inside
+  = do	{ rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
+	; let rec_ids = zipWith mkLocalId recNames rec_tys
+	; tcExtendIdEnv rec_ids $ do
+    	{ (stmts', (later_ids, rec_rets))
+		<- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty	$ \ _res_ty' ->
+			-- ToDo: res_ty not really right
+		   do { rec_rets <- zipWithM tcCheckId recNames rec_tys
+		      ; later_ids <- tcLookupLocalIds laterNames
+		      ; return (later_ids, rec_rets) }
+
+	; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
+		-- NB:	The rec_ids for the recursive things 
+		-- 	already scope over this part. This binding may shadow
+		--	some of them with polymorphic things with the same Name
+		--	(see note [RecStmt] in HsExpr)
+
+        ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
+                               , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+                               , recS_ret_ty = res_ty }, thing)
+	}}
+
+tcArrDoStmt _ _ stmt _ _
+  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
+
+tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType)
+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
+		        ; rhs' <- tcCmd env rhs ([], ty)
+		        ; return (rhs', ty) }
+\end{code}
+
+
+%************************************************************************
+%*									*
 		Helpers
 %*									*
 %************************************************************************
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 33e9081..8462403 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -844,7 +844,7 @@ unifyCtxts (sig1 : sigs)
                -- where F is a type function and (F a ~ [a])
                -- Then unification might succeed with a coercion.  But it's much
                -- much simpler to require that such signatures have identical contexts
-               checkTc (all isIdentityCoI cois)
+               checkTc (all isReflCo cois)
                        (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
              }
 \end{code}
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 59cc736..2cb38a9 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -8,12 +8,13 @@ module TcCanonical(
 #include "HsVersions.h"
 
 import BasicTypes
-import Type
+import Id	( evVarPred )
+import TcErrors
 import TcRnTypes
 import FunDeps
 import qualified TcMType as TcM
 import TcType
-import TcErrors
+import Type
 import Coercion
 import Class
 import TyCon
@@ -92,7 +93,9 @@ expansions contain any type function applications would speed things
 up a bit; right now we waste a lot of energy traversing the same types
 multiple times.
 
+
 \begin{code}
+
 -- Flatten a bunch of types all at once.
 flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
 -- Coercions :: Xi ~ Type 
@@ -111,35 +114,35 @@ flatten ctxt ty
 	-- Preserve type synonyms if possible
 	-- We can tell if ty' is function-free by
 	-- whether there are any floated constraints
-       ; if isEmptyCCan ccs then
-             return (ty, ty, emptyCCan)  
+        ; if isReflCo co then
+             return (ty, mkReflCo ty, emptyCCan)
          else
              return (xi, co, ccs) }
 
 flatten _ v@(TyVarTy _)
-  = return (v, v, emptyCCan)
+  = return (v, mkReflCo v, emptyCCan)
 
 flatten ctxt (AppTy ty1 ty2)
   = do { (xi1,co1,c1) <- flatten ctxt ty1
        ; (xi2,co2,c2) <- flatten ctxt ty2
-       ; return (mkAppTy xi1 xi2, mkAppCoercion co1 co2, c1 `andCCan` c2) }
+       ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) }
 
 flatten ctxt (FunTy ty1 ty2)
   = do { (xi1,co1,c1) <- flatten ctxt ty1
        ; (xi2,co2,c2) <- flatten ctxt ty2
-       ; return (mkFunTy xi1 xi2, mkFunCoercion co1 co2, c1 `andCCan` c2) }
+       ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) }
 
 flatten fl (TyConApp tc tys)
   -- For a normal type constructor or data family application, we just
   -- recursively flatten the arguments.
   | not (isSynFamilyTyCon tc)
     = do { (xis,cos,ccs) <- flattenMany fl tys
-         ; return (mkTyConApp tc xis, mkTyConCoercion tc cos, ccs) }
+         ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) }
 
   -- Otherwise, it's a type function application, and we have to
   -- flatten it away as well, and generate a new given equality constraint
   -- between the application and a newly generated flattening skolem variable.
-  | otherwise 
+  | otherwise
   = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
       do { (xis, cos, ccs) <- flattenMany fl tys
          ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
@@ -147,35 +150,41 @@ flatten fl (TyConApp tc tys)
 	       	 -- The type function might be *over* saturated
 		 -- in which case the remaining arguments should
 		 -- be dealt with by AppTys
-               fam_ty = mkTyConApp tc xi_args 
-               fam_co = fam_ty -- identity 
-
-         ; (ret_co, rhs_var, ct) <- 
-             if isGiven fl then
-               do { rhs_var <- newFlattenSkolemTy fam_ty
-                  ; cv <- newGivenCoVar fam_ty rhs_var fam_co
-                  ; let ct = CFunEqCan { cc_id     = cv
-                                       , cc_flavor = fl -- Given
-                                       , cc_fun    = tc 
-                                       , cc_tyargs = xi_args 
-                                       , cc_rhs    = rhs_var }
-                  ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
-             else -- Derived or Wanted: make a new *unification* flatten variable
-               do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
-                  ; cv <- newCoVar fam_ty rhs_var
-                  ; let ct = CFunEqCan { cc_id = cv
-                                       , cc_flavor = mkWantedFlavor fl
-                                           -- Always Wanted, not Derived
-                                       , cc_fun = tc
-                                       , cc_tyargs = xi_args
-                                       , cc_rhs    = rhs_var }
-                  ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
-
+               fam_ty = mkTyConApp tc xi_args
+         ; (ret_co, rhs_var, ct) <-
+             do { is_cached <- lookupFlatCacheMap tc xi_args fl 
+                ; case is_cached of 
+                    Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
+                    Nothing
+                        | isGivenOrSolved fl ->
+                            do { rhs_var <- newFlattenSkolemTy fam_ty
+                               ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
+                               ; let ct = CFunEqCan { cc_id     = cv
+                                                    , cc_flavor = fl -- Given
+                                                    , cc_fun    = tc 
+                                                    , cc_tyargs = xi_args 
+                                                    , cc_rhs    = rhs_var }
+                               ; let ret_co = mkCoVarCo cv 
+                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co 
+                               ; return $ (ret_co, rhs_var, singleCCan ct) }
+                        | otherwise ->
+                    -- Derived or Wanted: make a new *unification* flatten variable
+                            do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
+                               ; cv <- newCoVar fam_ty rhs_var
+                               ; let ct = CFunEqCan { cc_id = cv
+                                                    , cc_flavor = mkWantedFlavor fl
+                                                    -- Always Wanted, not Derived
+                                                    , cc_fun = tc
+                                                    , cc_tyargs = xi_args
+                                                    , cc_rhs    = rhs_var }
+                               ; let ret_co = mkCoVarCo cv
+                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+                               ; return $ (ret_co, rhs_var, singleCCan ct) } }
          ; return ( foldl AppTy rhs_var xi_rest
-                  , foldl AppTy (mkSymCoercion ret_co 
-                                    `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
-                  , ccs `extendCCans` ct) }
-
+                  , foldl AppCo (mkSymCo ret_co 
+                                   `mkTransCo` mkTyConAppCo tc cos_args) 
+                                cos_rest
+                  , ccs `andCCan` ct) }
 
 flatten ctxt (PredTy pred) 
   = do { (pred', co, ccs) <- flattenPred ctxt pred
@@ -193,22 +202,20 @@ flatten ctxt ty@(ForAllTy {})
              tv_set   = mkVarSet tvs
        ; unless (isEmptyBag bad_eqs)
                 (flattenForAllErrorTcS ctxt ty bad_eqs)
-       ; return (mkForAllTys tvs rho', mkForAllTys tvs co, ccs)  }
+       ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs)  }
 
 ---------------
 flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts)
 flattenPred ctxt (ClassP cls tys)
   = do { (tys', cos, ccs) <- flattenMany ctxt tys
-       ; return (ClassP cls tys', mkClassPPredCo cls cos, ccs) }
+       ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) }
 flattenPred ctxt (IParam nm ty)
   = do { (ty', co, ccs) <- flatten ctxt ty
-       ; return (IParam nm ty', mkIParamPredCo nm co, ccs) }
--- TODO: Handling of coercions between EqPreds must be revisited once the New Coercion API is ready!
+       ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) }
 flattenPred ctxt (EqPred ty1 ty2)
   = do { (ty1', co1, ccs1) <- flatten ctxt ty1
        ; (ty2', co2, ccs2) <- flatten ctxt ty2
-       ; return (EqPred ty1' ty2', mkEqPredCo co1 co2, ccs1 `andCCan` ccs2) }
-
+       ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) }
 \end{code}
 
 %************************************************************************
@@ -222,7 +229,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList
 canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
 
 canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
-canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
+canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
                           ; return (unionWorkLists ccs) }
 
 mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
@@ -238,6 +245,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
     canon_one fev wl = do { wl' <- mkCanonicalFEV fev
                           ; return (unionWorkList wl' wl) }
 
+
 mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
 mkCanonical fl ev = case evVarPred ev of 
                         ClassP clas tys -> canClassToWorkList fl ev clas tys 
@@ -248,15 +256,15 @@ mkCanonical fl ev = case evVarPred ev of
 canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
 canClassToWorkList fl v cn tys 
   = do { (xis,cos,ccs) <- flattenMany fl tys  -- cos :: xis ~ tys
-       ; let no_flattening_happened = isEmptyCCan ccs
-             dict_co = mkTyConCoercion (classTyCon cn) cos
-       ; v_new <- if no_flattening_happened then return v
-                  else if isGiven fl        then return v
+       ; let no_flattening_happened = all isReflCo cos
+             dict_co = mkTyConAppCo (classTyCon cn) cos
+       ; v_new <- if no_flattening_happened  then return v
+                  else if isGivenOrSolved fl then return v
                          -- The cos are all identities if fl=Given,
                          -- hence nothing to do
                   else do { v' <- newDictVar cn xis  -- D xis
                           ; when (isWanted fl) $ setDictBind v  (EvCast v' dict_co)
-                          ; when (isGiven fl)  $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
+                          ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
                                  -- NB: No more setting evidence for derived now 
                           ; return v' }
 
@@ -320,7 +328,7 @@ For Deriveds:
 
 Here's an example that demonstrates why we chose to NOT add
 superclasses during simplification: [Comes from ticket #4497]
-
+ 
    class Num (RealOf t) => Normed t
    type family RealOf x
 
@@ -346,14 +354,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis
   = return emptyWorkList  -- Deriveds don't yield more superclasses because we will
                           -- add them transitively in the case of wanteds. 
 
-  | isGiven orig_flavor 
-  = do { let sc_theta = immSuperClasses cls xis 
-             flavor   = orig_flavor
-       ; sc_vars <- mapM newEvVar sc_theta
-       ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
-       ; mkCanonicals flavor sc_vars }
-
-  | isEmptyVarSet (tyVarsOfTypes xis) 
+  | Just gk <- isGiven_maybe orig_flavor 
+  = case gk of 
+      GivenOrig -> do { let sc_theta = immSuperClasses cls xis 
+                            flavor   = orig_flavor
+                      ; sc_vars <- mapM newEvVar sc_theta
+                      ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
+                      ; mkCanonicals flavor sc_vars }
+      GivenSolved -> return emptyWorkList 
+      -- Seems very dangerous to add the superclasses for dictionaries that may be 
+      -- partially solved because we may end up with evidence loops.
+
+  | isEmptyVarSet (tyVarsOfTypes xis)
   = return emptyWorkList -- Wanteds with no variables yield no deriveds.
                          -- See Note [Improvement from Ground Wanteds]
 
@@ -391,9 +403,9 @@ canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2
 
 canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts 
 canEq fl cv ty1 ty2 
-  | tcEqType ty1 ty2	-- Dealing with equality here avoids
+  | eqType ty1 ty2	-- Dealing with equality here avoids
     	     	 	-- later spurious occurs checks for a~a
-  = do { when (isWanted fl) (setCoBind cv ty1)
+  = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1))
        ; return emptyCCan }
 
 -- If one side is a variable, orient and flatten, 
@@ -407,47 +419,6 @@ canEq fl cv ty1 ty2@(TyVarTy {})
        ; canEqLeaf untch fl cv (classify ty1) (classify ty2) }
       -- NB: don't use VarCls directly because tv1 or tv2 may be scolems!
 
-canEq fl cv (TyConApp fn tys) ty2 
-  | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
-canEq fl cv ty1 (TyConApp fn tys)
-  | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
-
-canEq fl cv s1 s2
-  | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe s1, 
-    Just (t2a,t2b,t2c) <- splitCoPredTy_maybe s2
-  = do { (v1,v2,v3) 
-             <- if isWanted fl then                   -- Wanted
-                    do { v1 <- newCoVar t1a t2a
-                       ; v2 <- newCoVar t1b t2b 
-                       ; v3 <- newCoVar t1c t2c 
-                       ; let res_co = mkCoPredCo (mkCoVarCoercion v1) 
-                                        (mkCoVarCoercion v2) (mkCoVarCoercion v3)
-                       ; setCoBind cv res_co
-                       ; return (v1,v2,v3) }
-                else if isGiven fl then               -- Given 
-                         let co_orig = mkCoVarCoercion cv 
-                             coa = mkCsel1Coercion co_orig
-                             cob = mkCsel2Coercion co_orig
-                             coc = mkCselRCoercion co_orig
-                         in do { v1 <- newGivenCoVar t1a t2a coa
-                               ; v2 <- newGivenCoVar t1b t2b cob
-                               ; v3 <- newGivenCoVar t1c t2c coc 
-                               ; return (v1,v2,v3) }
-                else                                  -- Derived 
-                    do { v1 <- newDerivedId (EqPred t1a t2a)
-                       ; v2 <- newDerivedId (EqPred t1b t2b)
-                       ; v3 <- newDerivedId (EqPred t1c t2c)
-                       ; return (v1,v2,v3) }
-       ; cc1 <- canEq fl v1 t1a t2a 
-       ; cc2 <- canEq fl v2 t1b t2b 
-       ; cc3 <- canEq fl v3 t1c t2c 
-       ; return (cc1 `andCCan` cc2 `andCCan` cc3) }
-
-
 -- Split up an equality between function types into two equalities.
 canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
   = do { (argv, resv) <- 
@@ -455,11 +426,10 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
                  do { argv <- newCoVar s1 s2 
                     ; resv <- newCoVar t1 t2 
                     ; setCoBind cv $ 
-                      mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv) 
+                      mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) 
                     ; return (argv,resv) } 
-
-             else if isGiven fl then 
-                      let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv) 
+             else if isGivenOrSolved fl then 
+                      let [arg,res] = decomposeCo 2 (mkCoVarCo cv) 
                       in do { argv <- newGivenCoVar s1 s2 arg 
                             ; resv <- newGivenCoVar t1 t2 res
                             ; return (argv,resv) } 
@@ -473,33 +443,17 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
        ; cc2 <- canEq fl resv t1 t2
        ; return (cc1 `andCCan` cc2) }
 
-canEq fl cv (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2))
-  | n1 == n2
-  = if isWanted fl then 
-        do { v <- newCoVar t1 t2 
-           ; setCoBind cv $ mkIParamPredCo n1 (mkCoVarCoercion cv)
-           ; canEq fl v t1 t2 } 
-    else return emptyCCan -- DV: How to decompose given IP coercions? 
-
-canEq fl cv (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2))
-  | c1 == c2
-  = if isWanted fl then 
-       do { vs <- zipWithM newCoVar tys1 tys2 
-          ; setCoBind cv $ mkClassPPredCo c1 (map mkCoVarCoercion vs) 
-          ; andCCans <$> zipWith3M (canEq fl) vs tys1 tys2
-          }
-    else return emptyCCan 
-  -- How to decompose given dictionary (and implicit parameter) coercions? 
-  -- You may think that the following is right: 
-  --    let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) 
-  --    in  zipWith3M newGivOrDerCoVar tys1 tys2 cos
-  -- But this assumes that the coercion is a type constructor-based 
-  -- coercion, and not a PredTy (ClassP cn cos) coercion. So we chose
-  -- to not decompose these coercions. We have to get back to this 
-  -- when we clean up the Coercion API.
+canEq fl cv (TyConApp fn tys) ty2 
+  | isSynFamilyTyCon fn, length tys == tyConArity fn
+  = do { untch <- getUntouchables 
+       ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
+canEq fl cv ty1 (TyConApp fn tys)
+  | isSynFamilyTyCon fn, length tys == tyConArity fn
+  = do { untch <- getUntouchables 
+       ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
 
 canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-  | isAlgTyCon tc1 && isAlgTyCon tc2
+  | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
   , tc1 == tc2
   , length tys1 == length tys2
   = -- Generate equalities for each of the corresponding arguments
@@ -507,11 +461,10 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
              <- if isWanted fl then
                     do { argsv <- zipWithM newCoVar tys1 tys2
                        ; setCoBind cv $ 
-                         mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
-                       ; return argsv } 
-
-                else if isGiven fl then 
-                    let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) 
+                         mkTyConAppCo tc1 (map mkCoVarCo argsv)
+                       ; return argsv }
+                else if isGivenOrSolved fl then
+                    let cos = decomposeCo (length tys1) (mkCoVarCo cv)
                     in zipWith3M newGivenCoVar tys1 tys2 cos
 
                 else -- Derived 
@@ -524,28 +477,24 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
 canEq fl cv ty1 ty2
   | Just (s1,t1) <- tcSplitAppTy_maybe ty1
   , Just (s2,t2) <- tcSplitAppTy_maybe ty2
-    = do { (cv1,cv2) <- 
-             if isWanted fl 
-             then do { cv1 <- newCoVar s1 s2 
-                     ; cv2 <- newCoVar t1 t2 
-                     ; setCoBind cv $ 
-                       mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2) 
-                     ; return (cv1,cv2) } 
-
-             else if isGiven fl then 
-                    let co1 = mkLeftCoercion  $ mkCoVarCoercion cv 
-                        co2 = mkRightCoercion $ mkCoVarCoercion cv
-                    in do { cv1 <- newGivenCoVar s1 s2 co1 
-                          ; cv2 <- newGivenCoVar t1 t2 co2 
-                          ; return (cv1,cv2) } 
-             else -- Derived
-                 do { cv1 <- newDerivedId (EqPred s1 s2)
-                    ; cv2 <- newDerivedId (EqPred t1 t2)
-                    ; return (cv1,cv2) }
-
-         ; cc1 <- canEq fl cv1 s1 s2 
-         ; cc2 <- canEq fl cv2 t1 t2 
-         ; return (cc1 `andCCan` cc2) } 
+    = if isWanted fl 
+      then do { cv1 <- newCoVar s1 s2 
+              ; cv2 <- newCoVar t1 t2 
+              ; setCoBind cv $ 
+                mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2) 
+              ; cc1 <- canEq fl cv1 s1 s2 
+              ; cc2 <- canEq fl cv2 t1 t2 
+              ; return (cc1 `andCCan` cc2) } 
+
+      else if isDerived fl 
+      then do { cv1 <- newDerivedId (EqPred s1 s2)
+              ; cv2 <- newDerivedId (EqPred t1 t2)
+              ; cc1 <- canEq fl cv1 s1 s2 
+              ; cc2 <- canEq fl cv2 t1 t2 
+              ; return (cc1 `andCCan` cc2) } 
+      
+      else return emptyCCan    -- We cannot decompose given applications
+      	   	  	       -- because we no longer have 'left' and 'right'
 
 canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {})
  | tcIsForAllTy s1, tcIsForAllTy s2, 
@@ -749,10 +698,10 @@ canEqLeaf _untch fl cv cls1 cls2
   | cls1 `re_orient` cls2
   = do { cv' <- if isWanted fl 
                 then do { cv' <- newCoVar s2 s1 
-                        ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv') 
+                        ; setCoBind cv $ mkSymCo (mkCoVarCo cv') 
                         ; return cv' } 
-                else if isGiven fl then 
-                         newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv))
+                else if isGivenOrSolved fl then
+                         newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
                 else -- Derived
                     newDerivedId (EqPred s2 s1)
        ; canEqLeafOriented fl cv' cls2 s1 }
@@ -783,18 +732,18 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2         -- cv : F tys1
        ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
                                                  -- co2  :: xi2 ~ s2
        ; let ccs = ccs1 `andCCan` ccs2
-             no_flattening_happened = isEmptyCCan ccs
-       ; cv_new <- if no_flattening_happened then return cv
-                   else if isGiven fl        then return cv
+             no_flattening_happened = all isReflCo (co2:cos1)
+       ; cv_new <- if no_flattening_happened  then return cv
+                   else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
                          do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
                                  -- cv' : F xis ~ xi2
                             ; let -- fun_co :: F xis1 ~ F tys1
-                                 fun_co = mkTyConCoercion fn cos1
+                                 fun_co = mkTyConAppCo fn cos1
                                  -- want_co :: F tys1 ~ s2
-                                 want_co = mkSymCoercion fun_co
-                                           `mkTransCoercion` mkCoVarCoercion cv'
-                                           `mkTransCoercion` co2
+                                 want_co = mkSymCo fun_co
+                                           `mkTransCo` mkCoVarCo cv'
+                                           `mkTransCo` co2
                             ; setCoBind cv  want_co
                             ; return cv' }
                    else -- Derived 
@@ -829,12 +778,12 @@ canEqLeafTyVarLeft fl cv tv s2       -- cv : tv ~ s2
        ; case mxi2' of {
            Nothing   -> canEqFailure fl cv ;
            Just xi2' ->
-    do { let no_flattening_happened = isEmptyCCan ccs2
-       ; cv_new <- if no_flattening_happened then return cv
-                   else if isGiven fl        then return cv
+    do { let no_flattening_happened = isReflCo co
+       ; cv_new <- if no_flattening_happened  then return cv
+                   else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
                          do { cv' <- newCoVar (mkTyVarTy tv) xi2'  -- cv' : tv ~ xi2
-                            ; setCoBind cv  (mkCoVarCoercion cv' `mkTransCoercion` co)
+                            ; setCoBind cv  (mkCoVarCo cv' `mkTransCo` co)
                             ; return cv' }
                    else -- Derived
                        newDerivedId (EqPred (mkTyVarTy tv) xi2')
@@ -898,7 +847,7 @@ expandAway tv (FunTy ty1 ty2)
 expandAway tv ty@(ForAllTy {}) 
   = let (tvs,rho) = splitForAllTys ty
         tvs_knds  = map tyVarKind tvs 
-    in if tv `elemVarSet` tyVarsOfTypes tvs_knds then 
+    in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
        -- Can't expand away the kinds unless we create 
        -- fresh variables which we don't want to do at this point.
            Nothing 
@@ -1057,15 +1006,15 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
        ; mapM (do_one subst) eqs }
   where 
     fl' = case fl of 
-             Given _     -> panic "mkFunDepEqns"
+             Given {}    -> panic "mkFunDepEqns"
              Wanted  loc -> Wanted  (push_ctx loc)
              Derived loc -> Derived (push_ctx loc)
 
     push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
 
     do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
-       = do { let sty1 = substTy subst ty1
-                  sty2 = substTy subst ty2
+       = do { let sty1 = Type.substTy subst ty1
+                  sty2 = Type.substTy subst ty2
             ; ev <- newCoVar sty1 sty2
             ; return (i, mkEvVarX ev fl') }
 
@@ -1077,8 +1026,8 @@ rewriteDictParams param_eqs tys
   where
     do_one :: Type -> Int -> (Type,Coercion)
     do_one ty n = case lookup n param_eqs of
-                    Just wev -> (get_fst_ty wev, mkCoVarCoercion (evVarOf wev))
-                    Nothing  -> (ty,ty)		-- Identity
+                    Just wev -> (get_fst_ty wev, mkCoVarCo (evVarOf wev))
+                    Nothing  -> (ty,             mkReflCo ty)	-- Identity
 
     get_fst_ty wev = case evVarOfPred wev of
                           EqPred ty1 _ -> ty1
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 8db89b9..8fc8a24 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -8,19 +8,15 @@ Typechecking class declarations
 \begin{code}
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
 		    findMethodBind, instantiateMethod, tcInstanceMethodBody,
-		    mkGenericDefMethBind, getGenericInstances, 
+		    mkGenericDefMethBind,
 		    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
 		  ) where
 
 #include "HsVersions.h"
 
 import HsSyn
-import RnHsSyn
-import RnExpr
-import Inst
-import InstEnv
-import TcPat( addInlinePrags )
 import TcEnv
+import TcPat( addInlinePrags )
 import TcBinds
 import TcUnify
 import TcHsType
@@ -28,21 +24,15 @@ import TcMType
 import TcType
 import TcRnMonad
 import BuildTyCl( TcMethInfo )
-import Generics
 import Class
-import TyCon
-import MkId
 import Id
 import Name
-import Var
 import NameEnv
 import NameSet
+import Var
 import Outputable
-import PrelNames
 import DynFlags
 import ErrUtils
-import Util
-import ListSetOps
 import SrcLoc
 import Maybes
 import BasicTypes
@@ -50,7 +40,6 @@ import Bag
 import FastString
 
 import Control.Monad
-import Data.List
 \end{code}
 
 
@@ -94,51 +83,43 @@ Death to "ExpandingDicts".
 %************************************************************************
 
 \begin{code}
-tcClassSigs :: Name	    		-- Name of the class
+tcClassSigs :: Name	             -- Name of the class
 	    -> [LSig Name]
 	    -> LHsBinds Name
-	    -> TcM [TcMethInfo]
-
+	    -> TcM ([TcMethInfo],    -- Exactly one for each method
+                    NameEnv Type)    -- Types of the generic-default methods
 tcClassSigs clas sigs def_methods
-  = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names)) 
-                        (bagToList def_methods)
-       ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
-  where
-    op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
-    op_names = [n   |     (L _ (TypeSig (L _ n) _)) <- op_sigs]
-
-checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
-  -- Check default bindings
-  -- 	a) must be for a class op for this class
-  --	b) must be all generic or all non-generic
-checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
-  = do {  	-- Check that the op is from this class
- 	 checkTc (op `elem` ops) (badMethodErr clas op)
-
-   	-- Check that all the defns ar generic, or none are
-       ; case (none_generic, all_generic) of
-           (True, _) -> return (op, VanillaDM)
-           (_, True) -> return (op, GenericDM)
-           _         -> failWith (mixedGenericErr op)
-    }
-  where
-    n_generic    = count (isJust . maybeGenericMatch) matches
-    none_generic = n_generic == 0
-    all_generic  = matches `lengthIs` n_generic
+  = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+       ; let gen_dm_env = mkNameEnv gen_dm_prs
 
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+       ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
 
+       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+       ; sequence_ [ failWithTc (badMethodErr clas n)
+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
+		   -- Value binding for non class-method (ie no TypeSig)
 
-tcClassSig :: NameEnv DefMethSpec	-- Info about default methods; 
-	   -> LSig Name
-	   -> TcM TcMethInfo
+       ; sequence_ [ failWithTc (badGenericMethod clas n)
+                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+		   -- Generic signature without value binding
 
-tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
-  = setSrcSpan loc $ do
-    { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
-    ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
-    ; return (op_name, dm, op_ty) }
-tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
+       ; return (op_info, gen_dm_env) }
+  where
+    vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty) <- sigs]
+    gen_sigs     = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
+    dm_bind_names :: [Name]	-- These ones have a value binding in the class decl
+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+    tc_sig genop_env (L _ op_name, op_hs_ty)
+      = do { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
+           ; let dm | op_name `elemNameEnv` genop_env = GenericDM
+                    | op_name `elem` dm_bind_names    = VanillaDM
+                    | otherwise                       = NoDM
+           ; return (op_name, dm, op_ty) }
+
+    tc_gen_sig (L _ op_name, gen_hs_ty)
+      = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+           ; return (op_name, gen_op_ty) }
 \end{code}
 
 
@@ -174,20 +155,21 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
 	; this_dict <- newEvVar pred
 
+	; traceTc "TIM2" (ppr sigs)
 	; let tc_dm = tcDefMeth clas clas_tyvars
-				this_dict default_binds
+				this_dict default_binds 
 	      			sig_fn prag_fn
 
 	; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                       mapM tc_dm op_items
 
-	; return (listToBag (catMaybes dm_binds)) }
+	; return (unionManyBags dm_binds) }
 
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
           -> SigFun -> PragFun -> ClassOpItem
-          -> TcM (Maybe (LHsBind Id))
+          -> TcM (LHsBinds TcId)
 -- Generate code for polymorphic default methods only (hence DefMeth)
 -- (Generic default methods have turned into instance decls by now.)
 -- This is incompatible with Hugs, which expects a polymorphic 
@@ -196,40 +178,45 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
   = case dm_info of
-      NoDefMeth       -> return Nothing
-      GenDefMeth      -> return Nothing
-      DefMeth dm_name -> do
-    	{ let sel_name = idName sel_id
-	; local_dm_name <- newLocalName sel_name
- 	  -- Base the local_dm_name on the selector name, because
- 	  -- type errors from tcInstanceMethodBody come from here
-
-		-- See Note [Silly default-method bind]
-		-- (possibly out of date)
-
-	; let meth_bind = findMethodBind sel_name binds_in
-			  `orElse` pprPanic "tcDefMeth" (ppr sel_id)
-		-- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
-	      dm_sig_fn  _  = sig_fn sel_name
-	      dm_id         = mkDefaultMethodId sel_id dm_name
-	      local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
-	      local_dm_id   = mkLocalId local_dm_name local_dm_type
-              prags         = prag_fn sel_name
-
-        ; dm_id_w_inline <- addInlinePrags dm_id prags
-        ; spec_prags     <- tcSpecPrags dm_id prags
-
-        ; warnTc (not (null spec_prags))
-                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
-                  <+> quotes (ppr sel_name))
-
-        ; liftM Just $
-          tcInstanceMethodBody (ClsSkol clas)
-                               tyvars 
-                               [this_dict]
-                               dm_id_w_inline local_dm_id
-                               dm_sig_fn IsDefaultMethod meth_bind }
+      NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+                               ; return emptyBag }
+      DefMeth dm_name    -> tc_dm dm_name 
+      GenDefMeth dm_name -> tc_dm dm_name 
+  where
+    sel_name      = idName sel_id
+    prags         = prag_fn sel_name
+    dm_sig_fn  _  = sig_fn sel_name
+    dm_bind       = findMethodBind sel_name binds_in
+	            `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+    -- Eg.   class C a where
+    --          op :: forall b. Eq b => a -> [b] -> a
+    --		gen_op :: a -> a
+    -- 		generic gen_op :: D a => a -> a
+    -- The "local_dm_ty" is precisely the type in the above
+    -- type signatures, ie with no "forall a. C a =>" prefix
+
+    tc_dm dm_name 
+      = do { dm_id <- tcLookupId dm_name
+	   ; local_dm_name <- newLocalName sel_name
+ 	     -- Base the local_dm_name on the selector name, because
+ 	     -- type errors from tcInstanceMethodBody come from here
+
+           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+	         local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+           ; dm_id_w_inline <- addInlinePrags dm_id prags
+           ; spec_prags     <- tcSpecPrags dm_id prags
+
+           ; warnTc (not (null spec_prags))
+                    (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                     <+> quotes (ppr sel_name))
+
+           ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+                                             dm_id_w_inline local_dm_id dm_sig_fn 
+                                             IsDefaultMethod dm_bind
+
+           ; return (unitBag tc_bind) }
 
 ---------------
 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
@@ -246,7 +233,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
           let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
                              -- Substitute the local_meth_name for the binder
 			     -- NB: the binding is always a FunBind
-
+        ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) 
 	; (ev_binds, (tc_bind, _)) 
                <- checkConstraints skol_info tyvars dfun_ev_vars $
 		  tcExtendIdEnv [local_meth_id] $
@@ -359,179 +346,22 @@ gives rise to the instance declarations
 	  op Unit      = ...
 
 \begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
   = 	-- A generic default method
-    	-- If the method is defined generically, we can only do the job if the
-	-- instance declaration is for a single-parameter type class with
-	-- a type constructor applied to type arguments in the instance decl
-	-- 	(checkTc, so False provokes the error)
-    do	{ checkTc (isJust maybe_tycon)
-	 	  (badGenericInstance sel_id (notSimple inst_tys))
-	; checkTc (tyConHasGenerics tycon)
-	   	  (badGenericInstance sel_id (notGeneric tycon))
-
-	; dflags <- getDOpts
+    	-- If the method is defined generically, we only have to call the
+        -- dm_name.
+    do	{ dflags <- getDOpts
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 		   (vcat [ppr clas <+> ppr inst_tys,
 			  nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
-		-- Rename it before returning it
-	; (rn_rhs, _) <- rnLExpr rhs
         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
-                                    [mkSimpleMatch [] rn_rhs]) }
+                                    [mkSimpleMatch [] rhs]) }
   where
-    rhs = mkGenericRhs sel_id clas_tyvar tycon
-
-	  -- The tycon is only used in the generic case, and in that
-	  -- case we require that the instance decl is for a single-parameter
-	  -- type class with type variable arguments:
-	  --	instance (...) => C (T a b)
-    clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
-    Just tycon	= maybe_tycon
-    maybe_tycon = case inst_tys of 
-			[ty] -> case tcSplitTyConApp_maybe ty of
-				  Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
-				  _    						  -> Nothing
-			_ -> Nothing
-
-
----------------------------
-getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] 
-getGenericInstances class_decls
-  = do	{ gen_inst_infos <- mapM (addLocM get_generics) class_decls
-	; let { gen_inst_info = concat gen_inst_infos }
-
-	-- Return right away if there is no generic stuff
-	; if null gen_inst_info then return []
-	  else do 
-
-	-- Otherwise print it out
-        { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
-                                2 (vcat (map pprInstInfoDetails gen_inst_info))
-	; return gen_inst_info }}
-
-get_generics :: TyClDecl Name -> TcM [InstInfo Name]
-get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
-  | null generic_binds
-  = return [] -- The comon case: no generic default methods
-
-  | otherwise	-- A source class decl with generic default methods
-  = recoverM (return [])                                $
-    tcAddDeclCtxt decl                                  $ do
-    clas <- tcLookupLocatedClass class_name
-
-	-- Group by type, and
-	-- make an InstInfo out of each group
-    let
-	groups = groupWith listToBag generic_binds
-
-    inst_infos <- mapM (mkGenericInstance clas) groups
-
-	-- Check that there is only one InstInfo for each type constructor
-  	-- The main way this can fail is if you write
-	--	f {| a+b |} ... = ...
-	--	f {| x+y |} ... = ...
-	-- Then at this point we'll have an InstInfo for each
-	--
-	-- The class should be unary, which is why simpleInstInfoTyCon should be ok
-    let
-	tc_inst_infos :: [(TyCon, InstInfo Name)]
-	tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
-	bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
-			      group `lengthExceeds` 1]
-	get_uniq (tc,_) = getUnique tc
-
-    mapM_ (addErrTc . dupGenericInsts) bad_groups
-
-	-- Check that there is an InstInfo for each generic type constructor
-    let
-	missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
-
-    checkTc (null missing) (missingGenericInstances missing)
-
-    return inst_infos
-  where
-    generic_binds :: [(HsType Name, LHsBind Name)]
-    generic_binds = getGenericBinds def_methods
-get_generics decl = pprPanic "get_generics" (ppr decl)
-
-
----------------------------------
-getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
-  -- Takes a group of method bindings, finds the generic ones, and returns
-  -- them in finite map indexed by the type parameter in the definition.
-getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-
-getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
-getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
-  = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
-  where
-    wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
-getGenericBind _
-  = []
-
-groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
-groupWith _  [] 	 = []
-groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
-    where
-      vs              = map snd this
-      (this,rest)     = partition same_t prs
-      same_t (t', _v) = t `eqPatType` t'
-
-eqPatLType :: LHsType Name -> LHsType Name -> Bool
-eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
-
-eqPatType :: HsType Name -> HsType Name -> Bool
--- A very simple equality function, only for 
--- type patterns in generic function definitions.
-eqPatType (HsTyVar v1)       (HsTyVar v2)    	= v1==v2
-eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2) 	= s1 `eqPatLType` s2 && t1 `eqPatLType` t2
-eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
-eqPatType (HsNumTy n1)	     (HsNumTy n2)	= n1 == n2
-eqPatType (HsParTy t1)	     t2			= unLoc t1 `eqPatType` t2
-eqPatType t1		     (HsParTy t2)	= t1 `eqPatType` unLoc t2
-eqPatType _ _ = False
-
----------------------------------
-mkGenericInstance :: Class
-		  -> (HsType Name, LHsBinds Name)
-		  -> TcM (InstInfo Name)
-
-mkGenericInstance clas (hs_ty, binds) = do
-  -- Make a generic instance declaration
-  -- For example:	instance (C a, C b) => C (a+b) where { binds }
-
-	-- Extract the universally quantified type variables
-	-- and wrap them as forall'd tyvars, so that kind inference
-	-- works in the standard way
-    let
-	sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
-                  extractHsTyVars (noLoc hs_ty)
-	hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-
-	-- Type-check the instance type, and check its form
-    forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
-    let
-	(tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
-
-    checkTc (validGenericInstanceType inst_ty)
-            (badGenericInstanceType binds)
-
-	-- Make the dictionary function.
-    span <- getSrcSpanM
-    overlap_flag <- getOverlapFlag
-    dfun_name <- newDFunName clas [inst_ty] span
-    let
-	inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
-	dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
-        ispec      = mkLocalInstance dfun_id overlap_flag
-
-    return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
+    rhs = nlHsVar dm_name
 \end{code}
 
-
 %************************************************************************
 %*									*
 		Error messages
@@ -562,6 +392,11 @@ badMethodErr clas op
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
 	  ptext (sLit "does not have a method"), quotes (ppr op)]
 
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
+	  ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
 badATErr :: Class -> Name -> SDoc
 badATErr clas at
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
@@ -570,23 +405,7 @@ badATErr clas at
 omittedATWarn :: Name -> SDoc
 omittedATWarn at
   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
-  = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
-	 because]
-
-notSimple :: [Type] -> SDoc
-notSimple inst_tys
-  = vcat [ptext (sLit "because the instance type(s)"), 
-	  nest 2 (ppr inst_tys),
-	  ptext (sLit "is not a simple type of form (T a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
-  = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+> 
-	  ptext (sLit "was not compiled with -XGenerics")]
-
+{-
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
@@ -604,8 +423,10 @@ dupGenericInsts tc_inst_infos
     ]
   where 
     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
-  = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+-}
+badDmPrag :: Id -> Sig Name -> TcM ()
+badDmPrag sel_id prag
+  = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") 
+              <+> quotes (ppr sel_id) 
+              <+> ptext (sLit "lacks an accompanying binding"))
 \end{code}
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1798be3..fab7c61 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -40,10 +40,13 @@ import Name
 import NameSet
 import TyCon
 import TcType
+import BuildTyCl
+import BasicTypes
 import Var
 import VarSet
 import PrelNames
 import SrcLoc
+import UniqSupply
 import Util
 import ListSetOps
 import Outputable
@@ -125,6 +128,9 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
 		   ds_cls = c, ds_tys = tys, ds_theta = rhs })
   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
 	    <+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+  ppr = pprDerivSpec
 \end{code}
 
 
@@ -292,17 +298,21 @@ both of them.  So we gather defs/uses from deriving just like anything else.
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
-	    -> TcM ([InstInfo Name],	-- The generated "instance decls"
-		    HsValBinds Name,	-- Extra generated top-level bindings
-                    DefUses)
+            -> TcM ([InstInfo Name] -- The generated "instance decls"
+                   ,HsValBinds Name -- Extra generated top-level bindings
+                   ,DefUses
+                   ,[TyCon]         -- Extra generated top-level types
+                   ,[TyCon])        -- Extra generated type family instances
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
+  = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
 	  is_boot <- tcIsHsBoot
 	; traceTc "tcDeriving" (ppr is_boot)
-	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+	; (early_specs, genericsExtras) 
+                <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+        ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
 
 	; overlap_flag <- getOverlapFlag
 	; let (infer_specs, given_specs) = splitEithers early_specs
@@ -313,20 +323,44 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 	; insts2 <- mapM (genInst False overlap_flag) final_specs
 
-		 -- Generate the generic to/from functions from each type declaration
-	; gen_binds <- mkGenericBinds is_boot tycl_decls
-	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
+	-- We no longer generate the old generic to/from functions
+        -- from each type declaration, so this is emptyBag
+	; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+	
+	; (inst_info, rn_binds, rn_dus)
+                <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
 
+	; dflags <- getDOpts
+	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+	         (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
+{-
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-
-	; return (inst_info, rn_binds, rn_dus) }
+-}
+	; return ( inst_info, rn_binds, rn_dus
+                 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
   where
-    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
-    ddump_deriving inst_infos extra_binds
-      = hang (ptext (sLit "Derived instances"))
-           2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
-              $$ ppr extra_binds)
+    ddump_deriving :: [InstInfo Name] -> HsValBinds Name 
+                   -> [MetaTyCons] -- ^ Empty data constructors
+                   -> [TyCon]      -- ^ Rep type family instances
+                   -> [[(InstInfo RdrName, DerivAuxBinds)]] 
+                      -- ^ Instances for the repMetaTys
+                   -> SDoc
+    ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+      =    hang (ptext (sLit "Derived instances"))
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+                 $$ ppr extra_binds)
+        $$ hangP "Generic representation" (
+              hangP "Generated datatypes for meta-information"
+               (vcat (map ppr repMetaTys))
+           -- The Outputable instance for TyCon unfortunately only prints the name...
+           $$ hangP "Representation types" 
+                (vcat (map ppr  repTyCons))
+           $$ hangP "Meta-information instances"
+                (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
+    
+    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+
 
 renameDeriv :: Bool -> LHsBinds RdrName
 	    -> [(InstInfo RdrName, DerivAuxBinds)]
@@ -379,26 +413,12 @@ renameDeriv is_boot gen_binds insts
 		-- scope (yuk), and rename the method binds
 	   ASSERT( null sigs )
 	   bindLocalNames (map Var.varName tyvars) $
- 	   do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+ 	   do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
 	      ; let binds' = VanillaInst rn_binds [] standalone_deriv
               ; return (inst_info { iBinds = binds' }, fvs) }
 	where
 	  (tyvars,_, clas,_) = instanceHead inst
 	  clas_nm            = className clas
-
------------------------------------------
-mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
-mkGenericBinds is_boot tycl_decls
-  | is_boot 
-  = return emptyBag
-  | otherwise
-  = do	{ tcs <- mapM tcLookupTyCon [ tcdName d 
-    	      	      		    | L _ d <- tycl_decls, isDataDecl d ]
-	; return (unionManyBags [ mkTyConGenericBinds tc
-				| tc <- tcs, tyConHasGenerics tc ]) }
-		-- We are only interested in the data type declarations,
-		-- and then only in the ones whose 'has-generics' flag is on
-		-- The predicate tyConHasGenerics finds both of these
 \end{code}
 
 Note [Newtype deriving and unused constructors]
@@ -430,34 +450,93 @@ stored in NewTypeDerived.
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 
 \begin{code}
+-- Make the "extras" for the generic representation
+mkGenDerivExtras :: TyCon 
+                 -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
+mkGenDerivExtras tc = do
+        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
+        ; metaInsts                <- genDtMeta (tc, metaTyCons)
+        ; return (metaTyCons, rep0TyInst, metaInsts) }
+
 makeDerivSpecs :: Bool 
 	       -> [LTyClDecl Name] 
-               -> [LInstDecl Name]
+	       -> [LInstDecl Name]
 	       -> [LDerivDecl Name] 
-	       -> TcM [EarlyDerivSpec]
-
+	       -> TcM ( [EarlyDerivSpec]
+                      , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
-  | is_boot 	-- No 'deriving' at all in hs-boot files
-  = do	{ mapM_ add_deriv_err deriv_locs 
-	; return [] }
+  | is_boot     -- No 'deriving' at all in hs-boot files
+  = do  { mapM_ add_deriv_err deriv_locs 
+        ; return ([],[]) }
   | otherwise
-  = do	{ eqns1 <- mapAndRecoverM deriveTyData all_tydata
-	; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
-	; return (eqns1 ++ eqns2) }
+  = do  { eqns1 <- mapAndRecoverM deriveTyData all_tydata
+        ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
+
+        -- Generic representation stuff: we might need to add some "extras"
+        -- to the instances
+        ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
+        ; generic_extras_deriv <- if not xDerRep
+                                   -- No extras if the flag is off
+                                   then (return [])
+                                    else do {
+          let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+        -- Select only those types that derive Generic
+        ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+                                       , getClassName c == Just genClassName ]
+        ; let sel_deriv_decls = catMaybes [ getTypeName t
+                                  | L _ (DerivDecl (L _ t)) <- deriv_decls
+                                  , getClassName t == Just genClassName ] 
+        ; derTyDecls <- mapM tcLookupTyCon $ 
+                         filter (needsExtras xDerRep
+                                  (sel_tydata ++ sel_deriv_decls)) allTyNames
+        -- We need to generate the extras to add to what has
+        -- already been derived
+        ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
+          pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
+          pprTrace "derTyDecls" (ppr derTyDecls) $
+          pprTrace "deriv_decls" (ppr deriv_decls) $ -}
+          mapM mkGenDerivExtras derTyDecls }
+
+        -- Merge and return
+        ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
   where
+      -- We need extras if the flag DeriveGeneric is on and this type is 
+      -- deriving Generic
+    needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
+
+    -- Extracts the name of the class in the deriving
+    getClassName :: HsType Name -> Maybe Name
+    getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
+    getClassName (HsPredTy (HsClassP n _))  = Just n
+    getClassName _                          = Nothing
+
+    -- Extracts the name of the type in the deriving
+    -- This function (and also getClassName above) is not really nice, and I
+    -- might not have covered all possible cases. I wonder if there is no easier
+    -- way to extract class and type name from a LDerivDecl...
+    getTypeName :: HsType Name -> Maybe Name
+    getTypeName (HsForAllTy _ _ _ (L _ n))      = getTypeName n
+    getTypeName (HsTyVar n)                     = Just n
+    getTypeName (HsOpTy _ (L _ n) _)            = Just n
+    getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+    getTypeName (HsAppTy (L _ n) _)             = getTypeName n
+    getTypeName (HsParTy (L _ n))               = getTypeName n
+    getTypeName (HsKindSig (L _ n) _)           = getTypeName n
+    getTypeName _                               = Nothing
+
     extractTyDataPreds decls
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 
     all_tydata :: [(LHsType Name, LTyClDecl Name)]
-	-- Derived predicate paired with its data type declaration
+        -- Derived predicate paired with its data type declaration
     all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
 
     deriv_locs = map (getLoc . snd) all_tydata
-		 ++ map getLoc deriv_decls
+                 ++ map getLoc deriv_decls
 
     add_deriv_err loc = setSrcSpan loc $
-			addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
-				   2 (ptext (sLit "Use an instance declaration instead")))
+                        addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+                                   2 (ptext (sLit "Use an instance declaration instead")))
 
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
@@ -727,6 +806,11 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
 inferConstraints _ cls inst_tys rep_tc rep_tc_args
+  -- Generic constraints are easy
+  | cls `hasKey` genClassKey
+  = []
+  -- The others are a bit more complicated
+  | otherwise
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
     stupid_constraints ++ extra_constraints
     ++ sc_constraints ++ con_arg_constraints
@@ -830,6 +914,8 @@ sideConditions mtheta cls
     	                                   cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
     	                                   cond_functorOK False)
+  | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
+                                           checkFlag Opt_DeriveGeneric)
   | otherwise = Nothing
   where
     cls_key = getUnique cls
@@ -848,7 +934,7 @@ orCond c1 c2 tc
 	Nothing -> Nothing	    -- c1 succeeds
 	Just x  -> case c2 tc of    -- c1 fails
 		     Nothing -> Nothing
-		     Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
+		     Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
 			            -- Both fail
 
 andCond :: Condition -> Condition -> Condition
@@ -874,11 +960,14 @@ cond_stdOK Nothing (_, rep_tc)
     check_con con 
       | isVanillaDataCon con
       , all isTauTy (dataConOrigArgTys con) = Nothing
-      | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
+      | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
   
 no_cons_why :: TyCon -> SDoc
 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> 
-		     ptext (sLit "has no data constructors")
+		     ptext (sLit "must have at least one data constructor")
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) = canDoGenerics t
 
 cond_enumOrProduct :: Condition
 cond_enumOrProduct = cond_isEnumeration `orCond` 
@@ -893,7 +982,7 @@ cond_noUnliftedArgs (_, tc)
   where
     bad_cons = [ con | con <- tyConDataCons tc
 		     , any isUnLiftedType (dataConOrigArgTys con) ]
-    why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
+    why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
 
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
@@ -901,7 +990,7 @@ cond_isEnumeration (_, rep_tc)
   | otherwise		        = Just why
   where
     why = sep [ quotes (pprSourceTyCon rep_tc) <+> 
-	          ptext (sLit "is not an enumeration type")
+	          ptext (sLit "must be an enumeration type")
               , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
 		  -- See Note [Enumeration types] in TyCon
 
@@ -911,7 +1000,7 @@ cond_isProduct (_, rep_tc)
   | otherwise	          = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
-	  ptext (sLit "does not have precisely one constructor")
+	  ptext (sLit "must have precisely one constructor")
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
@@ -924,9 +1013,9 @@ cond_typeableOK (_, tc)
   | otherwise	      = Nothing
   where
     too_many = quotes (pprSourceTyCon tc) <+> 
-	       ptext (sLit "has too many arguments")
+	       ptext (sLit "must have 7 or fewer arguments")
     bad_kind = quotes (pprSourceTyCon tc) <+> 
-	       ptext (sLit "has arguments of kind other than `*'")
+	       ptext (sLit "must only have arguments of kind `*'")
 
 functorLikeClassKeys :: [Unique]
 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
@@ -941,11 +1030,11 @@ cond_functorOK :: Bool -> Condition
 cond_functorOK allowFunctions (_, rep_tc)
   | null tc_tvs
   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) 
-          <+> ptext (sLit "has no parameters"))
+          <+> ptext (sLit "must have some type parameters"))
 
   | not (null bad_stupid_theta)
   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) 
-          <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+          <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
 
   | otherwise
   = msum (map check_con data_cons)	-- msum picks the first 'Just', if any
@@ -972,10 +1061,10 @@ cond_functorOK allowFunctions (_, rep_tc)
                       , ft_bad_app = Just (badCon con wrong_arg)
                       , ft_forall = \_ x   -> x }
                     
-    existential = ptext (sLit "has existential arguments")
-    covariant 	= ptext (sLit "uses the type variable in a function argument")
-    functions 	= ptext (sLit "contains function types")
-    wrong_arg 	= ptext (sLit "uses the type variable in an argument other than the last")
+    existential = ptext (sLit "must not have existential arguments")
+    covariant 	= ptext (sLit "must not use the type variable in a function argument")
+    functions 	= ptext (sLit "must not contain function types")
+    wrong_arg 	= ptext (sLit "must not use the type variable in an argument other than the last")
 
 checkFlag :: ExtensionFlag -> Condition
 checkFlag flag (dflags, _)
@@ -999,11 +1088,11 @@ std_class_via_iso clas
 
 
 non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
 -- even with -XGeneralizedNewtypeDeriving
 non_iso_class cls 
-  = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
-			 typeableClassKeys)
+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+                         , genClassKey] ++ typeableClassKeys)
 
 typeableClassKeys :: [Unique]
 typeableClassKeys = map getUnique typeableClassNames
@@ -1294,7 +1383,7 @@ inferInstanceContexts oflag infer_specs
 		  
  	   ; let tv_set = mkVarSet tyvars
 	         weird_preds = [pred | pred <- deriv_rhs
-                                     , not (tyVarsOfPred pred `subVarSet` tv_set)]  
+                                     , not (tyVarsOfPred pred `subVarSet` tv_set)]
 	   ; mapM_ (addErrTc . badDerivedPred) weird_preds	
 
            ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
@@ -1425,14 +1514,12 @@ genInst standalone_deriv oflag
   where
     inst_spec = mkInstance oflag theta spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
-	      Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+              Just co_con -> mkAxInstCo co_con rep_tc_args
     	      Nothing     -> id_co
 	      -- Not a family => rep_tycon = main tycon
-    co2 = case newTyConCo_maybe rep_tycon of
-	      Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
-              Nothing     -> id_co  -- The newtype is transparent; no need for a cast
-    co = co1 `mkTransCoI` co2
-    id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
+    co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
+    co  = co1 `mkTransCo` co2
+    id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
 
 -- Example: newtype instance N [a] = N1 (Tree a) 
 --          deriving instance Eq b => Eq (N [(b,b)])
@@ -1453,20 +1540,159 @@ genDerivBinds loc fix_env clas tycon
 	Nothing	    -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
   where
     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
-    gen_list = [(eqClassKey,       gen_Eq_binds)
- 	       ,(ordClassKey,      gen_Ord_binds)
- 	       ,(enumClassKey,     gen_Enum_binds)
- 	       ,(boundedClassKey,  gen_Bounded_binds)
- 	       ,(ixClassKey,       gen_Ix_binds)
- 	       ,(showClassKey,     gen_Show_binds fix_env)
- 	       ,(readClassKey,     gen_Read_binds fix_env)
-	       ,(dataClassKey,     gen_Data_binds)
-	       ,(functorClassKey,  gen_Functor_binds)
-	       ,(foldableClassKey, gen_Foldable_binds)
-	       ,(traversableClassKey, gen_Traversable_binds)
+    gen_list = [(eqClassKey,            gen_Eq_binds)
+ 	       ,(ordClassKey,           gen_Ord_binds)
+ 	       ,(enumClassKey,          gen_Enum_binds)
+ 	       ,(boundedClassKey,       gen_Bounded_binds)
+ 	       ,(ixClassKey,            gen_Ix_binds)
+ 	       ,(showClassKey,          gen_Show_binds fix_env)
+ 	       ,(readClassKey,          gen_Read_binds fix_env)
+	       ,(dataClassKey,          gen_Data_binds)
+	       ,(functorClassKey,       gen_Functor_binds)
+	       ,(foldableClassKey,      gen_Foldable_binds)
+	       ,(traversableClassKey,   gen_Traversable_binds)
+	       ,(genClassKey,           genGenericBinds)
  	       ]
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
+%*									*
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance 
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@genGenericBinds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericAll@ does all of them
+
+\begin{code}
+genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
+
+genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc =
+  do  uniqS <- newUniqueSupply
+      let
+        -- Uniques for everyone
+        (uniqD:uniqs) = uniqsFromSupply uniqS
+        (uniqsC,us) = splitAt (length tc_cons) uniqs
+        uniqsS :: [[Unique]] -- Unique supply for the S datatypes
+        uniqsS = mkUniqsS tc_arits us
+        mkUniqsS []    _  = []
+        mkUniqsS (n:t) us = case splitAt n us of
+                              (us1,us2) -> us1 : mkUniqsS t us2
+
+        tc_name   = tyConName tc
+        tc_cons   = tyConDataCons tc
+        tc_arits  = map dataConSourceArity tc_cons
+        
+        tc_occ    = nameOccName tc_name
+        d_occ     = mkGenD tc_occ
+        c_occ m   = mkGenC tc_occ m
+        s_occ m n = mkGenS tc_occ m n
+        mod_name  = nameModule (tyConName tc)
+        d_name    = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
+        c_names   = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
+                      | (u,m) <- zip uniqsC [0..] ]
+        s_names   = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan 
+                        | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
+        
+        mkTyCon name = ASSERT( isExternalName name )
+                         buildAlgTyCon name [] [] mkAbstractTyConRhs
+                           NonRecursive False NoParentTyCon Nothing
+
+      metaDTyCon  <- mkTyCon d_name
+      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
+      metaSTyCons <- mapM sequence 
+                       [ [ mkTyCon s_name 
+                         | s_name <- s_namesC ] | s_namesC <- s_names ]
+
+      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
+  
+      rep0_tycon <- tc_mkRepTyCon tc metaDts
+      
+      -- pprTrace "rep0" (ppr rep0_tycon) $
+      return (metaDts, rep0_tycon)
+{-
+genGenericAll :: TyCon
+                  -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericAll tc =
+  do  (metaDts, rep0_tycon)     <- genGenericRepExtras tc
+      clas                      <- tcLookupClass genClassName
+      dfun_name                 <- new_dfun_name clas tc
+      let
+        mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
+                               , [ {- No DerivAuxBinds -} ])
+        inst  = mkLocalInstance dfun NoOverlap
+        binds = VanillaInst (mkBindsRep tc) [] False
+
+        tvs   = tyConTyVars tc
+        tc_ty = mkTyConApp tc (mkTyVarTys tvs)
+        
+        dfun  = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
+      return (mkInstRep, metaDts, rep0_tycon)
+-}
+genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
+genDtMeta (tc,metaDts) =
+  do  dClas <- tcLookupClass datatypeClassName
+      d_dfun_name <- new_dfun_name dClas tc
+      cClas <- tcLookupClass constructorClassName
+      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
+      sClas <- tcLookupClass selectorClassName
+      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
+                                               | _ <- x ] 
+                                             | x <- metaS metaDts ])
+      fix_env <- getFixityEnv
+
+      let
+        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+        
+        -- Datatype
+        d_metaTycon = metaD metaDts
+        d_inst = mkLocalInstance d_dfun NoOverlap
+        d_binds = VanillaInst dBinds [] False
+        d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
+                    [ mkTyConTy d_metaTycon ]
+        d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
+        
+        -- Constructor
+        c_metaTycons = metaC metaDts
+        c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap 
+                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
+        c_binds = [ VanillaInst c [] False | c <- cBinds ]
+        c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
+                               [ mkTyConTy c ]
+        c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) 
+                   | (is,bs) <- myZip1 c_insts c_binds ]
+        
+        -- Selector
+        s_metaTycons = metaS metaDts
+        s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
+                    (myZip2 s_metaTycons s_dfun_names)
+        s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
+        s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
+                               [ mkTyConTy s ]
+        s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
+                     (myZip2 s_insts s_binds)
+       
+        myZip1 :: [a] -> [b] -> [(a,b)]
+        myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
+        
+        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
+        myZip2 l1 l2 =
+          ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
+            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
+        
+      return (d_mkInst : c_mkInst ++ concat s_mkInst)
+\end{code}
+
 
 %************************************************************************
 %*									*
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index c6789f4..94daff0 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -212,7 +212,7 @@ tcLookupFamInst tycon tys
        }
 
 tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
--- Find the instance of a data famliy
+-- Find the instance of a data family
 -- Note [Looking up family instances for deriving]
 tcLookupDataFamInst tycon tys
   | not (isFamilyTyCon tycon)
@@ -474,7 +474,7 @@ tcExtendGlobalTyVars gtv_var extra_global_tvs
 \begin{code}
 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
 	-- Just pop the new rules into the EPS and envt resp
-	-- All the rules come from an interface file, not soruce
+	-- All the rules come from an interface file, not source
 	-- Nevertheless, some may be for this module, if we read
 	-- its interface instead of its source code
 tcExtendRules lcl_rules thing_inside
@@ -639,7 +639,7 @@ data InstBindings a
 			-- witness dictionary is identical to the argument 
 			-- dictionary.  Hence no bindings, no pragmas.
 
-	CoercionI	-- The coercion maps from newtype to the representation type
+	Coercion	-- The coercion maps from newtype to the representation type
 			-- (mentioning type variables bound by the forall'd iSpec variables)
 			-- E.g.   newtype instance N [a] = N1 (Tree a)
 			-- 	  co : N [a] ~ Tree a
@@ -653,7 +653,7 @@ data InstBindings a
 pprInstInfo :: InstInfo a -> SDoc
 pprInstInfo info = hang (ptext (sLit "instance"))
                       2 (sep [ ifPprDebug (pprForAll tvs)
-                             , pprThetaArrow theta, ppr tau
+                             , pprThetaArrowTy theta, ppr tau
                              , ptext (sLit "where")])
   where
     (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
@@ -694,7 +694,7 @@ newDFunName clas tys loc
 \end{code}
 
 Make a name for the representation tycon of a family instance.  It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
 newGlobalBinder.
 
 \begin{code}
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 645c43a..b199053 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -16,14 +16,13 @@ import TcSMonad
 import TcType
 import TypeRep
 import Type( isTyVarTy )
-
+import Unify ( tcMatchTys )
 import Inst
 import InstEnv
-
 import TyCon
 import Name
 import NameEnv
-import Id	( idType )
+import Id	( idType, evVarPred )
 import Var
 import VarSet
 import VarEnv
@@ -106,7 +105,7 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
                        -- because they are unconditionally wrong
                        -- Moreover, if any of the insolubles are givens, stop right there
                        -- ignoring nested errors, because the code is inaccessible
-  = do { let (given, other) = partitionBag (isGiven . evVarX) insols
+  = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
              insol_implics  = filterBag ic_insol implics
        ; if isEmptyBag given
          then do { mapBagM_ (reportInsoluble ctxt) other
@@ -154,7 +153,8 @@ reportInsoluble ctxt (EvVarX ev flav)
   | otherwise
   = pprPanic "reportInsoluble" (pprEvVarWithType ev)
   where
-    inaccessible_msg | Given loc <- flav
+    inaccessible_msg | Given loc GivenOrig <- flav
+                       -- If a GivenSolved then we should not report inaccessible code
                      = hang (ptext (sLit "Inaccessible code in"))
                           2 (ppr (ctLocOrigin loc))
                      | otherwise = empty
@@ -223,7 +223,7 @@ pprWithArising ev_vars
   where
     first_loc = evVarX (head ev_vars)
     ppr_one (EvVarX v loc)
-       = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
+       = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
 
 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
@@ -300,8 +300,8 @@ getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp
                  ty1 ty2
   -- If the types in the error message are the same as the types we are unifying,
   -- don't add the extra expected/actual message
-  | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
-  | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
+  | act `eqType` ty1 && exp `eqType` ty2 = empty
+  | exp `eqType` ty1 && act `eqType` ty2 = empty
   | otherwise                                = mkExpectedActualMsg act exp
 
 getWantedEqExtra orig _ _ = pprArising orig
@@ -420,18 +420,18 @@ couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
 couldNotDeduce givens (wanteds, orig)
   = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
               2 (pprArising orig)
-         , vcat pp_givens ]
-  where
-    pp_givens
-      = case givens of
+         , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens 
+   = case givens of
          []     -> []
          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                  : map (ppr_given (ptext (sLit "or from"))) gs
-
-    ppr_given herald (gs,loc)
-      = hang (herald <+> pprEvVarTheta gs)
-           2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
-                  , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+    where ppr_given herald (gs,loc)
+           = hang (herald <+> pprEvVarTheta gs)
+                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+                       , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
 
 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 -- Add on extra info about the types themselves
@@ -574,9 +574,21 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
     mk_overlap_msg (matches, unifiers)
       = ASSERT( not (null matches) )
         vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
-				<+> pprPred pred)
+				<+> pprPredTy pred)
     	     ,	sep [ptext (sLit "Matching instances") <> colon,
     		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+             ,  if not (null overlapping_givens) then 
+                  sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+                else empty
+
+             ,  if null overlapping_givens && isSingleton matches && null unifiers then
+                -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) 
+                -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+                -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+                  sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+                else empty 
+
 	     ,	if not (isSingleton matches)
     		then 	-- Two or more matches
 		     empty
@@ -584,11 +596,39 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 		ASSERT( not (null unifiers) )
 		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
-			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
-			      ptext (sLit "when compiling the other instance declarations")])]
+			      if null (overlapping_givens) then
+                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+			                  ptext (sLit "when compiling the other instance declarations")]
+                              else empty])]
       where
     	ispecs = [ispec | (ispec, _) <- matches]
 
+        givens = getUserGivens ctxt
+        overlapping_givens = unifiable_givens givens
+
+        unifiable_givens [] = [] 
+        unifiable_givens (gg:ggs) 
+          | Just ggdoc <- matchable gg 
+          = ggdoc : unifiable_givens ggs 
+          | otherwise 
+          = unifiable_givens ggs 
+
+        matchable (evvars,gloc) 
+          = case ev_vars_matching of
+                 [] -> Nothing
+                 _  -> Just $ hang (pprTheta ev_vars_matching)
+                                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+                                       , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+            where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+                  ev_var_matches (ClassP clas' tys')
+                    | clas' == clas
+                    , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+                    = True 
+                  ev_var_matches (ClassP clas' tys') =
+                    any ev_var_matches (immSuperClasses clas' tys')
+                  ev_var_matches _ = False
+
+
 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 
 ----------------------
@@ -834,9 +874,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
 
 \begin{code}
 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 7d7c461..8b907d2 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -46,6 +46,7 @@ import TypeRep
 import Coercion
 import Var
 import VarSet
+import VarEnv
 import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
@@ -56,6 +57,7 @@ import SrcLoc
 import Util
 import ListSetOps
 import Maybes
+import ErrUtils
 import Outputable
 import FastString
 import Control.Monad
@@ -347,8 +349,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        ; co_res <- unifyType op_res_ty res_ty
        ; op_id <- tcLookupId op_name
        ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
-       ; return $ mkHsWrapCoI co_res $
-         OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
+       ; return $ mkHsWrapCo co_res $
+         OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
 
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)
@@ -356,8 +358,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
        ; co_res <- unifyType op_res_ty res_ty
        ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
-       ; return $ mkHsWrapCoI co_res $
-         OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
+       ; return $ mkHsWrapCo co_res $
+         OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --	\ x -> op x expr
@@ -367,8 +369,8 @@ tcExpr (SectionR op arg2) res_ty
        ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
        ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
-       ; return $ mkHsWrapCoI co_res $
-         SectionR (mkLHsWrapCoI co_fn op') arg2' } 
+       ; return $ mkHsWrapCo co_res $
+         SectionR (mkLHsWrapCo co_fn op') arg2' } 
 
 tcExpr (SectionL arg1 op) res_ty
   = do { (op', op_ty) <- tcInferFun op
@@ -379,15 +381,15 @@ tcExpr (SectionL arg1 op) res_ty
        ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
        ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
        ; arg1' <- tcArg op (arg1, arg1_ty, 1)
-       ; return $ mkHsWrapCoI co_res $
-         SectionL arg1' (mkLHsWrapCoI co_fn op') }
+       ; return $ mkHsWrapCo co_res $
+         SectionL arg1' (mkLHsWrapCo co_fn op') }
 
 tcExpr (ExplicitTuple tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let tup_tc = tupleTyCon boxity (length tup_args)
        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
        ; tup_args1 <- tcTupArgs tup_args arg_tys
-       ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
     
   | otherwise
   = -- The tup_args are a mixture of Present and Missing (for tuple sections)
@@ -406,19 +408,19 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
        -- Handle tuple sections where
        ; tup_args1 <- tcTupArgs tup_args arg_tys
        
-       ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
 
 tcExpr (ExplicitList _ exprs) res_ty
   = do 	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; exprs' <- mapM (tc_elt elt_ty) exprs
-	; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
+	; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
 tcExpr (ExplicitPArr _ exprs) res_ty	-- maybe empty
   = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
     	; exprs' <- mapM (tc_elt elt_ty) exprs	
-	; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
+	; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 \end{code}
@@ -476,12 +478,12 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
        -- and it maintains uniformity with other rebindable syntax
        ; return (HsIf (Just fun') pred' b1' b2') }
 
-tcExpr (HsDo do_or_lc stmts body _) res_ty
-  = tcDoStmts do_or_lc stmts body res_ty
+tcExpr (HsDo do_or_lc stmts _) res_ty
+  = tcDoStmts do_or_lc stmts res_ty
 
 tcExpr (HsProc pat cmd) res_ty
   = do	{ (pat', cmd', coi) <- tcProc pat cmd res_ty
-	; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
+	; return $ mkHsWrapCo coi (HsProc pat' cmd') }
 
 tcExpr e@(HsArrApp _ _ _ _ _) _
   = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), 
@@ -528,7 +530,7 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
 
         ; co_res <- unifyType actual_res_ty res_ty
         ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
-	; return $ mkHsWrapCoI co_res $ 
+	; return $ mkHsWrapCo co_res $ 
           RecordCon (L loc con_id) con_expr rbinds' } 
 \end{code}
 
@@ -664,7 +666,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 
 		-- Take apart a representative constructor
 	      con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
-	      (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
+	      (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
 	      con1_flds = dataConFieldLabels con1
 	      con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
    	      
@@ -702,10 +704,10 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 	; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
 	; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 
-	; let rec_res_ty    = substTy result_inst_env con1_res_ty
-	      con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+	; let rec_res_ty    = TcType.substTy result_inst_env con1_res_ty
+	      con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
 	      scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
-	      scrut_ty      = substTy scrut_subst con1_res_ty
+	      scrut_ty      = TcType.substTy scrut_subst con1_res_ty
 
         ; co_res <- unifyType rec_res_ty res_ty
 
@@ -720,11 +722,11 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 
 	-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
 	; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon 
-		       = WpCast $ mkTyConApp co_con scrut_inst_tys
+		       = WpCast $ mkAxInstCo co_con scrut_inst_tys
 		       | otherwise
 		       = idHsWrapper
 	-- Phew!
-        ; return $ mkHsWrapCoI co_res $
+        ; return $ mkHsWrapCo co_res $
           RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
 			           relevant_cons scrut_inst_tys result_inst_tys  }
   where
@@ -764,7 +766,7 @@ tcExpr (ArithSeq _ seq@(From expr)) res_ty
 	; expr' <- tcPolyExpr expr elt_ty
 	; enum_from <- newMethodFromName (ArithSeqOrigin seq) 
 			      enumFromName elt_ty 
-	; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
+	; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
 
 tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
   = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
@@ -772,7 +774,7 @@ tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) 
 			      enumFromThenName elt_ty 
-	; return $ mkHsWrapCoI coi 
+	; return $ mkHsWrapCo coi 
                     (ArithSeq enum_from_then (FromThen expr1' expr2')) }
 
 tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
@@ -781,7 +783,7 @@ tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) 
 		  	      enumFromToName elt_ty 
-	; return $ mkHsWrapCoI coi 
+	; return $ mkHsWrapCo coi 
                      (ArithSeq enum_from_to (FromTo expr1' expr2')) }
 
 tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
@@ -791,7 +793,7 @@ tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 	; expr3' <- tcPolyExpr expr3 elt_ty
 	; eft <- newMethodFromName (ArithSeqOrigin seq) 
 		      enumFromThenToName elt_ty 
-	; return $ mkHsWrapCoI coi 
+	; return $ mkHsWrapCo coi 
                      (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
 
 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
@@ -800,7 +802,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 
 				 (enumFromToPName basePackageId) elt_ty    -- !!!FIXME: chak
-	; return $ mkHsWrapCoI coi 
+	; return $ mkHsWrapCo coi 
                      (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 
 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
@@ -810,7 +812,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 	; expr3' <- tcPolyExpr expr3 elt_ty
 	; eft <- newMethodFromName (PArrSeqOrigin seq)
 		      (enumFromThenToPName basePackageId) elt_ty        -- !!!FIXME: chak
-	; return $ mkHsWrapCoI coi 
+	; return $ mkHsWrapCo coi 
                      (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 
 tcExpr (PArrSeq _ _) _ 
@@ -881,15 +883,15 @@ tcApp fun args res_ty
 	-- Typecheck the result, thereby propagating 
         -- info (if any) from result into the argument types
         -- Both actual_res_ty and res_ty are deeply skolemised
-        ; co_res <- addErrCtxt (funResCtxt fun) $
+        ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
                     unifyType actual_res_ty res_ty
 
 	-- Typecheck the arguments
 	; args1 <- tcArgs fun args expected_arg_tys
 
         -- Assemble the result
-	; let fun2 = mkLHsWrapCoI co_fun fun1
-              app  = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
+	; let fun2 = mkLHsWrapCo co_fun fun1
+              app  = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
 
         ; return (unLoc app) }
 
@@ -911,7 +913,7 @@ tcInferApp fun args
 	; (co_fun, expected_arg_tys, actual_res_ty)
 	      <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
 	; args1 <- tcArgs fun args expected_arg_tys
-	; let fun2 = mkLHsWrapCoI co_fun fun1
+	; let fun2 = mkLHsWrapCo co_fun fun1
               app  = foldl mkHsApp fun2 args1
         ; return (unLoc app, actual_res_ty) }
 
@@ -960,7 +962,7 @@ tcTupArgs args tys
 
 ----------------
 unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
-              -> TcM (CoercionI, [TcSigmaType], TcRhoType)	 		
+              -> TcM (Coercion, [TcSigmaType], TcRhoType)	 		
 -- A wrapper for matchExpectedFunTys
 unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
   where
@@ -1087,7 +1089,7 @@ instantiateOuter orig id
        ; let theta' = substTheta subst theta
        ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
        ; wrap <- instCall orig tys theta'
-       ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
+       ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
   where
     (tvs, theta, tau) = tcSplitSigmaTy (idType id)
 \end{code}
@@ -1211,7 +1213,7 @@ tcTagToEnum loc fun_name arg res_ty
         ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
               rep_ty = mkTyConApp rep_tc rep_args
 
-	; return (mkHsWrapCoI coi $ HsApp fun' arg') }
+	; return (mkHsWrapCo coi $ HsApp fun' arg') }
   where
     doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
 		, ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
@@ -1219,18 +1221,18 @@ tcTagToEnum loc fun_name arg res_ty
     doc3 = ptext (sLit "No family instance for this type")
 
     get_rep_ty :: TcType -> TyCon -> [TcType]
-               -> TcM (CoercionI, TyCon, [TcType])
+               -> TcM (Coercion, TyCon, [TcType])
     	-- Converts a family type (eg F [a]) to its rep type (eg FList a)
 	-- and returns a coercion between the two
     get_rep_ty ty tc tc_args
       | not (isFamilyTyCon tc) 
-      = return (IdCo ty, tc, tc_args)
+      = return (mkReflCo ty, tc, tc_args)
       | otherwise 
       = do { mb_fam <- tcLookupFamInst tc tc_args
            ; case mb_fam of 
 	       Nothing -> failWithTc (tagToEnumError ty doc3)
                Just (rep_tc, rep_args) 
-                   -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
+                   -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
                              , rep_tc, rep_args )
                  where
                    co_tc = expectJust "tcTagToEnum" $
@@ -1463,9 +1465,23 @@ funAppCtxt fun arg arg_no
 		    quotes (ppr fun) <> text ", namely"])
        2 (quotes (ppr arg))
 
-funResCtxt :: LHsExpr Name -> SDoc
-funResCtxt fun
-  = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+funResCtxt :: LHsExpr Name -> TcType -> TcType 
+           -> TidyEnv -> TcM (TidyEnv, Message)
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+funResCtxt fun fun_res_ty res_ty env0
+  = do { fun_res' <- zonkTcType fun_res_ty
+       ; res'     <- zonkTcType res_ty
+       ; let n_fun = length (fst (tcSplitFunTys fun_res'))
+             n_res = length (fst (tcSplitFunTys res'))
+             what  | n_fun > n_res = ptext (sLit "few")
+                   | otherwise     = ptext (sLit "many")
+             extra | n_fun == n_res = empty
+                   | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+                                 <+> ptext (sLit "is applied to too") <+> what 
+                                 <+> ptext (sLit "arguments") 
+             msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+       ; return (env0, msg $$ extra) }
 
 badFieldTypes :: [(Name,TcType)] -> SDoc
 badFieldTypes prs
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 73fd449..8f53d6e 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
 module checks to see if a foreign declaration has got a legal type.
 
 \begin{code}
-module TcForeign 
-	( 
-	  tcForeignImports
+module TcForeign
+        (
+          tcForeignImports
         , tcForeignExports
-	) where
+        ) where
 
 #include "HsVersions.h"
 
@@ -43,18 +43,18 @@ import FastString
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
 isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _			      = False
+isForeignImport _                           = False
 
 -- Exports a binding
 isForeignExport :: LForeignDecl name -> Bool
 isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _	  	              = False
+isForeignExport _                           = False
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Imports}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -64,22 +64,22 @@ tcForeignImports decls
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo)  $ 
-   do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-      ; let 
-          -- Drop the foralls before inspecting the
-          -- structure of the foreign type.
-	    (_, t_ty)	      = tcSplitForAllTys sig_ty
-	    (arg_tys, res_ty) = tcSplitFunTys t_ty
-	    id  	      = mkLocalId nm sig_ty
- 		-- Use a LocalId to obey the invariant that locally-defined 
-		-- things are LocalIds.  However, it does not need zonking,
-		-- (so TcHsSyn.zonkForeignExports ignores it).
-   
-      ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-         -- Can't use sig_ty here because sig_ty :: Type and 
-	 -- we need HsType Id hence the undefined
-      ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+  = addErrCtxt (foreignDeclCtxt fo)  $
+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+       ; let
+           -- Drop the foralls before inspecting the
+           -- structure of the foreign type.
+             (_, t_ty)         = tcSplitForAllTys sig_ty
+             (arg_tys, res_ty) = tcSplitFunTys t_ty
+             id                = mkLocalId nm sig_ty
+                 -- Use a LocalId to obey the invariant that locally-defined
+                 -- things are LocalIds.  However, it does not need zonking,
+                 -- (so TcHsSyn.zonkForeignExports ignores it).
+
+       ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+          -- Can't use sig_ty here because sig_ty :: Type and
+          -- we need HsType Id hence the undefined
+       ; return (id, ForeignImport (L loc id) undefined imp_decl') }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 \end{code}
 
@@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
     do { checkCg checkCOrAsmOrLlvmOrInterp
        ; checkSafety safety
        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
-       ; return idecl }	     -- NB check res_ty not sig_ty!
-       	 	      	     --    In case sig_ty is (forall a. ForeignPtr a)
+       ; return idecl }      -- NB check res_ty not sig_ty!
+                             --    In case sig_ty is (forall a. ForeignPtr a)
 
 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
-   	-- Foreign wrapper (former f.e.d.)
-   	-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-   	-- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
-   	-- as ft -> IO Addr is accepted, too.  The use of the latter two forms
-   	-- is DEPRECATED, though.
+        -- Foreign wrapper (former f.e.d.)
+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
+        -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
+        -- is DEPRECATED, though.
     checkCg checkCOrAsmOrLlvmOrInterp
     checkCConv cconv
     checkSafety safety
@@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty
 \end{code}
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Exports}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-tcForeignExports :: [LForeignDecl Name] 
-    		 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+                 -> TcM (LHsBinds TcId, [LForeignDecl TcId])
 tcForeignExports decls
   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
   where
@@ -190,25 +190,25 @@ tcForeignExports decls
        return (b `consBag` binds, f:fs)
 
 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
-   addErrCtxt (foreignDeclCtxt fo)      $ do
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+  = addErrCtxt (foreignDeclCtxt fo) $ do
 
-   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-   rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
 
-   tcCheckFEType sig_ty spec
+    tcCheckFEType sig_ty spec
 
-	  -- we're exporting a function, but at a type possibly more
-	  -- constrained than its declared/inferred type. Hence the need
-	  -- to create a local binding which will call the exported function
-	  -- at a particular type (and, maybe, overloading).
+           -- we're exporting a function, but at a type possibly more
+           -- constrained than its declared/inferred type. Hence the need
+           -- to create a local binding which will call the exported function
+           -- at a particular type (and, maybe, overloading).
 
 
-   -- We need to give a name to the new top-level binding that
-   -- is *stable* (i.e. the compiler won't change it later),
-   -- because this name will be referred to by the C code stub.
-   id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-   return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+    -- We need to give a name to the new top-level binding that
+    -- is *stable* (i.e. the compiler won't change it later),
+    -- because this name will be referred to by the C code stub.
+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+    return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}
 
@@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{Miscellaneous}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -246,7 +246,7 @@ checkForeignArgs pred tys
     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 
 ------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form 
+-- Check that the type has the form
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --
 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
@@ -256,14 +256,14 @@ nonIOok  = True
 mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
-	-- (IO t) is ok, and so is any newtype wrapping thereof
+        -- (IO t) is ok, and so is any newtype wrapping thereof
   | Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
     pred_res_ty res_ty
   = return ()
- 
+
   | otherwise
-  = check (non_io_result_ok && pred_res_ty ty) 
-	  (illegalForeignTyErr result ty)
+  = check (non_io_result_ok && pred_res_ty ty)
+          (illegalForeignTyErr result ty)
 \end{code}
 
 \begin{code}
@@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC    = Nothing
 checkCOrAsmOrLlvm HscAsm  = Nothing
 checkCOrAsmOrLlvm HscLlvm = Nothing
 checkCOrAsmOrLlvm _
-   = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+  = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
 
 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
 checkCOrAsmOrLlvmOrInterp HscC           = Nothing
@@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
 checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
 checkCOrAsmOrLlvmOrInterp _
-   = Just (text "requires interpreted, C, Llvm or native code generation")
+  = Just (text "requires interpreted, C, Llvm or native code generation")
 
 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
 checkCOrAsmOrLlvmOrDotNetOrInterp HscC           = Nothing
@@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm         = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm        = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
 checkCOrAsmOrLlvmOrDotNetOrInterp _
-   = Just (text "requires interpreted, C, Llvm or native code generation")
+  = Just (text "requires interpreted, C, Llvm or native code generation")
 
 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
 checkCg check = do
-   dflags <- getDOpts
-   let target = hscTarget dflags
-   case target of
-     HscNothing -> return ()
-     _ ->
-       case check target of
-	 Nothing  -> return ()
-	 Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+    dflags <- getDOpts
+    let target = hscTarget dflags
+    case target of
+      HscNothing -> return ()
+      _ ->
+        case check target of
+          Nothing  -> return ()
+          Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
 \end{code}
-			   
+
 Calling conventions
 
 \begin{code}
 checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv  = return ()
+checkCConv CCallConv    = return ()
 #if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv  = return ()
 #else
 -- This is a warning, not an error. see #3336
-checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
+checkCConv StdCallConv  = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
 #endif
 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
-checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
 \end{code}
 
 Deprecated "threadsafe" calls
@@ -329,12 +329,12 @@ Warnings
 
 \begin{code}
 check :: Bool -> Message -> TcM ()
-check True _	   = return ()
+check True _       = return ()
 check _    the_err = addErrTc the_err
 
 illegalForeignTyErr :: SDoc -> Type -> SDoc
 illegalForeignTyErr arg_or_res ty
-  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
+  = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
                 ptext (sLit "type in foreign declaration:")])
        2 (hsep [ppr ty])
 
@@ -344,12 +344,11 @@ argument = text "argument"
 result   = text "result"
 
 badCName :: CLabelString -> Message
-badCName target 
-   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+badCName target
+  = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
 
 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 foreignDeclCtxt fo
   = hang (ptext (sLit "When checking declaration:"))
        2 (ppr fo)
 \end{code}
-
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index efacac2..ad640ef 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -42,7 +42,7 @@ import Name
 import HscTypes
 import PrelInfo
 import MkCore	( eRROR_ID )
-import PrelNames
+import PrelNames hiding (error_RDR)
 import PrimOp
 import SrcLoc
 import TyCon
@@ -50,7 +50,6 @@ import TcType
 import TysPrim
 import TysWiredIn
 import Type
-import Var( TyVar )
 import TypeRep
 import VarSet
 import State
@@ -779,7 +778,7 @@ gen_Ix_binds loc tycon
     single_con_range
       = mk_easy_FunBind loc range_RDR 
 	  [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
-	nlHsDo ListComp stmts con_expr
+	noLoc (mkHsComp ListComp stmts con_expr)
       where
 	stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 
@@ -893,7 +892,7 @@ gen_Read_binds get_fixity loc tycon
     read_nullary_cons 
       = case nullary_cons of
     	    []    -> []
-    	    [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])]
+    	    [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
             _     -> [nlHsApp (nlHsVar choose_RDR) 
     		   	      (nlList (map mk_pair nullary_cons))]
         -- NB For operators the parens around (:=:) are matched by the
@@ -965,11 +964,12 @@ gen_Read_binds get_fixity loc tycon
     ------------------------------------------------------------------------
     --		Helpers
     ------------------------------------------------------------------------
-    mk_alt e1 e2       = genOpApp e1 alt_RDR e2					-- e1 +++ e2
-    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]	-- prec p (do { ss ; b })
-    bindLex pat	       = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))		-- pat <- lexP
-    con_app con as     = nlHsVarApps (getRdrName con) as			-- con as
-    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)		-- return (con as)
+    mk_alt e1 e2       = genOpApp e1 alt_RDR e2				-- e1 +++ e2
+    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p	        -- prec p (do { ss ; b })
+                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+    bindLex pat	       = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))	-- pat <- lexP
+    con_app con as     = nlHsVarApps (getRdrName con) as		-- con as
+    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
     
     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 
@@ -1836,7 +1836,7 @@ assoc_ty_id cls_str _ tbl ty
 					      text "for primitive type" <+> ppr ty)
   | otherwise = head res
   where
-    res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
+    res = [id | (ty',id) <- tbl, ty `eqType` ty']
 
 -----------------------------------------------------------------------
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index ab7d8c2..4845d70 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -35,6 +35,7 @@ import TcRnMonad
 import PrelNames
 import TcType
 import TcMType
+import Coercion
 import TysPrim
 import TysWiredIn
 import DataCon
@@ -43,14 +44,15 @@ import NameSet
 import Var
 import VarSet
 import VarEnv
+import DynFlags( DynFlag(..) )
 import Literal
 import BasicTypes
 import Maybes
 import SrcLoc
-import DynFlags( DynFlag(..) )
 import Bag
 import FastString
 import Outputable
+-- import Data.Traversable( traverse )
 \end{code}
 
 \begin{code}
@@ -119,7 +121,7 @@ shortCutLit (HsIntegral i) ty
   | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
   | isIntegerTy ty 	       	 = Just (HsLit (HsInteger i ty))
-  | otherwise		       	 = shortCutLit (HsFractional (fromInteger i)) ty
+  | otherwise		       	 = shortCutLit (HsFractional (integralFractionalLit i)) ty
 	-- The 'otherwise' case is important
 	-- Consider (3 :: Float).  Syntactically it looks like an IntLit,
 	-- so we'll call shortCutIntLit, but of course it's a float
@@ -594,11 +596,10 @@ zonkExpr env (HsLet binds expr)
     zonkLExpr new_env expr	`thenM` \ new_expr ->
     returnM (HsLet new_binds new_expr)
 
-zonkExpr env (HsDo do_or_lc stmts body ty)
-  = zonkStmts env stmts 	`thenM` \ (new_env, new_stmts) ->
-    zonkLExpr new_env body	`thenM` \ new_body ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+  = zonkStmts env stmts 	`thenM` \ (_, new_stmts) ->
     zonkTcTypeToType env ty	`thenM` \ new_ty   ->
-    returnM (HsDo do_or_lc new_stmts new_body new_ty)
+    returnM (HsDo do_or_lc new_stmts new_ty)
 
 zonkExpr env (ExplicitList ty exprs)
   = zonkTcTypeToType env ty	`thenM` \ new_ty ->
@@ -692,7 +693,7 @@ zonkCoFn env WpHole   = return (env, WpHole)
 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
 				    ; (env2, c2') <- zonkCoFn env1 c2
 				    ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
+zonkCoFn env (WpCast co)    = do { co' <- zonkTcCoToCo env co
 				 ; return (env, WpCast co') }
 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
 				 ; return (env', WpEvLam ev') }
@@ -744,22 +745,26 @@ zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
 			  ; return (env2, s' : ss') }
 
 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
   = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
     let 
 	new_binders = concat (map snd new_stmts_w_bndrs)
 	env1 = extendZonkEnv env new_binders
     in
-    return (env1, ParStmt new_stmts_w_bndrs)
+    zonkExpr env1 mzip_op   `thenM` \ new_mzip ->
+    zonkExpr env1 bind_op   `thenM` \ new_bind ->
+    zonkExpr env1 return_op `thenM` \ new_return ->
+    return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
   where
     zonk_branch (stmts, bndrs) = zonkStmts env stmts	`thenM` \ (env1, new_stmts) ->
 				 returnM (new_stmts, zonkIdOccs env1 bndrs)
 
 zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                       , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
-                      , recS_rec_rets = rets })
+                      , recS_rec_rets = rets, recS_ret_ty = ret_ty })
   = do { new_rvs <- zonkIdBndrs env rvs
        ; new_lvs <- zonkIdBndrs env lvs
+       ; new_ret_ty  <- zonkTcTypeToType env ret_ty
        ; new_ret_id  <- zonkExpr env ret_id
        ; new_mfix_id <- zonkExpr env mfix_id
        ; new_bind_id <- zonkExpr env bind_id
@@ -772,28 +777,34 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
-                         , recS_rec_rets = new_rets }) }
+                         , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
 
-zonkStmt env (ExprStmt expr then_op ty)
+zonkStmt env (ExprStmt expr then_op guard_op ty)
   = zonkLExpr env expr		`thenM` \ new_expr ->
     zonkExpr env then_op	`thenM` \ new_then ->
+    zonkExpr env guard_op	`thenM` \ new_guard ->
     zonkTcTypeToType env ty	`thenM` \ new_ty ->
-    returnM (env, ExprStmt new_expr new_then new_ty)
+    returnM (env, ExprStmt new_expr new_then new_guard new_ty)
 
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
-  = do { (env', stmts') <- zonkStmts env stmts 
-    ; let binders' = zonkIdOccs env' binders
-    ; usingExpr' <- zonkLExpr env' usingExpr
-    ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
-    ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
-    
-zonkStmt env (GroupStmt stmts binderMap by using)
+zonkStmt env (LastStmt expr ret_op)
+  = zonkLExpr env expr		`thenM` \ new_expr ->
+    zonkExpr env ret_op		`thenM` \ new_ret ->
+    returnM (env, LastStmt new_expr new_ret)
+
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+                        , trS_by = by, trS_form = form, trS_using = using
+                        , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
   = do { (env', stmts') <- zonkStmts env stmts 
     ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
-    ; by' <- fmapMaybeM (zonkLExpr env') by
-    ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+    ; by'        <- fmapMaybeM (zonkLExpr env') by
+    ; using'     <- zonkLExpr env using
+    ; return_op' <- zonkExpr env' return_op
+    ; bind_op'   <- zonkExpr env' bind_op
+    ; liftM_op'  <- zonkExpr env' liftM_op
     ; let env'' = extendZonkEnv env' (map snd binderMap')
-    ; return (env'', GroupStmt stmts' binderMap' by' using') }
+    ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                               , trS_by = by', trS_form = form, trS_using = using'
+                               , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
   where
     zonkBinderMapEntry env (oldBinder, newBinder) = do 
         let oldBinder' = zonkIdOcc env oldBinder
@@ -811,11 +822,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
 	; new_fail <- zonkExpr env fail_op
 	; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
 
-zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
-zonkMaybeLExpr _   Nothing  = return Nothing
-zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-
-
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
 zonkRecFields env (HsRecFields flds dd)
@@ -1020,7 +1026,6 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
-     | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
      | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
@@ -1050,10 +1055,10 @@ zonkVect env (HsVect v (Just e))
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
                                     return (EvId (zonkIdOcc env v))
-zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
+zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcCoToCo env co
                                        ; return (EvCoercion co') }
 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
-                                    do { co' <- zonkTcTypeToType env co
+                                    do { co' <- zonkTcCoToCo env co
                                        ; return (EvCast (zonkIdOcc env v) co') }
 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
 zonkEvTerm env (EvDFunApp df tys tms)
@@ -1128,4 +1133,27 @@ zonkTypeZapping ty
     zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
 			       ; writeMetaTyVar tv ty
 			       ; return ty }
-\end{code}
\ No newline at end of file
+
+zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkTcCoToCo env co
+  = go co
+  where
+    go (CoVarCo cv)         = return (CoVarCo (zonkEvVarOcc env cv))
+    go (Refl ty)            = do { ty' <- zonkTcTypeToType env ty
+                                 ; return (Refl ty') }
+    go (TyConAppCo tc cos)  = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
+    go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') }
+    go (AppCo co1 co2)      = do { co1' <- go co1; co2' <- go co2
+                                 ; return (mkAppCo co1' co2') }
+    go (UnsafeCo t1 t2)     = do { t1' <- zonkTcTypeToType env t1
+                                 ; t2' <- zonkTcTypeToType env t2
+                                 ; return (mkUnsafeCo t1' t2') }
+    go (SymCo co)           = do { co' <- go co; return (mkSymCo co')  }
+    go (NthCo n co)         = do { co' <- go co; return (mkNthCo n co')  }
+    go (TransCo co1 co2)    = do { co1' <- go co1; co2' <- go co2
+                                 ; return (mkTransCo co1' co2')  }
+    go (InstCo co ty)       = do { co' <- go co; ty' <- zonkTcTypeToType env ty
+                                 ; return (mkInstCo co' ty')  }
+    go (ForAllCo tv co)     = ASSERT( isImmutableTyVar tv )
+                              do { co' <- go co; return (mkForAllCo tv co') }
+\end{code}
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 669c61c..2174be3 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -45,7 +45,6 @@ import TyCon
 import Class
 import Name
 import NameSet
-import PrelNames
 import TysWiredIn
 import BasicTypes
 import SrcLoc
@@ -371,9 +370,6 @@ kc_hs_type (HsModalBoxType ecn ty) = do
     ty' <- kcLiftedType ty
     return (HsModalBoxType ecn ty', liftedTypeKind)
 
-kc_hs_type (HsNumTy n)
-   = return (HsNumTy n, liftedTypeKind)
-
 kc_hs_type (HsKindSig ty k) = do
     ty' <- kc_check_lhs_type ty (EK k EkKindSig)
     return (HsKindSig ty' k, k)
@@ -617,11 +613,6 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do
     tau_ty2 <- dsHsType ty2
     setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
 
-ds_type (HsNumTy n)
-  = ASSERT(n==1) do
-    tc <- tcLookupTyCon genUnitTyConName
-    return (mkTyConApp tc [])
-
 ds_type ty@(HsAppTy _ _)
   = ds_app ty []
 
@@ -868,7 +859,7 @@ tcPatSig :: UserTypeCtxt
 		 [(Name, TcType)], -- The new bit of type environment, binding
 				   -- the scoped type variables
                  HsWrapper)        -- Coercion due to unification with actual ty
-		 		   -- Of shape:  res_ty ~ sig_ty
+                                   -- Of shape:  res_ty ~ sig_ty
 tcPatSig ctxt sig res_ty
   = do	{ (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
     	-- sig_tvs are the type variables free in 'sig', 
@@ -880,8 +871,7 @@ tcPatSig ctxt sig res_ty
 		-- and hence is rigid, so use it to zap the res_ty
                   wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty
 		; return (sig_ty, [], wrap)
-
-	} else do {
+        } else do {
 		-- Type signature binds at least one scoped type variable
 	
 		-- A pattern binding cannot bind scoped type variables
@@ -904,20 +894,20 @@ tcPatSig ctxt sig res_ty
 	; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
 
 	-- Now do a subsumption check of the pattern signature against res_ty
-	; sig_tvs' <- tcInstSigTyVars sig_tvs
+        ; sig_tvs' <- tcInstSigTyVars sig_tvs
         ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
               sig_tv_tys' = mkTyVarTys sig_tvs'
-        ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
+	; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
 
 	-- Check that each is bound to a distinct type variable,
 	-- and one that is not already in scope
-	; binds_in_scope <- getScopedTyVarBinds
+        ; binds_in_scope <- getScopedTyVarBinds
 	; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys'
 	; check binds_in_scope tv_binds
 	
 	-- Phew!
-	; return (sig_ty', tv_binds, wrap)
-	} }
+        ; return (sig_ty', tv_binds, wrap)
+        } }
   where
     check _ [] = return ()
     check in_scope ((n,ty):rest) = do { check_one in_scope n ty
@@ -928,7 +918,7 @@ tcPatSig ctxt sig res_ty
 		-- Must not bind to the same type variable
 		-- as some other in-scope type variable
 	where
-	  dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty]
+	  dups = [n' | (n',ty') <- in_scope, eqType ty' ty]
 \end{code}
 
 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3bb27a7..bb0089f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -16,22 +16,24 @@ import TcPat( addInlinePrags )
 import TcRnMonad
 import TcMType
 import TcType
+import BuildTyCl
 import Inst
 import InstEnv
 import FamInst
 import FamInstEnv
-import MkCore	( nO_METHOD_BINDING_ERROR_ID )
 import TcDeriv
 import TcEnv
 import RnSource ( addTcgDUs )
 import TcHsType
 import TcUnify
+import MkCore	( nO_METHOD_BINDING_ERROR_ID )
 import Type
 import Coercion
 import TyCon
 import DataCon
 import Class
 import Var
+import Pair
 import VarSet
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
@@ -206,7 +208,7 @@ Just <blah>.
 Instead, we simply rely on the fact that casts are cheap:
 
    $df :: forall a. C a => C [a]
-   {-# INLINE df #}  -- NB: INLINE this
+   {-# INLINE df #-}  -- NB: INLINE this
    $df = /\a. \d. MkC [a] ($cop_list a d)
        = $cop_list |> forall a. C a -> (sym (Co:C [a]))
 
@@ -370,40 +372,41 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
-             ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
-             ; implicit_things = concatMap implicitTyThings at_idx_tycons
-	     ; aux_binds       = mkRecSelBinds at_idx_tycons
-             }
+             ; implicit_things = concatMap implicitTyConThings at_idx_tycons
+	     ; aux_binds       = mkRecSelBinds at_idx_tycons  }
 
                 -- (2) Add the tycons of indexed types and their implicit
                 --     tythings to the global environment
-       ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+       ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
 
-                -- (3) Instances from generic class declarations
-       ; generic_inst_info <- getGenericInstances clas_decls
 
                 -- Next, construct the instance environment so far, consisting
                 -- of
                 --   (a) local instance decls
-                --   (b) generic instances
-                --   (c) local family instance decls
+                --   (b) local family instance decls
        ; addInsts local_info         $
-         addInsts generic_inst_info  $
          addFamInsts at_idx_tycons   $ do {
 
-                -- (4) Compute instances from "deriving" clauses;
+                -- (3) Compute instances from "deriving" clauses;
                 -- This stuff computes a context for the derived instance
                 -- decl, so it needs to know about all the instances possible
                 -- NB: class instance declarations can contain derivings as
                 --     part of associated data type declarations
-	 failIfErrsM		-- If the addInsts stuff gave any errors, don't
-				-- try the deriving stuff, becuase that may give
-				-- more errors still
-       ; (deriv_inst_info, deriv_binds, deriv_dus) 
+	 failIfErrsM	-- If the addInsts stuff gave any errors, don't
+			-- try the deriving stuff, because that may give
+			-- more errors still
+       ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) 
               <- tcDeriving tycl_decls inst_decls deriv_decls
-       ; gbl_env <- addInsts deriv_inst_info getGblEnv
+
+       -- Extend the global environment also with the generated datatypes for
+       -- the generic representation
+       ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
+       ; gbl_env <- tcExtendGlobalEnv all_tycons $
+                    tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+                    addFamInsts deriv_ty_insts $
+                    addInsts deriv_inst_info getGblEnv
        ; return ( addTcgDUs gbl_env deriv_dus,
-                  generic_inst_info ++ deriv_inst_info ++ local_info,
+                  deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
     }}}
 
@@ -411,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 
-addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts :: [TyCon] -> TcM a -> TcM a
 addFamInsts tycons thing_inside
-  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
-  where
-    mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
-    mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
-                                                    (ppr tything)
+  = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
 \end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name
-                 -> TcM (InstInfo Name, [TyThing])
+                 -> TcM (InstInfo Name, [TyCon])
         -- A source-file instance declaration
         -- Type-check all the stuff before the "where"
         --
@@ -466,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
     checkValidAndMissingATs :: Class
                             -> ([TyVar], [TcType])     -- instance types
                             -> [(LTyClDecl Name,       -- source form of AT
-                                 TyThing)]    	       -- Core form of AT
+                                 TyCon)]    	       -- Core form of AT
                             -> TcM ()
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
@@ -484,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
            ; mapM_ (checkIndexes clas inst_tys) ats
            }
 
-    checkIndexes clas inst_tys (hsAT, ATyCon tycon)
+    checkIndexes clas inst_tys (hsAT, tycon)
 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
       = checkIndexes' clas inst_tys hsAT
                       (tyConTyVars tycon,
                        snd . fromJust . tyConFamInst_maybe $ tycon)
-    checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
       = let atName = tcdName . unLoc $ hsAT
@@ -549,8 +547,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
       | isTyVarTy ty         = return ()
       | otherwise            = addErrTc $ mustBeVarArgErr ty
     checkIndex ty (Just instTy)
-      | ty `tcEqType` instTy = return ()
-      | otherwise            = addErrTc $ wrongATArgErr ty instTy
+      | ty `eqType` instTy = return ()
+      | otherwise          = addErrTc $ wrongATArgErr ty instTy
 
     listToNameSet = addListToNameSet emptyNameSet
 
@@ -563,7 +561,183 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
           tv1 `sameLexeme` tv2 =
             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
       in
-      extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+      TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+\end{code}
+
+
+%************************************************************************
+%*									*
+               Type checking family instances
+%*									*
+%************************************************************************
+
+Family instances are somewhat of a hybrid.  They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+
+\begin{code}
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
+tcFamInstDecl top_lvl (L loc decl)
+  =	-- Prime error recovery, set source location
+    setSrcSpan loc				$
+    tcAddDeclCtxt decl				$
+    do { -- type family instances require -XTypeFamilies
+	 -- and can't (currently) be in an hs-boot file
+       ; type_families <- xoptM Opt_TypeFamilies
+       ; is_boot  <- tcIsHsBoot	  -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+	 -- Perform kind and type checking
+       ; tc <- tcFamInstDecl1 decl
+       ; checkValidTyCon tc	-- Remember to check validity;
+				-- no recursion to worry about here
+
+       -- Check that toplevel type instances are not for associated types.
+       ; when (isTopLevel top_lvl && isAssocFamily tc)
+              (addErr $ assocInClassErr (tcdName decl))
+
+       ; return tc }
+
+isAssocFamily :: TyCon -> Bool	-- Is an assocaited type
+isAssocFamily tycon
+  = case tyConFamInst_maybe tycon of
+          Nothing       -> panic "isAssocFamily: no family?!?"
+          Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+   ptext (sLit "must be inside a class instance")
+
+
+
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+
+  -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+    do { -- check that the family declaration is for a synonym
+         checkTc (isFamilyTyCon family) (notFamily family)
+       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+
+       ; -- (1) kind check the right-hand side of the type equation
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+       	       	  -- ToDo: the ExpKind could be better
+
+         -- we need the exact same number of type parameters as the family
+         -- declaration 
+       ; let famArity = tyConArity family
+       ; checkTc (length k_typats == famArity) $ 
+           wrongNumberOfParmsErr famArity
+
+         -- (2) type check type equation
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
+       ; t_typats <- mapM tcHsKindedType k_typats
+       ; t_rhs    <- tcHsKindedType k_rhs
+
+         -- (3) check the well-formedness of the instance
+       ; checkValidTypeInst t_typats t_rhs
+
+         -- (4) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
+                       (typeKind t_rhs) 
+                       NoParentTyCon (Just (family, t_typats))
+       }}
+
+  -- "newtype instance" and "data instance"
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+			     tcdCons = cons})
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+    do { -- check that the family declaration is for the right kind
+         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+
+       ; -- (1) kind check the data declaration as usual
+       ; k_decl <- kcDataDecl decl k_tvs
+       ; let k_ctxt = tcdCtxt k_decl
+	     k_cons = tcdCons k_decl
+
+         -- result kind must be '*' (otherwise, we have too few patterns)
+       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
+
+         -- (2) type check indexed data type declaration
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
+       ; unbox_strict <- doptM Opt_UnboxStrictFields
+
+         -- kind check the type indexes and the context
+       ; t_typats     <- mapM tcHsKindedType k_typats
+       ; stupid_theta <- tcHsKindedContext k_ctxt
+
+         -- (3) Check that
+         --     (a) left-hand side contains no type family applications
+         --         (vanilla synonyms are fine, though, and we checked for
+         --         foralls earlier)
+       ; mapM_ checkTyFamFreeness t_typats
+
+       ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
+
+         -- (4) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+       ; let ex_ok = True	-- Existentials ok for type families!
+       ; fixM (\ rep_tycon -> do 
+	     { let orig_res_ty = mkTyConApp fam_tycon t_typats
+	     ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+				       (t_tvs, orig_res_ty) k_cons
+	     ; tc_rhs <-
+		 case new_or_data of
+		   DataType -> return (mkDataTyConRhs data_cons)
+		   NewType  -> ASSERT( not (null data_cons) )
+			       mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
+	     ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+			     h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+                 -- We always assume that indexed types are recursive.  Why?
+                 -- (1) Due to their open nature, we can never be sure that a
+                 -- further instance might not introduce a new recursive
+                 -- dependency.  (2) They are always valid loop breakers as
+                 -- they involve a coercion.
+	     })
+       }}
+       where
+	 h98_syntax = case cons of 	-- All constructors have same shape
+			L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+			_ -> True
+
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+
+-- Kind checking of indexed types
+-- -
+
+-- Kind check type patterns and kind annotate the embedded type variables.
+--
+-- * Here we check that a type instance matches its kind signature, but we do
+--   not check whether there is a pattern for each type index; the latter
+--   check is only required for type synonym instances.
+
+kcIdxTyPats :: TyClDecl Name
+	    -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
+	       -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
+	    -> TcM a
+kcIdxTyPats decl thing_inside
+  = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
+    do { let tc_name = tcdLName decl
+       ; fam_tycon <- tcLookupLocatedTyCon tc_name
+       ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+	     ; hs_typats	= fromJust $ tcdTyPats decl }
+
+         -- we may not have more parameters than the kind indicates
+       ; checkTc (length kinds >= length hs_typats) $
+	   tooManyParmsErr (tcdLName decl)
+
+         -- type functions can have a higher-kinded result
+       ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
+       ; typats <- zipWithM kcCheckLHsType hs_typats 
+       	 	   	    [ EK kind (EkArg (ppr tc_name) n) 
+                            | (kind,n) <- kinds `zip` [1..]]
+       ; thing_inside tvs typats resultKind fam_tycon
+       }
 \end{code}
 
 
@@ -621,6 +795,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
     do {  -- Instantiate the instance decl with skolem constants
        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+                     -- We instantiate the dfun_id with superSkolems.
+                     -- See Note [Subtle interaction of recursion and overlap]
+                     -- and Note [Binding when looking up instances]
        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
@@ -699,7 +876,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                  listToBag meth_binds)
        }
  where
-   skol_info = InstSkol         -- See Note [Subtle interaction of recursion and overlap]
+   skol_info = InstSkol         
    dfun_ty   = idType dfun_id
    dfun_id   = instanceDFunId ispec
    loc       = getSrcSpan dfun_id
@@ -718,8 +895,8 @@ tcSuperClass n_ty_args ev_vars pred
        ; return (sc_dict, DFunConstArg (Var sc_dict)) }
   where
     find _ [] = Nothing
-    find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
-                    | otherwise                    = find (i+1) evs
+    find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
+                    | otherwise                  = find (i+1) evs
 
 ------------------------------
 tcSpecInstPrags :: DFunId -> InstBindings Name
@@ -917,10 +1094,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     ----------------------
     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+    tc_default sel_id (GenDefMeth dm_name)
+      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+           ; tc_body sel_id False {- Not generated code? -} meth_bind }
+{-
     tc_default sel_id GenDefMeth    -- Derivable type classes stuff
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
            ; tc_body sel_id False {- Not generated code? -} meth_bind }
-    	  
+-}
     tc_default sel_id NoDefMeth	    -- No default method at all
       = do { warnMissingMethod sel_id
     	   ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
@@ -1042,13 +1224,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
      inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
      Just (init_inst_tys, _) = snocView inst_tys
-     rep_ty   = fst (coercionKind co)  -- [p]
+     rep_ty   = pFst (coercionKind co)  -- [p]
      rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
 
      -- co : [p] ~ T p
-     co = substTyWith inst_tvs (mkTyVarTys tyvars) $
-          case coi of { IdCo ty -> ty ;
-                        ACo co  -> mkSymCoercion co }
+     co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
+          mkSymCo coi
 
      ----------------
      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
@@ -1072,7 +1253,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
      ----------------
      mk_op_wrapper :: Id -> EvVar -> HsWrapper
      mk_op_wrapper sel_id rep_d 
-       = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+       = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
+                               local_meth_ty)
          <.> WpEvApp (EvId rep_d)
          <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) 
        where
@@ -1262,4 +1444,37 @@ wrongATArgErr ty instTy =
       , ptext (sLit "Found") <+> quotes (ppr ty)
         <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
       ]
+
+tooManyParmsErr :: Located Name -> SDoc
+tooManyParmsErr tc_name
+  = ptext (sLit "Family instance has too many parameters:") <+> 
+    quotes (ppr tc_name)
+
+tooFewParmsErr :: Arity -> SDoc
+tooFewParmsErr arity
+  = ptext (sLit "Family instance has too few parameters; expected") <+> 
+    ppr arity
+
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr exp_arity
+  = ptext (sLit "Number of parameters must match family declaration; expected")
+    <+> ppr exp_arity
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+  = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+  
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+  = ptext (sLit "Wrong category of family instance; declaration was for a")
+    <+> kindOfFamily
+  where
+    kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
+		 | isAlgTyCon family = ptext (sLit "data type")
+		 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 \end{code}
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 4a049aa..3833534 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -12,6 +12,7 @@ import BasicTypes
 import TcCanonical
 import VarSet
 import Type
+import Unify
 
 import Id 
 import Var
@@ -30,6 +31,7 @@ import Coercion
 import Outputable
 
 import TcRnTypes
+import TcMType ( isSilentEvVar )
 import TcErrors
 import TcSMonad
 import Bag
@@ -68,8 +70,11 @@ An InertSet is a bag of canonical constraints, with the following invariants:
     will be marked as solved right before being pushed into the inert set. 
     See note [Touchables and givens].
 
-  8 No Given constraint mentions a touchable unification variable,
-    except if the
+  8 No Given constraint mentions a touchable unification variable, but 
+    Given/Solved may do so. 
+
+  9 Given constraints will also have their superclasses in the inert set, 
+    but Given/Solved will not. 
  
 Note that 6 and 7 are /not/ enforced by canonicalization but rather by 
 insertion in the inert list, ie by TcInteract. 
@@ -192,7 +197,7 @@ extractUnsolved is@(IS {inert_eqs = eqs})
                         , inert_funeqs = solved_funeqs }
     in (is_solved, unsolved)
 
-  where (unsolved_eqs, solved_eqs)       = Bag.partitionBag (not.isGivenCt) eqs
+  where (unsolved_eqs, solved_eqs)       = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
         (unsolved_ips, solved_ips)       = extractUnsolvedCMap (inert_ips is) 
         (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap (inert_dicts is) 
         (unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is) 
@@ -327,7 +332,7 @@ solveInteractGiven inert gloc evs
                            map mk_given evs
        ; return inert_ret }
   where
-    flav = Given gloc
+    flav = Given gloc GivenOrig
     mk_given ev = mkEvVarX ev flav
 
 solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
@@ -408,16 +413,12 @@ dischargeFromCCans cans ev fl
 
     discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool
     discharge_ct ct _rest
-      | evVarPred (cc_id ct) `tcEqPred` the_pred
+      | evVarPred (cc_id ct) `eqPred` the_pred
       , cc_flavor ct `canSolve` fl
-      = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct) 
+      = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct))
            	 -- Deriveds need no evidence
     	         -- For Givens, we already have evidence, and we don't need it twice 
            ; return True }
-      where 
-         set_ev_bind x y
-            | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y))
-            | otherwise                = setEvBind x (EvId y)
 
     discharge_ct _ct rest = rest
 \end{code}
@@ -531,7 +532,7 @@ spontaneousSolveStage depth workItem inerts
                            , sr_stop       = ContinueWith workItem }
 
            SPSolved workItem'
-               | not (isGivenCt workItem) 
+               | not (isGivenOrSolvedCt workItem) 
 	       	 -- Original was wanted or derived but we have now made him 
                  -- given so we have to interact him with the inerts due to
                  -- its status change. This in turn may produce more work.
@@ -572,7 +573,7 @@ data SPSolveResult = SPCantSolve | SPSolved WorkItem | SPError
 --     	    See Note [Touchables and givens] 
 trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
 trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
-  | isGiven gw
+  | isGivenOrSolved gw
   = return SPCantSolve
   | Just tv2 <- tcGetTyVar_maybe xi
   = do { tch1 <- isTouchableMetaTyVar tv1
@@ -725,13 +726,13 @@ solveWithIdentity cv wd tv xi
                   ]
 
        ; setWantedTyBind tv xi
-       ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi xi
+       ; let refl_xi = mkReflCo xi
+       ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi
 
-       ; when (isWanted wd) (setCoBind cv xi)
+       ; when (isWanted wd) (setCoBind cv refl_xi)
            -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-
        ; return $ SPSolved (CTyEqCan { cc_id = cv_given
-                                     , cc_flavor = mkGivenFlavor wd UnkSkol
+                                     , cc_flavor = mkSolvedFlavor wd UnkSkol
                                      , cc_tyvar  = tv, cc_rhs = xi }) }
 \end{code}
 
@@ -928,10 +929,10 @@ doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult
 doInteractWithInert
   inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) 
    workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
-  | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2)
+  | cls1 == cls2 && eqTypes tys1 tys2
   = solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem 
 
-  | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+  | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
   = 	 -- See Note [When improvement happens]
     do { let pty1 = ClassP cls1 tys1
              pty2 = ClassP cls2 tys2
@@ -946,7 +947,7 @@ doInteractWithInert
        ; case m of 
            Nothing -> noInteraction workItem
            Just (rewritten_tys2, cos2, fd_work)
-             | tcEqTypes tys1 rewritten_tys2
+             | eqTypes tys1 rewritten_tys2
              -> -- Solve him on the spot in this case
 	     	case fl2 of
 	          Given   {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem)
@@ -991,7 +992,7 @@ doInteractWithInert
                      workListFromNonEq workItem' `unionWorkList` fd_work } 
 
              where
-               dict_co = mkTyConCoercion (classTyCon cls1) cos2
+               dict_co = mkTyConAppCo (classTyCon cls1) cos2
   }
 
 -- Class constraint and given equality: use the equality to rewrite
@@ -1035,7 +1036,7 @@ doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_i
 -- so we just generate a fresh coercion variable that isn't used anywhere.
 doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
            workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
-  | nm1 == nm2 && isGiven wfl && isGiven ifl
+  | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
   = 	-- See Note [Overriding implicit parameters]
         -- Dump the inert item, override totally with the new one
 	-- Do not require type equality
@@ -1043,15 +1044,22 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i
 	--              we must *override* the outer one with the inner one
     mkIRContinue "IP/IP override" workItem DropInert emptyWorkList
 
-  | nm1 == nm2 && ty1 `tcEqType` ty2 
+  | nm1 == nm2 && ty1 `eqType` ty2 
   = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem 
 
   | nm1 == nm2
   =  	-- See Note [When improvement happens]
     do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation]
-       ; let flav = Wanted (combineCtLoc ifl wfl) 
-       ; cans <- mkCanonical flav co_var 
-       ; mkIRContinue "IP/IP fundep" workItem KeepInert cans }
+       ; let flav = Wanted (combineCtLoc ifl wfl)
+       ; cans <- mkCanonical flav co_var
+       ; case wfl of
+           Given   {} -> pprPanic "Unexpected given IP" (ppr workItem)
+           Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
+           Wanted  {} ->
+               do { setIPBind (cc_id workItem) $
+                    EvCast id1 (mkSymCo (mkCoVarCo co_var))
+                  ; mkIRStopK "IP/IP interaction (solved)" cans }
+       }
 
 -- Never rewrite a given with a wanted equality, and a type function
 -- equality can never rewrite an equality. We rewrite LHS *and* RHS 
@@ -1089,24 +1097,31 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1
                                , cc_tyargs = args1, cc_rhs = xi1 }) 
            workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
                                , cc_tyargs = args2, cc_rhs = xi2 })
+  | tc1 == tc2 && and (zipWith eqType args1 args2) 
+  , Just GivenSolved <- isGiven_maybe fl1 
+  = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
+  | tc1 == tc2 && and (zipWith eqType args1 args2) 
+  , Just GivenSolved <- isGiven_maybe fl2 
+  = mkIRStopK "Funeq/Funeq" emptyWorkList
+
   | fl1 `canSolve` fl2 && lhss_match
-  = do { cans <- rewriteEqLHS LeftComesFromInert  (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) 
+  = do { cans <- rewriteEqLHS LeftComesFromInert  (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) 
        ; mkIRStopK "FunEq/FunEq" cans } 
   | fl2 `canSolve` fl1 && lhss_match
-  = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) 
+  = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) 
        ; mkIRContinue "FunEq/FunEq" workItem DropInert cans }
   where
-    lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2) 
+    lhss_match = tc1 == tc2 && eqTypes args1 args2 
 
 doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) 
            workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
 -- Check for matching LHS 
   | fl1 `canSolve` fl2 && tv1 == tv2 
-  = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) 
+  = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) 
        ; mkIRStopK "Eq/Eq lhs" cans } 
 
   | fl2 `canSolve` fl1 && tv1 == tv2 
-  = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) 
+  = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) 
        ; mkIRContinue "Eq/Eq lhs" workItem DropInert cans }
 
 -- Check for rewriting RHS 
@@ -1137,13 +1152,13 @@ doInteractWithInert _ workItem = noInteraction workItem
 -- Equational Rewriting 
 rewriteDict  :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
 rewriteDict (cv,tv,xi) (dv,gw,cl,xis) 
-  = do { let cos  = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi]
+  = do { let cos  = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis   -- xis[tv] ~ xis[xi]
              args = substTysWith [tv] [xi] xis
              con  = classTyCon cl 
-             dict_co = mkTyConCoercion con cos 
+             dict_co = mkTyConAppCo con cos 
        ; dv' <- newDictVar cl args 
        ; case gw of 
-           Wanted {}         -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co))
+           Wanted {}         -> setDictBind dv (EvCast dv' (mkSymCo dict_co))
            Given {}          -> setDictBind dv' (EvCast dv dict_co) 
            Derived {}        -> return () -- Derived dicts we don't set any evidence
 
@@ -1154,11 +1169,11 @@ rewriteDict (cv,tv,xi) (dv,gw,cl,xis)
 
 rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt 
 rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) 
-  = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty     -- ty[tv] ~ t[xi] 
-             ty'   = substTyWith [tv] [xi] ty
+  = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty     -- ty[tv] ~ t[xi]
+             ty'   = substTyWith   [tv] [xi] ty
        ; ipid' <- newIPVar nm ty' 
        ; case gw of 
-           Wanted {}         -> setIPBind ipid  (EvCast ipid' (mkSymCoercion ip_co))
+           Wanted {}         -> setIPBind ipid  (EvCast ipid' (mkSymCo ip_co))
            Given {}          -> setIPBind ipid' (EvCast ipid ip_co) 
            Derived {}        -> return () -- Derived ips: we don't set any evidence
 
@@ -1169,20 +1184,21 @@ rewriteIP (cv,tv,xi) (ipid,gw,nm,ty)
    
 rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt
 rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2)                   -- cv2 :: F args ~ xi2
-  = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args 
-             args'   = substTysWith [tv] [xi1] args 
-             fun_co  = mkTyConCoercion tc arg_cos                 -- fun_co :: F args ~ F args'
+  = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1]
+             arg_cos  = map co_subst args
+             args'    = substTysWith [tv] [xi1] args
+             fun_co   = mkTyConAppCo tc arg_cos                -- fun_co :: F args ~ F args'
 
              xi2'    = substTyWith [tv] [xi1] xi2
-             xi2_co  = substTyWith [tv] [mkCoVarCoercion cv1] xi2 -- xi2_co :: xi2 ~ xi2' 
+             xi2_co  = co_subst xi2 -- xi2_co :: xi2 ~ xi2'
 
        ; cv2' <- newCoVar (mkTyConApp tc args') xi2'
        ; case gw of 
-           Wanted {} -> setCoBind cv2  (fun_co               `mkTransCoercion` 
-                                        mkCoVarCoercion cv2' `mkTransCoercion` 
-                                        mkSymCoercion xi2_co)
-           Given {}  -> setCoBind cv2' (mkSymCoercion fun_co `mkTransCoercion` 
-                                        mkCoVarCoercion cv2  `mkTransCoercion` 
+           Wanted {} -> setCoBind cv2  (fun_co         `mkTransCo` 
+                                        mkCoVarCo cv2' `mkTransCo` 
+                                        mkSymCo xi2_co)
+           Given {}  -> setCoBind cv2' (mkSymCo fun_co `mkTransCo` 
+                                        mkCoVarCo cv2  `mkTransCo` 
                                         xi2_co)
            Derived {} -> return () 
 
@@ -1203,20 +1219,20 @@ rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS WorkLis
 rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) 
   | Just tv2' <- tcGetTyVar_maybe xi2'
   , tv2 == tv2'	 -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2
-  = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2')) 
+  = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2')) 
        ; return emptyWorkList } 
   | otherwise
   = do { cv2' <- newCoVar (mkTyVarTy tv2) xi2'
        ; case gw of
-             Wanted {} -> setCoBind cv2 $ mkCoVarCoercion cv2' `mkTransCoercion` 
-                                          mkSymCoercion co2'
-             Given {}  -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion` 
+             Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo` 
+                                          mkSymCo co2'
+             Given {}  -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo` 
                                            co2'
              Derived {} -> return ()
        ; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' }
   where 
     xi2' = substTyWith [tv1] [xi1] xi2 
-    co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2  -- xi2 ~ xi2[xi1/tv1]
+    co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2  -- xi2 ~ xi2[xi1/tv1]
 
 rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList
 -- Used to ineract two equalities of the following form: 
@@ -1229,9 +1245,9 @@ rewriteEqLHS LeftComesFromInert (co1,xi1) (cv2,gw,xi2)
   = do { cv2' <- newCoVar xi2 xi1 
        ; case gw of 
            Wanted {} -> setCoBind cv2 $ 
-                        co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2')
+                        co1 `mkTransCo` mkSymCo (mkCoVarCo cv2')
            Given {}  -> setCoBind cv2' $ 
-                        mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1 
+                        mkSymCo (mkCoVarCo cv2) `mkTransCo` co1 
            Derived {} -> return ()
        ; mkCanonical gw cv2' }
 
@@ -1239,9 +1255,9 @@ rewriteEqLHS RightComesFromInert (co1,xi1) (cv2,gw,xi2)
   = do { cv2' <- newCoVar xi1 xi2
        ; case gw of
            Wanted {} -> setCoBind cv2 $
-                        co1 `mkTransCoercion` mkCoVarCoercion cv2'
+                        co1 `mkTransCo` mkCoVarCo cv2'
            Given {}  -> setCoBind cv2' $
-                        mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
+                        mkSymCo co1 `mkTransCo` mkCoVarCo cv2
            Derived {} -> return ()
        ; mkCanonical gw cv2' }
 
@@ -1249,12 +1265,12 @@ rewriteFrozen :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor) -> TcS WorkList
 rewriteFrozen (cv1, tv1, xi1) (cv2, fl2)
   = do { cv2' <- newCoVar ty2a' ty2b'  -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1]
        ; case fl2 of
-             Wanted {} -> setCoBind cv2 $ co2a'                `mkTransCoercion`
-                       	         	  mkCoVarCoercion cv2' `mkTransCoercion`
-                       	         	  mkSymCoercion co2b'
+             Wanted {} -> setCoBind cv2 $ co2a'                `mkTransCo`
+                       	         	  mkCoVarCo cv2' `mkTransCo`
+                       	         	  mkSymCo co2b'
 
-             Given {} -> setCoBind cv2' $ mkSymCoercion co2a'  `mkTransCoercion`
-                      	 		  mkCoVarCoercion cv2  `mkTransCoercion`
+             Given {} -> setCoBind cv2' $ mkSymCo co2a'  `mkTransCo`
+                      	 		  mkCoVarCo cv2  `mkTransCo`
                       	 		  co2b'
 
              Derived {} -> return ()
@@ -1265,8 +1281,8 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2)
     ty2a' = substTyWith [tv1] [xi1] ty2a
     ty2b' = substTyWith [tv1] [xi1] ty2b
 
-    co2a' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2a  -- ty2a ~ ty2a[xi1/tv1]
-    co2b' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2b  -- ty2b ~ ty2b[xi1/tv1]
+    co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a  -- ty2a ~ ty2a[xi1/tv1]
+    co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b  -- ty2b ~ ty2b[xi1/tv1]
 
 solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
 -- First argument inert, second argument work-item. They both represent 
@@ -1284,6 +1300,10 @@ solveOneFromTheOther info (ev_term,ifl) workItem
 		  -- so it's safe to continue on from this point
   = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
   
+  | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+    -- Same if the inert is a GivenSolved -- just get rid of it
+  = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+
   | otherwise
   = ASSERT( ifl `canSolve` wfl )
       -- Because of Note [The Solver Invariant], plus Derived dealt with
@@ -1658,33 +1678,34 @@ data TopInteractResult
                                         -- only reacted with functional dependencies 
 					-- arising from top-level instances.
 
-topReactionsStage :: SimplifierStage 
-topReactionsStage depth workItem inerts 
-  = do { tir <- tryTopReact workItem 
-       ; case tir of 
-           NoTopInt -> 
-               return $ SR { sr_inerts   = inerts 
-                           , sr_new_work = emptyWorkList 
-                           , sr_stop     = ContinueWith workItem } 
-           SomeTopInt tir_new_work tir_new_inert -> 
+topReactionsStage :: SimplifierStage
+topReactionsStage depth workItem inerts
+  = do { tir <- tryTopReact inerts workItem
+             -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
+       ; case tir of
+           NoTopInt ->
+               return $ SR { sr_inerts   = inerts
+                           , sr_new_work = emptyWorkList
+                           , sr_stop     = ContinueWith workItem }
+           SomeTopInt tir_new_work tir_new_inert ->
                do { bumpStepCountTcS
                   ; traceFireTcS depth (ptext (sLit "Top react")
                        <+> vcat [ ptext (sLit "Work =") <+> ppr workItem
                                 , ptext (sLit "New =") <+> ppr tir_new_work ])
-                  ; return $ SR { sr_inerts   = inerts 
+                  ; return $ SR { sr_inerts   = inerts
                            	, sr_new_work = tir_new_work
                            	, sr_stop     = tir_new_inert
                            	} }
        }
 
-tryTopReact :: WorkItem -> TcS TopInteractResult 
-tryTopReact workitem 
+tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult 
+tryTopReact inerts workitem 
   = do {  -- A flag controls the amount of interaction allowed
           -- See Note [Simplifying RULE lhs constraints]
          ctxt <- getTcSContext
        ; if allowedTopReaction (simplEqsOnly ctxt) workitem 
          then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
-                 ; doTopReact workitem }
+                 ; doTopReact inerts workitem }
          else return NoTopInt 
        } 
 
@@ -1692,7 +1713,7 @@ allowedTopReaction :: Bool -> WorkItem -> Bool
 allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
 allowedTopReaction _        _             = True
 
-doTopReact :: WorkItem -> TcS TopInteractResult 
+doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
 -- The work item does not react with the inert set, so try interaction with top-level instances
 -- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are 
 --     added in the worklist as part of the canonicalisation process. 
@@ -1700,12 +1721,12 @@ doTopReact :: WorkItem -> TcS TopInteractResult
 
 -- Given dictionary
 -- See Note [Given constraint that matches an instance declaration]
-doTopReact (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_flavor = Given {} })
   = return NoTopInt -- NB: Superclasses already added since it's canonical
 
 -- Derived dictionary: just look for functional dependencies
-doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
-                              , cc_class = cls, cc_tyargs = xis })
+doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+                                      , cc_class = cls, cc_tyargs = xis })
   = do { instEnvs <- getInstEnvs
        ; let fd_eqns = improveFromInstEnv instEnvs
                                                 (ClassP cls xis, pprArisingAt loc)
@@ -1719,10 +1740,10 @@ doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
                                       , tir_new_inert = ContinueWith workItem' } }
 
 -- Wanted dictionary
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
-                              , cc_class = cls, cc_tyargs = xis })
+doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+                                     , cc_class = cls, cc_tyargs = xis })
   = do { -- See Note [MATCHING-SYNONYMS]
-       ; lkp_inst_res <- matchClassInst cls xis loc
+       ; lkp_inst_res <- matchClassInst inerts cls xis loc
        ; case lkp_inst_res of
            NoInstance ->
              do { traceTcS "doTopReact/ no class instance for" (ppr dv)
@@ -1734,7 +1755,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
                 ; case m of
                     Nothing -> return NoTopInt
                     Just (xis',cos,fd_work) ->
-                        do { let dict_co = mkTyConCoercion (classTyCon cls) cos
+                        do { let dict_co = mkTyConAppCo (classTyCon cls) cos
                            ; dv'<- newDictVar cls xis'
                            ; setDictBind dv (EvCast dv' dict_co)
                            ; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl, 
@@ -1748,7 +1769,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
 		   -- matches already so we won't get any more info
 		   -- from functional dependencies
              | null wtvs
-             -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) 
+             -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv) 
                    ; setDictBind dv ev_term 
                     -- Solved in one step and no new wanted work produced. 
                     -- i.e we directly matched a top-level instance
@@ -1757,25 +1778,29 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
                                          , tir_new_inert = Stop } }
 
              | otherwise
-             -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) 
+             -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv) 
                    ; setDictBind dv ev_term 
                         -- Solved and new wanted work produced, you may cache the 
-                        -- (tentatively solved) dictionary as Given! (used to be: Derived)
-                   ; let solved   = workItem { cc_flavor = given_fl }
-                         given_fl = Given (setCtLocOrigin loc UnkSkol) 
+                        -- (tentatively solved) dictionary as Solved given.
+                   ; let solved    = workItem { cc_flavor = solved_fl }
+                         solved_fl = mkSolvedFlavor fl UnkSkol  
                    ; inst_work <- canWanteds wtvs
                    ; return $ SomeTopInt { tir_new_work  = inst_work
                                          , tir_new_inert = ContinueWith solved } }
        }          
 
 -- Type functions
-doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
-                      , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+  | Just GivenSolved <- isGiven_maybe fl
+  = return NoTopInt -- If Solved, no more interactions should happen
+
+-- Otherwise, it's a Given, Derived, or Wanted
+doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl
+                                       , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
   = ASSERT (isSynFamilyTyCon tc)   -- No associated data families have reached that far 
     do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
        ; case match_res of 
-           MatchInstNo 
-             -> return NoTopInt 
+           MatchInstNo -> return NoTopInt 
            MatchInstSingle (rep_tc, rep_tys)
              -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
                          Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
@@ -1783,25 +1808,40 @@ doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
 			    -- RHS of a type function, so that it never
 			    -- appears in an error message
                             -- See Note [Type synonym families] in TyCon
-                         coe = mkTyConApp coe_tc rep_tys 
-                   ; cv' <- case fl of
-                              Wanted {} -> do { cv' <- newCoVar rhs_ty xi
-                                              ; setCoBind cv $ 
-                                                    coe `mkTransCoercion`
-                                                      mkCoVarCoercion cv'
-                                              ; return cv' }
-                              Given {}   -> newGivenCoVar xi rhs_ty $ 
-                                            mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe 
-                              Derived {} -> newDerivedId (EqPred xi rhs_ty)
-                   ; can_cts <- mkCanonical fl cv'
-                   ; return $ SomeTopInt can_cts Stop }
+                         coe = mkAxInstCo coe_tc rep_tys 
+                   ; case fl of
+                       Wanted {} -> do { cv' <- newCoVar rhs_ty xi
+                                       ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
+                                       ; can_cts <- mkCanonical fl cv'
+                                       ; let solved = workItem { cc_flavor = solved_fl }
+                                             solved_fl = mkSolvedFlavor fl UnkSkol
+                                       ; if isEmptyWorkList can_cts then 
+                                              return (SomeTopInt can_cts Stop) -- No point in caching
+                                         else return $ 
+                                              SomeTopInt { tir_new_work = can_cts
+                                                         , tir_new_inert = ContinueWith solved }
+                                       }
+                       Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $ 
+                                               mkSymCo (mkCoVarCo cv) `mkTransCo` coe 
+                                      ; can_cts <- mkCanonical fl cv'
+                                      ; return $ 
+                                        SomeTopInt { tir_new_work = can_cts
+                                                   , tir_new_inert = Stop }
+                                      }
+                       Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty)
+                                        ; can_cts <- mkCanonical fl cv'
+                                        ; return $ 
+                                          SomeTopInt { tir_new_work = can_cts
+                                                     , tir_new_inert = Stop }
+                                        }
+                   }
            _ 
              -> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
        }
 
 
 -- Any other work item does not react with any top-level equations
-doTopReact _workItem = return NoTopInt 
+doTopReact _inerts _workItem = return NoTopInt 
 \end{code}
 
 
@@ -2005,15 +2045,25 @@ data LookupInstResult
   = NoInstance
   | GenInst [WantedEvVar] EvTerm 
 
-matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
-matchClassInst clas tys loc
+matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst inerts clas tys loc
    = do { let pred = mkClassPred clas tys 
         ; mb_result <- matchClass clas tys
+        ; untch <- getUntouchables
         ; case mb_result of
             MatchInstNo   -> return NoInstance
-            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until 
+            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
                                                -- we learn more about the reagent 
-            MatchInstSingle (dfun_id, mb_inst_tys) -> 
+            MatchInstSingle (_,_)
+              | given_overlap untch -> 
+                  do { traceTcS "Delaying instance application" $ 
+                       vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
+                            , text "Silents and their superclasses=" <+> ppr silents_and_their_scs
+                            , text "All given dictionaries=" <+> ppr all_given_dicts ]
+                     ; return NoInstance -- see Note [Instance and Given overlap]
+                     }
+
+            MatchInstSingle (dfun_id, mb_inst_tys) ->
               do { checkWellStagedDFun pred dfun_id loc
 
  	-- It's possible that not all the tyvars are in
@@ -2022,7 +2072,7 @@ matchClassInst clas tys loc
 	-- (presumably there's a functional dependency in class C)
 	-- Hence mb_inst_tys :: Either TyVar TcType 
 
-                 ; tys <- instDFunTypes mb_inst_tys 
+                 ; tys <- instDFunTypes mb_inst_tys
                  ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
                  ; if null theta then
                        return (GenInst [] (EvDFunApp dfun_id tys []))
@@ -2032,4 +2082,94 @@ matchClassInst clas tys loc
                      ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
                  }
         }
+   where given_overlap :: TcsUntouchables -> Bool
+         given_overlap untch
+           = foldlBag (\r d -> r || matchable untch d) False all_given_dicts
+
+         matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
+           | Just GivenOrig <- isGiven_maybe fl
+           , clas' == clas
+           , does_not_originate_in_a_silent clas' sys
+           = case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && 
+                                        tv `elemVarSet` tyVarsOfTypes tys
+                                     then BindMe else Skolem) tys sys of
+           -- We can't learn anything more about any variable at this point, so the only
+           -- cause of overlap can be by an instantiation of a touchable unification
+           -- variable. Hence we only bind touchable unification variables. In addition,
+           -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
+                Nothing -> False
+                Just _  -> True
+           | otherwise = False -- No overlap with a solved, already been taken care of 
+                               -- by the overlap check with the instance environment.
+         matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+
+         does_not_originate_in_a_silent clas sys
+             -- UGLY: See Note [Silent parameters overlapping]
+           = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
+
+         silents_and_their_scs 
+           = foldlBag (\acc rvnt -> case rvnt of
+                        CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
+                         | isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc 
+                        _ -> acc) [] all_given_dicts
+
+         -- TODO:
+         -- When silent parameters will go away we should simply select from 
+         -- the given map of the inert set. 
+         all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
+
 \end{code}
+
+Note [Silent parameters overlapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DV 12/05/2011:
+The long-term goal is to completely remove silent superclass
+parameters when checking instance declarations. But until then we must
+make sure that we never prevent the application of an instance
+declaration because of a potential match from a silent parameter --
+after all we are supposed to have solved that silent parameter from
+some instance, anyway! In effect silent parameters behave more like
+Solved than like Given.
+
+A concrete example appears in typecheck/SilentParametersOverlapping.hs
+
+Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Assume that we have an inert set that looks as follows:
+       [Given] D [Int]
+And an instance declaration: 
+       instance C a => D [a]
+A new wanted comes along of the form: 
+       [Wanted] D [alpha]
+
+One possibility is to apply the instance declaration which will leave us 
+with an unsolvable goal (C alpha). However, later on a new constraint may 
+arise (for instance due to a functional dependency between two later dictionaries), 
+that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha]) 
+will be transformed to [Wanted] D [Int], which could have been discharged by the given. 
+
+The solution is that in matchClassInst and eventually in topReact, we get back with 
+a matching instance, only when there is no Given in the inerts which is unifiable to
+this particular dictionary.
+
+The end effect is that, much as we do for overlapping instances, we delay choosing a 
+class instance if there is a possibility of another instance OR a given to match our 
+constraint later on. This fixes bugs #4981 and #5002.
+
+This is arguably not easy to appear in practice due to our aggressive prioritization 
+of equality solving over other constraints, but it is possible. I've added a test case 
+in typecheck/should-compile/GivenOverlapping.hs
+
+Moreover notice that our goals here are different than the goals of the top-level 
+overlapping checks. There we are interested in validating the following principle:
+ 
+    If we inline a function f at a site where the same global instance environment
+    is available as the instance environment at the definition site of f then we 
+    should get the same behaviour. 
+
+But for the Given Overlap check our goal is just related to completeness of 
+constraint solving. 
+
+
+
+
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 1d163aa..2c01d23 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -26,7 +26,6 @@ module TcMType (
   --------------------------------
   -- Creating new evidence variables
   newEvVar, newCoVar, newEvVars,
-  writeWantedCoVar, readWantedCoVar, 
   newIP, newDict, newSilentGiven, isSilentEvVar,
 
   newWantedEvVar, newWantedEvVars,
@@ -43,16 +42,15 @@ module TcMType (
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
   SourceTyCtxt(..), checkValidTheta, 
-  checkValidInstance,
-  checkValidTypeInst, checkTyFamFreeness,
+  checkValidInstHead, checkValidInstance, 
+  checkInstTermination, checkValidTypeInst, checkTyFamFreeness, 
   arityErr, 
   growPredTyVars, growThetaTyVars, validDerivPred,
 
   --------------------------------
   -- Zonking
   zonkType, mkZonkTcTyVar, zonkTcPredType, 
-  zonkTcTypeCarefully,
-  skolemiseUnboundMetaTyVar,
+  zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
@@ -72,7 +70,6 @@ module TcMType (
 import TypeRep
 import TcType
 import Type
-import Coercion
 import Class
 import TyCon
 import Var
@@ -145,7 +142,7 @@ newEvVar (IParam ip ty)   = newIP    ip ty
 
 newCoVar :: TcType -> TcType -> TcM CoVar
 newCoVar ty1 ty2
-  = do { name <- newName (mkTyVarOccFS (fsLit "co"))
+  = do { name <- newName (mkVarOccFS (fsLit "co"))
        ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
 
 newIP :: IPName Name -> TcType -> TcM IpId
@@ -300,10 +297,6 @@ readMetaTyVar :: TyVar -> TcM MetaDetails
 readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
 		      readMutVar (metaTvRef tyvar)
 
-readWantedCoVar :: CoVar -> TcM MetaDetails
-readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar )
-		        readMutVar (metaTvRef covar)
-
 isFilledMetaTyVar :: TyVar -> TcM Bool
 -- True of a filled-in (Indirect) meta type variable
 isFilledMetaTyVar tv
@@ -342,9 +335,6 @@ writeMetaTyVar tyvar ty
   = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
     return ()
 
-writeWantedCoVar :: CoVar -> Coercion -> TcM () 
-writeWantedCoVar cv co = writeMetaTyVar cv co 
-
 --------------------
 writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
 -- Here the tyvar is for error checking only; 
@@ -627,8 +617,8 @@ zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
 zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
 
 zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
-zonkFlavor fl          = return fl
+zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
+zonkFlavor fl             = return fl
 
 zonkGivenLoc :: GivenLoc -> TcM GivenLoc
 -- GivenLocs may have unification variables inside them!
@@ -750,13 +740,12 @@ zonkType zonk_tc_tyvar ty
 
 	-- The two interesting cases!
     go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
-		       | otherwise	 = liftM TyVarTy $ 
-                                           zonkTyVar zonk_tc_tyvar tyvar
+		       | otherwise	 = return (TyVarTy tyvar)
 		-- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             tyvar' <- zonkTyVar zonk_tc_tyvar tyvar
+                             tyvar' <- return tyvar
                              return (ForAllTy tyvar' ty')
 
     go_pred (ClassP c tys)   = do tys' <- mapM go tys
@@ -779,16 +768,6 @@ mkZonkTcTyVar unbound_var_fn tyvar
 			   ; case cts of    
 			       Flexi       -> unbound_var_fn tyvar  
 			       Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
-
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable 
--- (their kind contains types).
-zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for a TcTyVar
- 	  -> TyVar -> TcM TyVar
-zonkTyVar zonk_tc_tyvar tv 
-  | isCoVar tv
-  = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv)
-       ; return $ setTyVarKind tv kind }
-  | otherwise = return tv
 \end{code}
 
 
@@ -1159,7 +1138,7 @@ check_valid_theta ctxt theta = do
     warnTc (notNull dups) (dupPredWarn dups)
     mapM_ (check_pred_ty dflags ctxt) theta
   where
-    (_,dups) = removeDups tcCmpPred theta
+    (_,dups) = removeDups cmpPred theta
 
 -------------------------
 check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM ()
@@ -1281,7 +1260,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars
 
 ambigErr :: PredType -> SDoc
 ambigErr pred
-  = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
+  = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred),
 	 nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
 		 ptext (sLit "must be reachable from the type after the '=>'"))]
 \end{code}
@@ -1348,14 +1327,14 @@ eqSuperClassErr pred
        2 (ppr pred)
 
 badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc
-badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred
-eqPredTyErr  pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred
+badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred
+eqPredTyErr  pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred
 		    $$
 		    parens (ptext (sLit "Use -XTypeFamilies to permit this"))
 predTyVarErr pred  = sep [ptext (sLit "Non type-variable argument"),
-			  nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+			  nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
 dupPredWarn :: [[PredType]] -> SDoc
-dupPredWarn dups   = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+dupPredWarn dups   = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups)
 
 arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
 arityErr kind name n m
@@ -1503,7 +1482,7 @@ checkInstTermination tys theta
 
 predUndecErr :: PredType -> SDoc -> SDoc
 predUndecErr pred msg = sep [msg,
-			nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+			nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
 
 nomoreMsg, smallerMsg, undecidableMsg :: SDoc
 nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 860a6db..29890a2 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -6,16 +6,18 @@
 TcMatches: Typecheck some @Matches@
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}   -- debugging
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
-		   TcMatchCtxt(..), 
-		   tcStmts, tcDoStmts, tcBody,
-		   tcDoStmt, tcMDoStmt, tcGuardStmt
+		   TcMatchCtxt(..), TcStmtChecker,
+		   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+		   tcDoStmt, tcGuardStmt
        ) where
 
-import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
+import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
 import HsSyn
+import BasicTypes
 import TcRnMonad
 import TcEnv
 import TcPat
@@ -28,13 +30,15 @@ import TysWiredIn
 import Id
 import TyCon
 import TysPrim
-import Coercion		( mkSymCoI )
+import Coercion         ( isReflCo, mkSymCo )
 import Outputable
-import BasicTypes	( Arity )
 import Util
 import SrcLoc
 import FastString
 
+-- Create chunkified tuple tybes for monad comprehensions
+import MkCore
+
 import Control.Monad
 
 #include "HsVersions.h"
@@ -143,7 +147,7 @@ matchFunTys
 matchFunTys herald arity res_ty thing_inside
   = do	{ (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
 	; res <- thing_inside pat_tys res_ty
-        ; return (coiToHsWrapper (mkSymCoI coi), res) }
+        ; return (coToHsWrapper (mkSymCo coi), res) }
 \end{code}
 
 %************************************************************************
@@ -221,7 +225,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty
 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
 
 tcGRHS ctxt res_ty (GRHS guards rhs)
-  = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+  = do  { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
 			     mc_body ctxt rhs
 	; return (GRHS guards' rhs') }
   where
@@ -238,36 +242,33 @@ tcGRHS ctxt res_ty (GRHS guards rhs)
 \begin{code}
 tcDoStmts :: HsStmtContext Name 
 	  -> [LStmt Name]
-	  -> LHsExpr Name
 	  -> TcRhoType
 	  -> TcM (HsExpr TcId)		-- Returns a HsDo
-tcDoStmts ListComp stmts body res_ty
+tcDoStmts ListComp stmts res_ty
   = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
-	; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts 
-				     elt_ty $
-			     tcBody body
-	; return $ mkHsWrapCoI coi 
-                     (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+        ; let list_ty = mkListTy elt_ty
+	; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
+	; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) }
 
-tcDoStmts PArrComp stmts body res_ty
+tcDoStmts PArrComp stmts res_ty
   = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
-	; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts 
-				     elt_ty $
-			     tcBody body
-	; return $ mkHsWrapCoI coi 
-                     (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
+        ; let parr_ty = mkPArrTy elt_ty
+	; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
+	; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) }
+
+tcDoStmts DoExpr stmts res_ty
+  = do	{ stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+	; return (HsDo DoExpr stmts' res_ty) }
 
-tcDoStmts DoExpr stmts body res_ty
-  = do	{ (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
-			     tcBody body
-	; return (HsDo DoExpr stmts' body' res_ty) }
+tcDoStmts MDoExpr stmts res_ty
+  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+        ; return (HsDo MDoExpr stmts' res_ty) }
 
-tcDoStmts MDoExpr stmts body res_ty
-  = do  { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
-			     tcBody body
-        ; return (HsDo MDoExpr stmts' body' res_ty) }
+tcDoStmts MonadComp stmts res_ty
+  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty 
+        ; return (HsDo MonadComp stmts' res_ty) }
 
-tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 tcBody body res_ty
@@ -296,40 +297,52 @@ tcStmts :: HsStmtContext Name
 	-> TcStmtChecker	-- NB: higher-rank type
         -> [LStmt Name]
 	-> TcRhoType
-	-> (TcRhoType -> TcM thing)
-        -> TcM ([LStmt TcId], thing)
+        -> TcM [LStmt TcId]
+tcStmts ctxt stmt_chk stmts res_ty
+  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
+                        const (return ())
+       ; return stmts' }
+
+tcStmtsAndThen :: HsStmtContext Name
+	       -> TcStmtChecker	-- NB: higher-rank type
+               -> [LStmt Name]
+	       -> TcRhoType
+	       -> (TcRhoType -> TcM thing)
+               -> TcM ([LStmt TcId], thing)
 
 -- Note the higher-rank type.  stmt_chk is applied at different
 -- types in the equations for tcStmts
 
-tcStmts _ _ [] res_ty thing_inside
+tcStmtsAndThen _ _ [] res_ty thing_inside
   = do	{ thing <- thing_inside res_ty
 	; return ([], thing) }
 
 -- LetStmts are handled uniformly, regardless of context
-tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
   = do	{ (binds', (stmts',thing)) <- tcLocalBinds binds $
-				      tcStmts ctxt stmt_chk stmts res_ty thing_inside
+				      tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
 	; return (L loc (LetStmt binds') : stmts', thing) }
 
 -- For the vanilla case, handle the location-setting part
-tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
   = do 	{ (stmt', (stmts', thing)) <- 
-		setSrcSpan loc		 		$
-    		addErrCtxt (pprStmtInCtxt ctxt stmt)	$
-		stmt_chk ctxt stmt res_ty		$ \ res_ty' ->
-		popErrCtxt 				$
-		tcStmts ctxt stmt_chk stmts res_ty'	$
+		setSrcSpan loc		 		    $
+    		addErrCtxt (pprStmtInCtxt ctxt stmt)	    $
+		stmt_chk ctxt stmt res_ty		    $ \ res_ty' ->
+		popErrCtxt 				    $
+		tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
 		thing_inside
 	; return (L loc stmt' : stmts', thing) }
 
---------------------------------
---	Pattern guards
+---------------------------------------------------
+--	        Pattern guards
+---------------------------------------------------
+
 tcGuardStmt :: TcStmtChecker
-tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
+tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
   = do	{ guard' <- tcMonoExpr guard boolTy
 	; thing  <- thing_inside res_ty
-	; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
+	; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 
 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRhoNC rhs	-- Stmt has a context already
@@ -341,25 +354,292 @@ tcGuardStmt _ stmt _ _
   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 
 
---------------------------------
---	List comprehensions and PArrays
+---------------------------------------------------
+--	     List comprehensions and PArrays
+--	         (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+--   a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
+--   b) We have special desugaring rules for list comprehensions,
+--      which avoid creating intermediate lists.  They in turn 
+--      assume that the bind/return operations are the regular
+--      polymorphic ones, and in particular don't have any
+--      coercion matching stuff in them.  It's hard to avoid the
+--      potential for non-trivial coercions in tcMcStmt
 
 tcLcStmt :: TyCon	-- The list/Parray type constructor ([] or PArray)
 	 -> TcStmtChecker
 
+tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
+  = do { body' <- tcMonoExprNC body elt_ty
+       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
+       ; return (LastStmt body' noSyntaxExpr, thing) }
+
 -- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
  = do	{ pat_ty <- newFlexiTyVarTy liftedTypeKind
         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
 	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
-                            thing_inside res_ty
+                            thing_inside elt_ty
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- A boolean guard
-tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
+tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
   = do	{ rhs'  <- tcMonoExpr rhs boolTy
-	; thing <- thing_inside res_ty
-	; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
+	; thing <- thing_inside elt_ty
+	; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
+
+-- ParStmt: See notes with tcMcStmt
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
+  = do	{ (pairs', thing) <- loop bndr_stmts_s
+	; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
+  where
+    -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
+    loop [] = do { thing <- thing_inside elt_ty
+		 ; return ([], thing) }		-- matching in the branches
+
+    loop ((stmts, names) : pairs)
+      = do { (stmts', (ids, pairs', thing))
+		<- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+		   do { ids <- tcLookupLocalIds names
+		      ; (pairs', thing) <- loop pairs
+		      ; return (ids, pairs', thing) }
+	   ; return ( (stmts', ids) : pairs', thing ) }
+
+tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
+                              , trS_bndrs =  bindersMap
+                              , trS_by = by, trS_using = using }) elt_ty thing_inside
+  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
+       	     -- The inner 'stmts' lack a LastStmt, so the element type
+	     --  passed in to tcStmtsAndThen is never looked at
+       ; (stmts', (bndr_ids, by'))
+            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+	       { by' <- case by of
+                           Nothing -> return Nothing
+                           Just e  -> do { e_ty <- tcInferRho e; return (Just e_ty) }
+               ; bndr_ids <- tcLookupLocalIds bndr_names
+               ; return (bndr_ids, by') }
+
+       ; let m_app ty = mkTyConApp m_tc [ty]
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
+       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
+       ; let n_app = case form of
+                       ThenForm -> (\ty -> ty)
+  		       _ 	-> m_app
+
+             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+             by_arrow = case by' of
+                          Nothing       -> \ty -> ty
+                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
+
+             tup_ty        = mkBigCoreVarTupTy bndr_ids
+             poly_arg_ty   = m_app alphaTy
+	     poly_res_ty   = m_app (n_app alphaTy)
+	     using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ 
+                             poly_arg_ty `mkFunTy` poly_res_ty
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' 
+
+	     -- 'stmts' returns a result of type (m1_ty tuple_ty),
+	     -- typically something like [(Int,Bool,Int)]
+	     -- We don't know what tuple_ty is yet, so we use a variable
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+	     -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with 
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
+
+       ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' 
+                                , trS_by = fmap fst by', trS_using = final_using 
+                                , trS_form = form }, thing) }
+    
+tcLcStmt _ _ stmt _ _
+  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--	     Monad comprehensions 
+--	  (supports rebindable syntax)
+---------------------------------------------------
+
+tcMcStmt :: TcStmtChecker
+
+tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
+  = do  { a_ty       <- newFlexiTyVarTy liftedTypeKind
+        ; return_op' <- tcSyntaxOp MCompOrigin return_op
+                                   (a_ty `mkFunTy` res_ty)
+        ; body'      <- tcMonoExprNC body a_ty
+        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
+        ; return (LastStmt body' return_op', thing) } 
+
+-- Generators for monad comprehensions ( pat <- rhs )
+--
+--   [ body | q <- gen ]  ->  gen :: m a
+--                            q   ::   a
+--
+
+tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+ = do   { rhs_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+
+	   -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+        ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op 
+                             (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
+
+           -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- if isIrrefutableHsPat pat 
+                      then return noSyntaxExpr
+                      else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
+
+        ; rhs' <- tcMonoExprNC rhs rhs_ty
+        ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
+                           thing_inside new_res_ty
+
+        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+
+-- Boolean expressions.
+--
+--   [ body | stmts, expr ]  ->  expr :: m Bool
+--
+tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
+  = do	{ -- Deal with rebindable syntax:
+          --    guard_op :: test_ty -> rhs_ty
+          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
+          -- Where test_ty is, for example, Bool
+          test_ty    <- newFlexiTyVarTy liftedTypeKind
+        ; rhs_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+        ; rhs'       <- tcMonoExpr rhs test_ty
+        ; guard_op'  <- tcSyntaxOp MCompOrigin guard_op
+                                   (mkFunTy test_ty rhs_ty)
+        ; then_op'   <- tcSyntaxOp MCompOrigin then_op
+		                   (mkFunTys [rhs_ty, new_res_ty] res_ty)
+	; thing      <- thing_inside new_res_ty
+	; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
+
+-- Grouping statements
+--
+--   [ body | stmts, then group by e ]
+--     ->  e :: t
+--   [ body | stmts, then group by e using f ]
+--     ->  e :: t
+--         f :: forall a. (a -> t) -> m a -> m (m a)
+--   [ body | stmts, then group using f ]
+--     ->  f :: forall a. m a -> m (m a)
+
+-- We type [ body | (stmts, group by e using f), ... ]
+--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
+--
+-- We type the functions as follows:
+--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)		(ThenForm)
+--     	 	       :: m1 (a,b,c) -> m2 (n (a,b,c))		(GroupForm)
+--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res	(ThenForm)
+--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res	(GroupForm)
+-- 
+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
+                         , trS_by = by, trS_using = using, trS_form = form
+                         , trS_ret = return_op, trS_bind = bind_op 
+                         , trS_fmap = fmap_op }) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+       ; m1_ty   <- newFlexiTyVarTy star_star_kind
+       ; m2_ty   <- newFlexiTyVarTy star_star_kind
+       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
+       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
+       ; n_app <- case form of
+                    ThenForm -> return (\ty -> ty)
+		    _ 	     -> do { n_ty <- newFlexiTyVarTy star_star_kind
+                      	           ; return (n_ty `mkAppTy`) }
+       ; let by_arrow :: Type -> Type     
+             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
+             --                          or res                    ('by' absent) 
+             by_arrow = case by of
+                          Nothing -> \res -> res
+                          Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
+
+             poly_arg_ty  = m1_ty `mkAppTy` alphaTy
+             using_arg_ty = m1_ty `mkAppTy` tup_ty
+	     poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
+	     using_res_ty = m2_ty `mkAppTy` n_app tup_ty
+	     using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ 
+                             poly_arg_ty `mkFunTy` poly_res_ty
+
+	     -- 'stmts' returns a result of type (m1_ty tuple_ty),
+	     -- typically something like [(Int,Bool,Int)]
+	     -- We don't know what tuple_ty is yet, so we use a variable
+       ; let (bndr_names, n_bndr_names) = unzip bindersMap
+       ; (stmts', (bndr_ids, by', return_op')) <-
+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
+	        { by' <- case by of
+                           Nothing -> return Nothing
+                           Just e  -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
+
+                -- Find the Ids (and hence types) of all old binders
+                ; bndr_ids <- tcLookupLocalIds bndr_names
+
+                -- 'return' is only used for the binders, so we know its type.
+                --   return :: (a,b,c,..) -> m (a,b,c,..)
+                ; return_op' <- tcSyntaxOp MCompOrigin return_op $ 
+                                (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
+
+                ; return (bndr_ids, by', return_op') }
+
+       --------------- Typecheck the 'bind' function -------------
+       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+       ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+                                using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
+                                             `mkFunTy` res_ty
+
+       --------------- Typecheck the 'fmap' function -------------
+       ; fmap_op' <- case form of
+                       ThenForm -> return noSyntaxExpr
+                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
+                            mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
+                            (alphaTy `mkFunTy` betaTy)
+                            `mkFunTy` (n_app alphaTy)
+                            `mkFunTy` (n_app betaTy)
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' 
+
+       --------------- Bulding the bindersMap ----------------
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+	     -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with 
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty)
+
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' 
+                           , trS_by = by', trS_using = final_using 
+                           , trS_ret = return_op', trS_bind = bind_op'
+                           , trS_fmap = fmap_op', trS_form = form }, thing) }
 
 -- A parallel set of comprehensions
 --	[ (g x, h x) | ... ; let g v = ...
@@ -381,106 +661,95 @@ tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 -- So the binders of the first parallel group will be in scope in the second
 -- group.  But that's fine; there's no shadowing to worry about.
-
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
-  = do	{ (pairs', thing) <- loop bndr_stmts_s
-	; return (ParStmt pairs', thing) }
-  where
-    -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
-    loop [] = do { thing <- thing_inside elt_ty
-		 ; return ([], thing) }		-- matching in the branches
-
-    loop ((stmts, names) : pairs)
-      = do { (stmts', (ids, pairs', thing))
-		<- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
-		   do { ids <- tcLookupLocalIds names
-		      ; (pairs', thing) <- loop pairs
-		      ; return (ids, pairs', thing) }
-	   ; return ( (stmts', ids) : pairs', thing ) }
-
-tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
-    (stmts', (binders', usingExpr', maybeByExpr', thing)) <- 
-        tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
-            let alphaListTy = mkTyConApp m_tc [alphaTy]
-                    
-            (usingExpr', maybeByExpr') <- 
-                case maybeByExpr of
-                    Nothing -> do
-                        -- We must validate that usingExpr :: forall a. [a] -> [a]
-                        let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
-                        usingExpr' <- tcPolyExpr usingExpr using_ty
-                        return (usingExpr', Nothing)
-                    Just byExpr -> do
-                        -- We must infer a type such that e :: t and then check that 
-			-- usingExpr :: forall a. (a -> t) -> [a] -> [a]
-                        (byExpr', tTy) <- tcInferRhoNC byExpr
-                        let using_ty = mkForAllTy alphaTyVar $ 
-                                       (alphaTy `mkFunTy` tTy)
-                                       `mkFunTy` alphaListTy `mkFunTy` alphaListTy
-                        usingExpr' <- tcPolyExpr usingExpr using_ty
-                        return (usingExpr', Just byExpr')
-            
-            binders' <- tcLookupLocalIds binders
-            thing <- thing_inside elt_ty'
-            
-            return (binders', usingExpr', maybeByExpr', thing)
-
-    return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
-
-tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
-  = do { let (bndr_names, list_bndr_names) = unzip bindersMap
-
-       ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
-            tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
-	        (by', using_ty) <- 
-                   case by of
-                     Nothing   -> -- check that using :: forall a. [a] -> [[a]]
-                                  return (Nothing, mkForAllTy alphaTyVar $
-                                                   alphaListTy `mkFunTy` alphaListListTy)
-		     			
-		     Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
-		     	          -- where by :: t
-                                  do { (by_e', t_ty) <- tcInferRhoNC by_e
-                                     ; return (Just by_e', mkForAllTy alphaTyVar $
-                                                           (alphaTy `mkFunTy` t_ty) 
-                                                           `mkFunTy` alphaListTy 
-                                                           `mkFunTy` alphaListListTy) }
-                -- Find the Ids (and hence types) of all old binders
-                bndr_ids <- tcLookupLocalIds bndr_names
-                
-                return (bndr_ids, by', using_ty, elt_ty')
-        
-                -- Ensure that every old binder of type b is linked up with
-		-- its new binder which should have type [b]
-       ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
-             bindersMap' = bndr_ids `zip` list_bndr_ids
-	     -- See Note [GroupStmt binder map] in HsExpr
-            
-       ; using' <- case using of
-                     Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
-                     Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
-
-             -- Type check the thing in the environment with 
-	     -- these new binders and return the result
-       ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
-       ; return (GroupStmt stmts' bindersMap' by' using', thing) }
-  where
-    alphaListTy = mkTyConApp m_tc [alphaTy]
-    alphaListListTy = mkTyConApp m_tc [alphaListTy]
-            
-    mk_list_bndr :: Name -> TcId -> TcId
-    mk_list_bndr list_bndr_name bndr_id 
-      = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
-    
-tcLcStmt _ _ stmt _ _
-  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
-        
---------------------------------
---	Do-notation
--- The main excitement here is dealing with rebindable syntax
+--
+-- Note: The `mzip` function will get typechecked via:
+--
+--   ParStmt [st1::t1, st2::t2, st3::t3]
+--   
+--   mzip :: m st1
+--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
+--        -> m (st1, (st2, st3))
+--
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+       ; m_ty   <- newFlexiTyVarTy star_star_kind
+
+       ; let mzip_ty  = mkForAllTys [alphaTyVar, betaTyVar] $
+                        (m_ty `mkAppTy` alphaTy)
+                        `mkFunTy`
+                        (m_ty `mkAppTy` betaTy)
+                        `mkFunTy`
+                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+
+       ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
+                       mkForAllTy alphaTyVar $
+                       alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
+
+       ; (pairs', thing) <- loop m_ty bndr_stmts_s
+
+       -- Typecheck bind:
+       ; let tys      = map (mkBigCoreVarTupTy . snd) pairs'
+             tuple_ty = mk_tuple_ty tys
+
+       ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+                        (m_ty `mkAppTy` tuple_ty)
+                        `mkFunTy` (tuple_ty `mkFunTy` res_ty)
+                        `mkFunTy` res_ty
+
+       ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
+
+  where 
+    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+
+       -- loop :: Type                                  -- m_ty
+       --      -> [([LStmt Name], [Name])]
+       --      -> TcM ([([LStmt TcId], [TcId])], thing)
+    loop _ [] = do { thing <- thing_inside res_ty
+                   ; return ([], thing) }           -- matching in the branches
+
+    loop m_ty ((stmts, names) : pairs)
+      = do { -- type dummy since we don't know all binder types yet
+             ty_dummy <- newFlexiTyVarTy liftedTypeKind
+           ; (stmts', (ids, pairs', thing))
+                <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
+                   do { ids <- tcLookupLocalIds names
+    		      ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
+
+    		      ; check_same m_tup_ty res_ty'
+    		      ; check_same m_tup_ty ty_dummy
+    							 
+                      ; (pairs', thing) <- loop m_ty pairs
+                      ; return (ids, pairs', thing) }
+           ; return ( (stmts', ids) : pairs', thing ) }
+
+	-- Check that the types match up.
+	-- This is a grevious hack.  They always *will* match 
+	-- If (>>=) and (>>) are polymorpic in the return type,
+	-- but we don't have any good way to incorporate the coercion
+	-- so for now we just check that it's the identity
+    check_same actual expected
+      = do { coi <- unifyType actual expected
+	   ; unless (isReflCo coi) $
+             failWithMisMatch [UnifyOrigin { uo_expected = expected
+                                           , uo_actual = actual }] }
+
+tcMcStmt _ stmt _ _
+  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--	     Do-notation
+--	  (supports rebindable syntax)
+---------------------------------------------------
 
 tcDoStmt :: TcStmtChecker
 
+tcDoStmt _ (LastStmt body _) res_ty thing_inside
+  = do { body' <- tcMonoExprNC body res_ty
+       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
+       ; return (LastStmt body' noSyntaxExpr, thing) }
+
 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
   = do	{ 	-- Deal with rebindable syntax:
 		--	 (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
@@ -510,7 +779,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 	; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
 
-tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
+tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
   = do	{   	-- Deal with rebindable syntax; 
                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 		-- See also Note [Treat rebindable syntax first]
@@ -521,7 +790,7 @@ tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
 
         ; rhs' <- tcMonoExprNC rhs rhs_ty
 	; thing <- thing_inside new_res_ty
-	; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+	; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
 
 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
@@ -535,7 +804,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         ; tcExtendIdEnv tup_ids $ do
         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
         ; (stmts', (ret_op', tup_rets))
-                <- tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
+                <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
                              -- Unify the types of the "final" Ids (which may 
                              -- be polymorphic) with those of "knot-tied" Ids
@@ -551,7 +820,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 			         (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 
         ; thing <- thing_inside new_res_ty
---         ; lie_binds <- bindLocalMethods lie tup_ids
   
         ; let rec_ids = takeList rec_names tup_ids
 	; later_ids <- tcLookupLocalIds later_names
@@ -560,7 +828,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' 
                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
-                          , recS_rec_rets = tup_rets }, thing)
+                          , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
         }}
 
 tcDoStmt _ stmt _ _
@@ -577,51 +845,6 @@ rebindable syntax first, and push that information into (tcMonoExprNC rhs).
 Otherwise the error shows up when cheking the rebindable syntax, and
 the expected/inferred stuff is back to front (see Trac #3613).
 
-\begin{code}
---------------------------------
---	Mdo-notation
--- The distinctive features here are
---	(a) RecStmts, and
---	(b) no rebindable syntax
-
-tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))	-- RHS inference
-	  -> TcStmtChecker
-tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
-  = do	{ (rhs', pat_ty) <- tc_rhs rhs
-	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
-                            thing_inside res_ty
-	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
-  = do	{ (rhs', elt_ty) <- tc_rhs rhs
-	; thing 	 <- thing_inside res_ty
-	; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
-
-tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
-                               , recS_rec_ids = recNames }) res_ty thing_inside
-  = do	{ rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
-	; let rec_ids = zipWith mkLocalId recNames rec_tys
-	; tcExtendIdEnv rec_ids			$ do
-    	{ (stmts', (later_ids, rec_rets))
-		<- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty	$ \ _res_ty' ->
-			-- ToDo: res_ty not really right
-		   do { rec_rets <- zipWithM tcCheckId recNames rec_tys
-		      ; later_ids <- tcLookupLocalIds laterNames
-		      ; return (later_ids, rec_rets) }
-
-	; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
-		-- NB:	The rec_ids for the recursive things 
-		-- 	already scope over this part. This binding may shadow
-		--	some of them with polymorphic things with the same Name
-		--	(see note [RecStmt] in HsExpr)
-
-        ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
-	}}
-
-tcMDoStmt _ _ stmt _ _
-  = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
-\end{code}
-
 
 %************************************************************************
 %*									*
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index d28e901..8304a22 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -36,7 +36,6 @@ import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
 import DynFlags
 import SrcLoc
-import ErrUtils
 import Util
 import Outputable
 import FastString
@@ -149,7 +148,7 @@ data TcSigInfo
 
 instance Outputable TcSigInfo where
     ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
-        = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau
+        = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
 \end{code}
 
 Note [sig_tau may be polymorphic]
@@ -193,7 +192,7 @@ res_ty free vars.
 %************************************************************************
 
 \begin{code}
-tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId)
+tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId)
 -- (coi, xp) = tcPatBndr penv x pat_ty
 -- Then coi : pat_ty ~ typeof(xp)
 --
@@ -205,11 +204,11 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
       
   | otherwise
   = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
-       ; return (IdCo pat_ty, bndr_id) }
+       ; return (mkReflCo pat_ty, bndr_id) }
 
 tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
   = do { bndr <- mkLocalBinder bndr_name pat_ty
-       ; return (IdCo pat_ty, bndr) }
+       ; return (mkReflCo pat_ty, bndr) }
 
 ------------
 newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId
@@ -348,9 +347,9 @@ tc_lpat :: LPat Name
 	-> TcM a
 	-> TcM (LPat TcId, a)
 tc_lpat (L span pat) pat_ty penv thing_inside
-  = setSrcSpan span		  $
-    maybeAddErrCtxt (patCtxt pat) $
-    do	{ (pat', res) <- tc_pat penv pat pat_ty thing_inside
+  = setSrcSpan span $
+    do	{ (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+                                          thing_inside
 	; return (L span pat', res) }
 
 tc_lpats :: PatEnv
@@ -373,7 +372,7 @@ tc_pat	:: PatEnv
 tc_pat penv (VarPat name) pat_ty thing_inside
   = do	{ (coi, id) <- tcPatBndr penv name pat_ty
     	; res <- tcExtendIdEnv1 name id thing_inside
-        ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
+        ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) }
 
 tc_pat penv (ParPat pat) pat_ty thing_inside
   = do	{ (pat', res) <- tc_lpat pat pat_ty penv thing_inside
@@ -423,7 +422,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
 	    -- perhaps be fixed, but only with a bit more work.
 	    --
 	    -- If you fix it, don't forget the bindInstsOfPatIds!
-	; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+	; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
 
 tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside 
   = do	{ checkUnboxedTuple overall_pat_ty $
@@ -448,7 +447,7 @@ tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside
          -- pattern must have pat_ty
         ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
 
-	; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) }
+	; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) }
 
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
@@ -459,9 +458,6 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
 
         ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
 
-tc_pat _ pat@(TypePat _) _ _
-  = failWithTc (badTypePat pat)
-
 ------------------------
 -- Lists, tuples, arrays
 tc_pat penv (ListPat pats _) pat_ty thing_inside
@@ -511,7 +507,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside
 	; coi <- unifyPatType lit_ty pat_ty
 		-- coi is of kind: pat_ty ~ lit_ty
 	; res <- thing_inside 
-	; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty 
+	; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty 
                  , res) }
 
 ------------------------
@@ -546,19 +542,19 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
 	; instStupidTheta orig [mkClassPred icls [pat_ty']]	
     
 	; res <- tcExtendIdEnv1 name bndr_id thing_inside
-	; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
+	; return (mkHsWrapPatCo coi pat' pat_ty, res) }
 
 tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut
 
 ----------------
-unifyPatType :: TcType -> TcType -> TcM CoercionI
+unifyPatType :: TcType -> TcType -> TcM Coercion
 -- In patterns we want a coercion from the
 -- context type (expected) to the actual pattern type
 -- But we don't want to reverse the args to unifyType because
 -- that controls the actual/expected stuff in error messages
 unifyPatType actual_ty expected_ty
   = do { coi <- unifyType actual_ty expected_ty
-       ; return (mkSymCoI coi) }
+       ; return (mkSymCo coi) }
 \end{code}
 
 Note [Hopping the LIE in lazy patterns]
@@ -657,7 +653,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
   = do	{ data_con <- tcLookupDataCon con_name
 	; let tycon = dataConTyCon data_con
          	  -- For data families this is the representation tycon
-	      (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+	      (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
                 = dataConFullSig data_con
 
 	  -- Instantiate the constructor type variables [a->ty]
@@ -679,9 +675,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 	      tenv     = zipTopTvSubst (univ_tvs     ++ ex_tvs)
 				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 	      arg_tys' = substTys tenv arg_tys
-	      full_theta = eq_theta ++ dict_theta
 
-	; if null ex_tvs && null eq_spec && null full_theta
+	; if null ex_tvs && null eq_spec && null theta
 	  then do { -- The common case; no class bindings etc 
                     -- (see Note [Arrows and patterns])
 		    (arg_pats', res) <- tcConArgs data_con arg_tys' 
@@ -696,8 +691,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 
 	  else do   -- The general case, with existential, 
                     -- and local equality constraints
-	{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
-	      theta'   = substTheta tenv (eq_preds ++ full_theta)
+	{ let theta'   = substTheta tenv (eqSpecPreds eq_spec ++ theta)
                            -- order is *important* as we generate the list of
                            -- dictionary binders from theta'
 	      no_equalities = not (any isEqPred theta')
@@ -726,21 +720,21 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
 	} }
 
 ----------------------------
-matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a))
+matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a))
                     -> TcRhoType -> TcM (HsWrapper, a) 
 -- See Note [Matching polytyped patterns]
 -- Returns a wrapper : pat_ty ~ inner_ty
 matchExpectedPatTy inner_match pat_ty
   | null tvs && null theta
   = do { (coi, res) <- inner_match pat_ty
-       ; return (coiToHsWrapper (mkSymCoI coi), res) }
+       ; return (coToHsWrapper (mkSymCo coi), res) }
        	 -- The Sym is because the inner_match returns a coercion
 	 -- that is the other way round to matchExpectedPatTy
 
   | otherwise
   = do { (_, tys, subst) <- tcInstTyVars tvs
        ; wrap1 <- instCall PatOrigin tys (substTheta subst theta)
-       ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau)
+       ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau)
        ; return (wrap2 <.> wrap1 , arg_tys) }
   where
     (tvs, theta, tau) = tcSplitSigmaTy pat_ty
@@ -749,7 +743,7 @@ matchExpectedPatTy inner_match pat_ty
 matchExpectedConTy :: TyCon  	 -- The TyCon that this data 
 		    		 -- constructor actually returns
 		   -> TcRhoType  -- The type of the pattern
-		   -> TcM (CoercionI, [TcSigmaType])
+		   -> TcM (Coercion, [TcSigmaType])
 -- See Note [Matching constructor patterns]
 -- Returns a coercion : T ty1 ... tyn ~ pat_ty
 -- This is the same way round as matchExpectedListTy etc
@@ -764,17 +758,16 @@ matchExpectedConTy data_tc pat_ty
        ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
        	     -- coi1 : T (ty1,ty2) ~ pat_ty
 
-       ; let coi2 = ACo (mkTyConApp co_tc tys)
+       ; let coi2 = mkAxInstCo co_tc tys
        	     -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2
 
-       ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) }
+       ; return (mkTransCo (mkSymCo coi2) coi1, tys) }
 
   | otherwise
   = matchExpectedTyConApp data_tc pat_ty
        	     -- coi : T tys ~ pat_ty
 \end{code}
 
-Noate [
 Note [Matching constructor patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
@@ -1006,12 +999,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 -}
 
 \begin{code}
-patCtxt :: Pat Name -> Maybe Message	-- Not all patterns are worth pushing a context
-patCtxt (VarPat _)  = Nothing
-patCtxt (ParPat _)  = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat 	    = Just (hang (ptext (sLit "In the pattern:")) 
-                         2 (ppr pat))
+maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside 
+  | not (worth_wrapping pat) = tcm thing_inside
+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+    			       -- Remember to pop before doing thing_inside
+  where
+   worth_wrapping (VarPat {}) = False
+   worth_wrapping (ParPat {}) = False
+   worth_wrapping (AsPat {})  = False
+   worth_wrapping _  	      = True
+   msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
 
 -----------------------------------------------
 checkExistentials :: [TyVar] -> PatEnv -> TcM ()
@@ -1047,9 +1046,6 @@ polyPatSig sig_ty
   = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
        2 (ppr sig_ty)
 
-badTypePat :: Pat Name -> SDoc
-badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
-
 lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
 lazyUnliftedPatErr pat
   = failWithTc $
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 23c2e67..5aa6959 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -65,7 +65,6 @@ import Name
 import NameEnv
 import NameSet
 import TyCon
-import TysPrim
 import SrcLoc
 import HscTypes
 import ListSetOps
@@ -246,7 +245,6 @@ tcRnImports hsc_env this_mod import_decls
 		-- interfaces, so that their rules and instance decls will be
 		-- found.
 	; loadOrphanModules (imp_orphs  imports) False
-	; loadOrphanModules (imp_finsts imports) True 
 
 		-- Check type-familily consistency
 	; traceRn (text "rn1: checking family instance consistency")
@@ -300,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 	-- any mutually recursive types are done right
 	-- Just discard the auxiliary bindings; they are generated 
 	-- only for Haskell source code, and should already be in Core
-   (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+   (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
 
    setGblEnv tcg_env $ do {
 	-- Make the new type env available to stuff slurped from interface files
@@ -501,10 +499,9 @@ tcRnHsBootDecls decls
 
 		-- Typecheck type/class decls
 	; traceTc "Tc2" empty
-	; (tcg_env, aux_binds, dm_ids) 
+	; (tcg_env, aux_binds) 
                <- tcTyAndClassDecls emptyModDetails tycl_decls
-	; setGblEnv tcg_env    $ 
-          tcExtendIdEnv dm_ids $ do {
+	; setGblEnv tcg_env    $ do {
 
 		-- Typecheck instance decls
 		-- Family instance declarations are rejected here
@@ -645,7 +642,7 @@ checkHiBootIface
     check_inst boot_inst
 	= case [dfun | inst <- local_insts, 
 		       let dfun = instanceDFunId inst,
-		       idType dfun `tcEqType` boot_inst_ty ] of
+		       idType dfun `eqType` boot_inst_ty ] of
 	    [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
                                                   , text "boot_inst"   <+> ppr boot_inst
                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
@@ -669,7 +666,7 @@ checkBootDecl :: TyThing -> TyThing -> Bool
 
 checkBootDecl (AnId id1) (AnId id2)
   = ASSERT(id1 == id2) 
-    (idType id1 `tcEqType` idType id2)
+    (idType id1 `eqType` idType id2)
 
 checkBootDecl (ATyCon tc1) (ATyCon tc2)
   = checkBootTyCon tc1 tc2
@@ -686,7 +683,7 @@ checkBootDecl (AClass c1)  (AClass c2)
 
        eqSig (id1, def_meth1) (id2, def_meth2)
          = idName id1 == idName id2 &&
-           tcEqTypeX env op_ty1 op_ty2 &&
+           eqTypeX env op_ty1 op_ty2 &&
            def_meth1 == def_meth2
          where
 	  (_, rho_ty1) = splitForAllTys (idType id1)
@@ -695,8 +692,8 @@ checkBootDecl (AClass c1)  (AClass c2)
           op_ty2 = funResultTy rho_ty2
 
        eqFD (as1,bs1) (as2,bs2) = 
-         eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
-         eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
 
        same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
     in
@@ -705,7 +702,7 @@ checkBootDecl (AClass c1)  (AClass c2)
        eqListBy eqFD clas_fds1 clas_fds2 &&
        (null sc_theta1 && null op_stuff1 && null ats1
         ||   -- Above tests for an "abstract" class
-        eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
         eqListBy eqSig op_stuff1 op_stuff2 &&
         eqListBy checkBootTyCon ats1 ats2)
 
@@ -728,7 +725,7 @@ checkBootTyCon tc1 tc2
         eqSynRhs SynFamilyTyCon SynFamilyTyCon
             = True
         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
-            = tcEqTypeX env t1 t2
+            = eqTypeX env t1 t2
         eqSynRhs _ _ = False
     in
     equalLength tvs1 tvs2 &&
@@ -737,7 +734,7 @@ checkBootTyCon tc1 tc2
   | isAlgTyCon tc1 && isAlgTyCon tc2
   = ASSERT(tc1 == tc2)
     eqKind (tyConKind tc1) (tyConKind tc2) &&
-    eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+    eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
 
   | isForeignTyCon tc1 && isForeignTyCon tc2
@@ -761,17 +758,7 @@ checkBootTyCon tc1 tc2
           && dataConIsInfix c1 == dataConIsInfix c2
           && dataConStrictMarks c1 == dataConStrictMarks c2
           && dataConFieldLabels c1 == dataConFieldLabels c2
-          && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
-                 tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
-                 env = rnBndrs2 env0 tvs1 tvs2
-             in
-              equalLength tvs1 tvs2 &&              
-              eqListBy (tcEqPredX env)
-                        (dataConEqTheta c1 ++ dataConDictTheta c1)
-                        (dataConEqTheta c2 ++ dataConDictTheta c2) &&
-              eqListBy (tcEqTypeX env)
-                        (dataConOrigArgTys c1)
-                        (dataConOrigArgTys c2)
+          && eqType (dataConUserType c1) (dataConUserType c2)
 
 ----------------
 missingBootThing :: Name -> String -> SDoc
@@ -848,11 +835,10 @@ tcTopSrcDecls boot_details
 		-- The latter come in via tycl_decls
         traceTc "Tc2" empty ;
 
-	(tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
+	(tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
 		-- If there are any errors, tcTyAndClassDecls fails here
 	
-	setGblEnv tcg_env	$
-        tcExtendIdEnv dm_ids    $ do {
+	setGblEnv tcg_env	$ do {
 
 		-- Source-language instances, including derivings,
 		-- and import the supporting declarations
@@ -886,6 +872,7 @@ tcTopSrcDecls boot_details
         setLclTypeEnv tcl_env $ do {	-- Environment doesn't change now
 
                 -- Second pass over class and instance declarations, 
+                -- now using the kind-checked decls
         traceTc "Tc6" empty ;
         inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
 
@@ -1205,7 +1192,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
 
 --------------------
 mkPlan :: LStmt Name -> TcM PlanResult
-mkPlan (L loc (ExprStmt expr _ _))	-- An expression typed at the prompt 
+mkPlan (L loc (ExprStmt expr _ _ _))	-- An expression typed at the prompt 
   = do	{ uniq <- newUnique		-- is treated very specially
 	; let fresh_it  = itName uniq
 	      the_bind  = L loc $ mkFunBind (L loc fresh_it) matches
@@ -1214,7 +1201,7 @@ mkPlan (L loc (ExprStmt expr _ _))	-- An expression typed at the prompt
 	      bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
 					   (HsVar bindIOName) noSyntaxExpr 
 	      print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
-			          	   (HsVar thenIOName) placeHolderType
+			          	   (HsVar thenIOName) noSyntaxExpr placeHolderType
 
 	-- The plans are:
 	--	[it <- e; print it]	but not if it::()
@@ -1242,7 +1229,7 @@ mkPlan (L loc (ExprStmt expr _ _))	-- An expression typed at the prompt
 mkPlan stmt@(L loc (BindStmt {}))
   | [v] <- collectLStmtBinders stmt		-- One binder, for a bind stmt 
   = do	{ let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
-			          	   (HsVar thenIOName) placeHolderType
+			          	  (HsVar thenIOName) noSyntaxExpr placeHolderType
 
 	; print_bind_result <- doptM Opt_PrintBindResult
 	; let print_plan = do
@@ -1269,11 +1256,25 @@ tcGhciStmts stmts
 	let {
 	    ret_ty    = mkListTy unitTy ;
 	    io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
-	    tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
-
+	    tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
 	    names = collectLStmtsBinders stmts ;
+	 } ;
+
+	-- OK, we're ready to typecheck the stmts
+	traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+	((tc_stmts, ids), lie) <- captureConstraints $ 
+                                  tc_io_stmts stmts  $ \ _ ->
+                           	  mapM tcLookupId names  ;
+			-- Look up the names right in the middle,
+			-- where they will all be in scope
+
+	-- Simplify the context
+	traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+	const_binds <- checkNoErrs (simplifyInteractive lie) ;
+		-- checkNoErrs ensures that the plan fails if context redn fails
 
-		-- mk_return builds the expression
+	traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+        let {   -- mk_return builds the expression
 		--	returnIO @ [()] [coerce () x, ..,  coerce () z]
 		--
 		-- Despite the inconvenience of building the type applications etc,
@@ -1284,27 +1285,14 @@ tcGhciStmts stmts
 		-- then the type checker would instantiate x..z, and we wouldn't
 		-- get their *polymorphic* values.  (And we'd get ambiguity errs
 		-- if they were overloaded, since they aren't applied to anything.)
-	    mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
-			 	    (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+	    ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
+		       (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
 	    mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
-		    	         (nlHsVar id) 
-	 } ;
-
-	-- OK, we're ready to typecheck the stmts
-	traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
-	((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
-					   mapM tcLookupId names ;
-					-- Look up the names right in the middle,
-					-- where they will all be in scope
-
-	-- Simplify the context
-	traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
-	const_binds <- checkNoErrs (simplifyInteractive lie) ;
-		-- checkNoErrs ensures that the plan fails if context redn fails
-
-	traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+		    	         (nlHsVar id) ;
+	    stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+        } ;
 	return (ids, mkHsDictLet (EvBinds const_binds) $
-		     noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
+		     noLoc (HsDo GhciStmt stmts io_ret_ty))
     }
 \end{code}
 
@@ -1325,16 +1313,13 @@ tcRnExpr hsc_env ictxt rdr_expr
 
 	-- Now typecheck the expression; 
 	-- it might have a rank-2 type (e.g. :t runST)
-
     uniq <- newUnique ;
     let { fresh_it  = itName uniq } ;
-    ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
-    ((qtvs, dicts, _), lie_top) <- captureConstraints $
-                                   simplifyInfer TopLevel
-                                                 False {- No MR for now -}
+    ((_tc_expr, res_ty), lie)	<- captureConstraints (tcInferRho rn_expr) ;
+    ((qtvs, dicts, _), lie_top) <- captureConstraints $ 
+                                   simplifyInfer TopLevel False {- No MR for now -}
                                                  [(fresh_it, res_ty)]
                                                  lie  ;
-
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
@@ -1399,7 +1384,6 @@ tcGetModuleExports mod directlyImpMods
   		-- Load any orphan-module and family instance-module
   		-- interfaces, so their instances are visible.
        ; loadOrphanModules (dep_orphs (mi_deps iface)) False 
-       ; loadOrphanModules (dep_finsts (mi_deps iface)) True
 
                 -- Check that the family instances of all directly loaded
                 -- modules are consistent.
@@ -1586,7 +1570,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
          , ppr_fam_insts fam_insts
          , vcat (map ppr rules)
          , vcat (map ppr vects)
-         , ppr_gen_tycons (typeEnvTyCons type_env)
          , ptext (sLit "Dependent modules:") <+> 
                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
 	 , ptext (sLit "Dependent packages:") <+> 
@@ -1621,7 +1604,10 @@ ppr_types insts type_env
 
 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
 ppr_tycons fam_insts type_env
-  = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+  = vcat [ text "TYPE CONSTRUCTORS"
+         ,   nest 2 (ppr_tydecls tycons)
+         , text "COERCION AXIOMS" 
+         ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
   where
     fi_tycons = map famInstTyCon fam_insts
     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
@@ -1653,22 +1639,11 @@ ppr_tydecls tycons
   = vcat (map ppr_tycon (sortLe le_sig tycons))
   where
     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
-    ppr_tycon tycon 
-      | isCoercionTyCon tycon 
-      = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
-            , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
-      | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
-      where
-        tvs = take (tyConArity tycon) alphaTyVars
+    ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
 
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty
 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
 		      nest 2 (pprRules rs),
 		      ptext (sLit "#-}")]
-
-ppr_gen_tycons :: [TyCon] -> SDoc
-ppr_gen_tycons []  = empty
-ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
-			   nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
 \end{code}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index deefe93..c86b081 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -407,7 +407,6 @@ traceRn, traceSplice :: SDoc -> TcRn ()
 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 traceSplice  = traceOptTcRn Opt_D_dump_splices
 
-
 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
@@ -782,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
 			   env { tcl_ctxt = upd ctxt })
 
--- Conditionally add an error context
-maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
-maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
-maybeAddErrCtxt Nothing    thing_inside = thing_inside
-
 popErrCtxt :: TcM a -> TcM a
 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 
@@ -898,6 +892,9 @@ add_err_tcm tidy_env err_msg loc ctxt
 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 -- Tidy the error info, trimming excessive contexts
 mkErrInfo env ctxts
+ | opt_PprStyle_Debug     -- In -dppr-debug style the output 
+ = return empty	          -- just becomes too voluminous
+ | otherwise
  = go 0 env ctxts
  where
    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
@@ -1153,7 +1150,7 @@ failIfM :: Message -> IfL a
 failIfM msg
   = do 	{ env <- getLclEnv
 	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-	; liftIO (printErrs (full_msg defaultErrStyle))
+	; liftIO (printErrs full_msg defaultErrStyle)
 	; failM }
 
 --------------------
@@ -1188,7 +1185,7 @@ forkM_maybe doc thing_inside
 	  	    ; return Nothing }
 	}}
   where
-    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+    print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
 
 forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 79f2a74..d94ecd7 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -40,11 +40,13 @@ module TcRnTypes(
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
 	CtOrigin(..), EqOrigin(..), 
-        WantedLoc, GivenLoc, pushErrCtxt,
+        WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
 
-        SkolemInfo(..),
+	SkolemInfo(..),
 
-        CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+        CtFlavor(..), pprFlavorArising, isWanted, 
+        isGivenOrSolved, isGiven_maybe,
+        isDerived,
         FlavoredEvVar,
 
 	-- Pretty printing
@@ -62,6 +64,7 @@ module TcRnTypes(
 import HsSyn
 import HscTypes
 import Type
+import Id	( evVarPred )
 import Class    ( Class )
 import DataCon  ( DataCon, dataConUserType )
 import TcType
@@ -324,6 +327,7 @@ data IfLclEnv
 		-- plus which bit is currently being examined
 
 	if_tv_env  :: UniqFM TyVar,	-- Nested tyvar bindings
+		      	     		-- (and coercions)
 	if_id_env  :: UniqFM Id		-- Nested id binding
     }
 \end{code}
@@ -643,7 +647,7 @@ plusImportAvails
   (ImportAvails { imp_mods = mods2,
 		  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                   imp_orphs = orphs2, imp_finsts = finsts2 })
-  = ImportAvails { imp_mods     = plusModuleEnv_C (++) mods1 mods2,	
+  = ImportAvails { imp_mods     = plusModuleEnv_C (++) mods1 mods2,
 		   imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,	
 		   imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
 		   imp_orphs    = orphs1 `unionLists` orphs2,
@@ -678,7 +682,6 @@ instance Outputable WhereFrom where
 %************************************************************************
 %*									*
 		Wanted constraints
-
      These are forced to be in TcRnTypes because
      	   TcLclEnv mentions WantedConstraints
 	   WantedConstraint mentions CtLoc
@@ -905,7 +908,7 @@ pprEvVarTheta :: [EvVar] -> SDoc
 pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
                               
 pprEvVarWithType :: EvVar -> SDoc
-pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)
 
 pprWantedsWithLocs :: WantedConstraints -> SDoc
 pprWantedsWithLocs wcs
@@ -927,35 +930,37 @@ pprWantedEvVar        (EvVarX v _)   = pprEvVarWithType v
 
 \begin{code}
 data CtFlavor
-  = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
-  | Derived WantedLoc 
-                      -- We have evidence for this constraint in TcEvBinds;
-                      --   *however* this evidence can contain wanteds, so 
-                      --   it's valid only provisionally to the solution of
-                      --   these wanteds 
-  | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses. 
+  = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+  | Derived WantedLoc        -- Derived's are just hints for unifications 
+  | Wanted WantedLoc         -- We have no evidence bindings for this constraint. 
+
+data GivenKind
+  = GivenOrig   -- Originates in some given, such as signature or pattern match
+  | GivenSolved -- Is given as result of being solved, maybe provisionally on
+                -- some other wanted constraints. 
 
 instance Outputable CtFlavor where
-  ppr (Given {})   = ptext (sLit "[G]")
-  ppr (Wanted {})  = ptext (sLit "[W]")
-  ppr (Derived {}) = ptext (sLit "[D]") 
+  ppr (Given _ GivenOrig)   = ptext (sLit "[G]")
+  ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+  ppr (Wanted {})           = ptext (sLit "[W]")
+  ppr (Derived {})          = ptext (sLit "[D]") 
+
 pprFlavorArising :: CtFlavor -> SDoc
-pprFlavorArising (Derived wl )  = pprArisingAt wl
+pprFlavorArising (Derived wl)   = pprArisingAt wl
 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
-pprFlavorArising (Given gl)     = pprArisingAt gl
+pprFlavorArising (Given gl _)   = pprArisingAt gl
 
 isWanted :: CtFlavor -> Bool
 isWanted (Wanted {}) = True
 isWanted _           = False
 
-isGiven :: CtFlavor -> Bool 
-isGiven (Given {}) = True 
-isGiven _          = False 
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind 
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _            = Nothing
 
 isDerived :: CtFlavor -> Bool 
 isDerived (Derived {}) = True
@@ -1116,6 +1121,7 @@ data CtOrigin
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin	-- Typechecking a default decl
   | DoOrigin		-- Arising from a do expression
+  | MCompOrigin         -- Arising from a monad comprehension
   | IfOrigin            -- Arising from an if statement
   | ProcOrigin		-- Arising from a proc expression
   | AnnOrigin           -- An annotation
@@ -1151,6 +1157,7 @@ pprO DerivOrigin	   = ptext (sLit "the 'deriving' clause of a data type declarat
 pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin	   = ptext (sLit "a 'default' declaration")
 pprO DoOrigin	           = ptext (sLit "a do statement")
+pprO MCompOrigin           = ptext (sLit "a statement in a monad comprehension")
 pprO ProcOrigin	           = ptext (sLit "a proc expression")
 pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
 pprO AnnOrigin             = ptext (sLit "an annotation")
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index b2c1dac..3925c6d 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -17,7 +17,6 @@ import TcHsType
 import TcExpr
 import TcEnv
 import Id
-import Var	( Var )
 import Name
 import VarSet
 import SrcLoc
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 647f22f..0992fb9 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -15,13 +15,15 @@ module TcSMonad (
     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
     deCanonicalise, mkFrozenError,
 
-    isWanted, isGiven, isDerived,
-    isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
+    isWanted, isGivenOrSolved, isDerived,
+    isGivenOrSolvedCt, isGivenCt_maybe, 
+    isWantedCt, isDerivedCt, pprFlavorArising,
 
     isFlexiTcsTv,
 
     canRewrite, canSolve,
-    combineCtLoc, mkGivenFlavor, mkWantedFlavor,
+    combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+    mkWantedFlavor,
     getWantedLoc,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
@@ -39,6 +41,8 @@ module TcSMonad (
 
     setWantedTyBind,
 
+    lookupFlatCacheMap, updateFlatCacheMap,
+
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
     getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
@@ -82,6 +86,7 @@ import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM 
        ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
+import Kind
 import TcType
 import DynFlags
 
@@ -97,16 +102,20 @@ import Outputable
 import Bag
 import MonadUtils
 import VarSet
+import Pair
 import FastString
 
 import HsBinds               -- for TcEvBinds stuff 
 import Id 
-
 import TcRnTypes
+import Data.IORef
+
+import qualified Data.Map as Map
+
 #ifdef DEBUG
+import StaticFlags( opt_PprStyle_Debug )
 import Control.Monad( when )
 #endif
-import Data.IORef
 \end{code}
 
 
@@ -206,9 +215,9 @@ instance Outputable CanonicalCt where
   ppr (CIPCan ip fl ip_nm ty)     
       = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
   ppr (CTyEqCan co fl tv ty)      
-      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty)
   ppr (CFunEqCan co fl tc tys ty) 
-      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty)
   ppr (CFrozenErr co fl)
       = ppr fl <+> pprEvVarWithType co
 \end{code}
@@ -332,11 +341,16 @@ getWantedLoc ct
 
 isWantedCt :: CanonicalCt -> Bool
 isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool
-isGivenCt ct = isGiven (cc_flavor ct)
 isDerivedCt :: CanonicalCt -> Bool
 isDerivedCt ct = isDerived (cc_flavor ct)
 
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
+
 canSolve :: CtFlavor -> CtFlavor -> Bool 
 -- canSolve ctid1 ctid2 
 -- The constraint ctid1 can be used to solve ctid2 
@@ -361,22 +375,27 @@ canRewrite = canSolve
 
 combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
 -- Precondition: At least one of them should be wanted 
-combineCtLoc (Wanted loc) _    = loc 
-combineCtLoc _ (Wanted loc)    = loc 
-combineCtLoc (Derived loc ) _  = loc 
-combineCtLoc _ (Derived loc )  = loc 
+combineCtLoc (Wanted loc) _    = loc
+combineCtLoc _ (Wanted loc)    = loc
+combineCtLoc (Derived loc ) _  = loc
+combineCtLoc _ (Derived loc )  = loc
 combineCtLoc _ _ = panic "combineCtLoc: both given"
 
-mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given   loc) sk  = Given (setCtLocOrigin loc sk)
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
+mkSolvedFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
 
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
 
 mkWantedFlavor :: CtFlavor -> CtFlavor
 mkWantedFlavor (Wanted  loc) = Wanted loc
 mkWantedFlavor (Derived loc) = Wanted loc
-mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
 \end{code}
 
 %************************************************************************
@@ -411,10 +430,33 @@ data TcSEnv
                      
       tcs_untch :: TcsUntouchables,
 
-      tcs_ic_depth :: Int,	-- Implication nesting depth
-      tcs_count    :: IORef Int	-- Global step count
+      tcs_ic_depth   :: Int,       -- Implication nesting depth
+      tcs_count      :: IORef Int, -- Global step count
+
+      tcs_flat_map   :: IORef FlatCache
     }
 
+data FlatCache 
+  = FlatCache { givenFlatCache  :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+                -- Invariant: all CtFlavors here satisfy isGiven
+              , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+                -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache 
+ = FlatCache { givenFlatCache  = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+  FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+  FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) 
+    = case compare tc1 tc2 of 
+        EQ    -> cmpTypes xis1 xis2
+        other -> other
+
 type TcsUntouchables = (Untouchables,TcTyVarSet)
 -- Like the TcM Untouchables, 
 -- but records extra TcsTv variables generated during simplification
@@ -511,12 +553,14 @@ runTcS context untouch tcs
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
        ; step_count <- TcM.newTcRef 0
+       ; flat_cache_var <- TcM.newTcRef emptyFlatCache
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
                           , tcs_context  = context
                           , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
 			  , tcs_count    = step_count
 			  , tcs_ic_depth = 0
+                          , tcs_flat_map = flat_cache_var
                           }
 
 	     -- Run the computation
@@ -527,7 +571,7 @@ runTcS context untouch tcs
 
 #ifdef DEBUG
        ; count <- TcM.readTcRef step_count
-       ; when (count > 0) $
+       ; when (opt_PprStyle_Debug && count > 0) $
          TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") 
                             <+> int count <+> ppr context)
 #endif
@@ -543,21 +587,31 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
     	    	   , tcs_untch = (_outer_range, outer_tcs)
 		   , tcs_count = count
 		   , tcs_ic_depth = idepth
-                   , tcs_context = ctxt } ->
-    let 
-       inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+                   , tcs_context = ctxt 
+                   , tcs_flat_map = orig_flat_cache_var
+                   } ->
+    do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
        		   -- The inner_range should be narrower than the outer one
 		   -- (thus increasing the set of untouchables) but 
 		   -- the inner Tcs-untouchables must be unioned with the
 		   -- outer ones!
-       nest_env = TcSEnv { tcs_ev_binds = ref
-                         , tcs_ty_binds = ty_binds
-                         , tcs_untch    = inner_untch
-                         , tcs_count    = count
-                         , tcs_ic_depth = idepth+1
-                         , tcs_context  = ctxtUnderImplic ctxt }
-    in 
-    thing_inside nest_env
+
+       ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+       ; flat_cache_var  <- TcM.newTcRef orig_flat_cache
+       -- One could be more conservative as well: 
+       -- ; flat_cache_var  <- TcM.newTcRef emptyFlatCache 
+
+                            -- Consider copying the results the tcs_flat_map of the 
+                            -- incomping constraint, but we must make sure that we
+                            -- have pushed everything in, which seems somewhat fragile
+       ; let nest_env = TcSEnv { tcs_ev_binds = ref
+                               , tcs_ty_binds = ty_binds
+                               , tcs_untch    = inner_untch
+                               , tcs_count    = count
+                               , tcs_ic_depth = idepth+1
+                               , tcs_context  = ctxtUnderImplic ctxt 
+                               , tcs_flat_map = flat_cache_var }
+       ; thing_inside nest_env }
 
 recoverTcS :: TcS a -> TcS a -> TcS a
 recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -571,14 +625,16 @@ ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule")
 ctxtUnderImplic ctxt              = ctxt
 
 tryTcS :: TcS a -> TcS a
--- Like runTcS, but from within the TcS monad 
+-- Like runTcS, but from within the TcS monad
 -- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs 
+tryTcS tcs
   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
                     ; ev_binds_var <- TcM.newTcEvBinds
+                    ; flat_cache_var <- TcM.newTcRef emptyFlatCache
                     ; let env1 = env { tcs_ev_binds = ev_binds_var
-                                     , tcs_ty_binds = ty_binds_var }
-                    ; unTcS tcs env1 })
+                                     , tcs_ty_binds = ty_binds_var
+                                     , tcs_flat_map = flat_cache_var }
+                   ; unTcS tcs env1 })
 
 -- Update TcEvBinds 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -601,12 +657,51 @@ getTcSTyBinds = TcS (return . tcs_ty_binds)
 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
 
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+  = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor 
+                   -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+           Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+           other   -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+                   -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+  = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; let new_cache_map
+              | isGivenOrSolved fl
+              = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                             givenFlatCache cache_map }
+              | isWanted fl
+              = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                              wantedFlatCache cache_map }
+              | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+       ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
 
 getTcEvBindsBag :: TcS EvBindMap
 getTcEvBindsBag
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
        ; wrapTcS $ TcM.readTcRef ev_ref }
 
+
 setCoBind :: CoVar -> Coercion -> TcS () 
 setCoBind cv co = setEvBind cv (EvCoercion co)
 
@@ -676,7 +771,7 @@ checkWellStagedDFun pred dfun_id loc
     bind_lvl = TcM.topIdLvl dfun_id
 
 pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
+pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2)
 
 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
 isTouchableMetaTyVar tv 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index cf41372..bed0932 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1,7 +1,7 @@
 \begin{code}
 module TcSimplify( 
        simplifyInfer,
-       simplifyDefault, simplifyDeriv,
+       simplifyDefault, simplifyDeriv, 
        simplifyRule, simplifyTop, simplifyInteractive
   ) where
 
@@ -15,10 +15,12 @@ import TcType
 import TcSMonad 
 import TcInteract
 import Inst
-import Unify( niFixTvSubst, niSubstTvSet )
+import Id	( evVarPred )
+import Unify	( niFixTvSubst, niSubstTvSet )
 import Var
 import VarSet
 import VarEnv 
+import Coercion
 import TypeRep
 
 import Name
@@ -747,22 +749,26 @@ solve_wanteds inert wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol =
                                   unsolved_implics
            }
 
-givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar
--- Extract the *wanted* ones from CanonicalCts
--- and make them into *givens*
-givensFromWanteds = foldrBag getWanted emptyBag
+givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
+-- Extract the Wanted ones from CanonicalCts and conver to
+-- Givens; not Given/Solved, see Note [Preparing inert set for implications]
+givensFromWanteds _ctxt = foldrBag getWanted emptyBag
   where
     getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
     getWanted cc givens
-      | not (isCFrozenErr cc)
-      , Wanted loc <- cc_flavor cc 
-      , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol))
-      = given `consBag` givens
-      | otherwise 
-      = givens   -- We are not helping anyone by pushing a Derived in!
-                 -- Because if we could not solve it to start with 
-                 -- we are not going to do either inside the impl constraint
-  
+      | pushable_wanted cc
+      = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
+        in given `consBag` givens     -- and not mkSolvedFlavor,
+                                      -- see Note [Preparing inert set for implications]
+      | otherwise = givens
+
+    pushable_wanted :: CanonicalCt -> Bool 
+    pushable_wanted cc 
+      | not (isCFrozenErr cc) 
+      , isWantedCt cc 
+      = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+      | otherwise = False 
+ 
 solveNestedImplications :: InertSet -> CanonicalCts
                         -> Bag Implication
                         -> TcS (Bag FlavoredEvVar, Bag Implication)
@@ -772,15 +778,18 @@ solveNestedImplications just_given_inert unsolved_cans implics
   | otherwise 
   = do {  -- See Note [Preparing inert set for implications]
 	  -- Push the unsolved wanteds inwards, but as givens
-         let pushed_givens    = givensFromWanteds unsolved_cans
+             
+       ; simpl_ctx <- getTcSContext 
+
+       ; let pushed_givens    = givensFromWanteds simpl_ctx unsolved_cans
              tcs_untouchables = filterVarSet isFlexiTcsTv $
                                 tyVarsOfEvVarXs pushed_givens
              -- See Note [Extra TcsTv untouchables]
 
        ; traceTcS "solveWanteds: preparing inerts for implications {"  
                   (vcat [ppr tcs_untouchables, ppr pushed_givens])
-     
-       ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
+
+       ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens 
 
        ; traceTcS "solveWanteds: } now doing nested implications {" $
          vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
@@ -931,6 +940,42 @@ We were not able to solve (a ~w [beta]) but we can't just assume it as
 given because the resulting set is not inert. Hence we have to do a
 'solveInteract' step first. 
 
+Finally, note that we convert them to [Given] and NOT [Given/Solved].
+The reason is that Given/Solved are weaker than Givens and may be discarded.
+As an example consider the inference case, where we may have, the following 
+original constraints: 
+     [Wanted] F Int ~ Int
+             (F Int ~ a => F Int ~ a)
+If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next 
+given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting 
+the (F Int ~ a) insoluble. Hence we should really convert the residual 
+wanteds to plain old Given. 
+
+We need only push in unsolved equalities both in checking mode and inference mode: 
+
+  (1) In checking mode we should not push given dictionaries in because of
+example LongWayOverlapping.hs, where we might get strange overlap
+errors between far-away constraints in the program.  But even in
+checking mode, we must still push type family equations. Consider:
+
+   type instance F True a b = a 
+   type instance F False a b = b
+
+   [w] F c a b ~ gamma 
+   (c ~ True) => a ~ gamma 
+   (c ~ False) => b ~ gamma
+
+Since solveCTyFunEqs happens at the very end of solving, the only way to solve
+the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not 
+merely Given/Solved because it has to interact with the top-level instance 
+environment) and push it inside the implications. Now, when we come out again at
+the end, having solved the implications solveCTyFunEqs will solve this equality.
+
+  (2) In inference mode, we recheck the final constraint in checking mode and
+hence we will be able to solve inner implications from top-level quantified
+constraints nonetheless.
+
+
 Note [Extra TcsTv untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Furthemore, we record the inert set simplifier-generated unification
@@ -986,7 +1031,8 @@ solveCTyFunEqs cts
 
       ; return (niFixTvSubst ni_subst, unsolved_can_cts) }
   where
-    solve_one (cv,tv,ty) = setWantedTyBind tv ty >> setCoBind cv ty
+    solve_one (cv,tv,ty) = do { setWantedTyBind tv ty
+                              ; setCoBind cv (mkReflCo ty) }
 
 ------------
 type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)])
@@ -1029,7 +1075,7 @@ getSolvableCTyFunEqs untch cts
 
       , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
            -- Occurs check: see Note [Solving Family Equations], Point 2
-      = ASSERT ( not (isGiven fl) )
+      = ASSERT ( not (isGivenOrSolved fl) )
         (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
 
     dflt_funeq (cts_in, fun_eq_binds) ct
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f68239e..3cc2eb5 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -71,6 +71,7 @@ import SrcLoc
 import Outputable
 import Util		( dropList )
 import Data.List	( mapAccumL )
+import Pair
 import Unique
 import Data.Maybe
 import BasicTypes
@@ -1066,8 +1067,9 @@ reifyThing (AGlobal (AnId id))
 	    _             -> return (TH.VarI     v ty Nothing fix)
     }
 
-reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls))  = reifyClass cls
 reifyThing (AGlobal (ADataCon dc))
   = do	{ let name = dataConName dc
 	; ty <- reifyType (idType (dataConWrapId dc))
@@ -1091,12 +1093,24 @@ reifyThing (ATyVar tv ty)
 reifyThing (AThing {}) = panic "reifyThing AThing"
 
 ------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+  | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+  = do { args' <- mapM reifyType args
+       ; rhs'  <- reifyType rhs
+       ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+  | otherwise
+  = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax 
+              <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
 reifyTyCon :: TyCon -> TcM TH.Info
 reifyTyCon tc
   | isFunTyCon tc  
   = return (TH.PrimTyConI (reifyName tc) 2 		  False)
+
   | isPrimTyCon tc 
   = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+
   | isFamilyTyCon tc
   = let flavour = reifyFamFlavour tc
         tvs     = tyConTyVars tc
@@ -1107,6 +1121,7 @@ reifyTyCon tc
     in
     return (TH.TyConI $
               TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
@@ -1114,7 +1129,7 @@ reifyTyCon tc
 		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
        }
 
-reifyTyCon tc
+  | otherwise
   = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
 	; let tvs = tyConTyVars tc
 	; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
@@ -1189,7 +1204,7 @@ reifyClassInstance i
 reifyType :: TypeRep.Type -> TcM TH.Type
 -- Monadic only because of failure
 reifyType ty@(ForAllTy _ _)        = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty	        -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
 reifyType (TyVarTy tv)	    = return (TH.VarT (reifyName tv))
 reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
 reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a433d69..8d62b78 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -7,7 +7,8 @@ TcTyClsDecls: Typecheck type and class declarations
 
 \begin{code}
 module TcTyClsDecls (
-	tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
+	tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
+        checkValidTyCon, dataDeclChecks, badFamInstDecl
     ) where
 
 #include "HsVersions.h"
@@ -25,17 +26,16 @@ import TcMType
 import TcType
 import TysWiredIn	( unitTy )
 import Type
-import Generics
 import Class
 import TyCon
 import DataCon
 import Id
-import MkId		( mkDefaultMethodId )
 import MkCore		( rEC_SEL_ERROR_ID )
 import IdInfo
 import Var
 import VarSet
 import Name
+import NameEnv
 import Outputable
 import Maybes
 import Unify
@@ -61,12 +61,12 @@ import Data.List
 %************************************************************************
 
 \begin{code}
+
 tcTyAndClassDecls :: ModDetails 
                    -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
    	           -> TcM (TcGblEnv,   	     -- Input env extended by types and classes 
 					     -- and their implicit Ids,DataCons
-		           HsValBinds Name,  -- Renamed bindings for record selectors
-			   [Id])      	     -- Default method ids
+		           HsValBinds Name)  -- Renamed bindings for record selectors
 -- Fails if there are any errors
 
 tcTyAndClassDecls boot_details decls_s
@@ -89,7 +89,7 @@ tcTyAndClassDecls boot_details decls_s
 
                       -- And now build the TyCons/Classes
                 ; let rec_flags = calcRecFlags boot_details rec_tyclss
-                 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+                ; concatMapM (tcTyClDecl rec_flags) kc_decls }
 
        ; tcExtendGlobalEnv tyclss $ do
        {  -- Perform the validity check
@@ -105,11 +105,13 @@ tcTyAndClassDecls boot_details decls_s
 	--     second time here.  This doesn't matter as the definitions are
 	--     the same.
 	; let {	implicit_things = concatMap implicitTyThings tyclss
-	      ; rec_sel_binds   = mkRecSelBinds tyclss
+	      ; rec_sel_binds   = mkRecSelBinds [tc | ATyCon tc <- tyclss]
               ; dm_ids          = mkDefaultMethodIds tyclss }
 
-  	; env <- tcExtendGlobalEnv implicit_things getGblEnv
-	; return (env, rec_sel_binds, dm_ids) } }
+  	; env <- tcExtendGlobalEnv implicit_things $
+                 tcExtendGlobalValEnv dm_ids $
+                 getGblEnv
+        ; return (env, rec_sel_binds) } }
                     
 zipRecTyClss :: [[LTyClDecl Name]]
              -> [TyThing]           -- Knot-tied
@@ -137,188 +139,6 @@ zipRecTyClss decls_s rec_things
 
 %************************************************************************
 %*									*
-               Type checking family instances
-%*									*
-%************************************************************************
-
-Family instances are somewhat of a hybrid.  They are processed together with
-class instance heads, but can contain data constructors and hence they share a
-lot of kinding and type checking code with ordinary algebraic data types (and
-GADTs).
-
-\begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
-tcFamInstDecl top_lvl (L loc decl)
-  =	-- Prime error recovery, set source location
-    setSrcSpan loc				$
-    tcAddDeclCtxt decl				$
-    do { -- type family instances require -XTypeFamilies
-	 -- and can't (currently) be in an hs-boot file
-       ; type_families <- xoptM Opt_TypeFamilies
-       ; is_boot  <- tcIsHsBoot	  -- Are we compiling an hs-boot file?
-       ; checkTc type_families $ badFamInstDecl (tcdLName decl)
-       ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
-	 -- Perform kind and type checking
-       ; tc <- tcFamInstDecl1 decl
-       ; checkValidTyCon tc	-- Remember to check validity;
-				-- no recursion to worry about here
-
-       -- Check that toplevel type instances are not for associated types.
-       ; when (isTopLevel top_lvl && isAssocFamily tc)
-              (addErr $ assocInClassErr (tcdName decl))
-
-       ; return (ATyCon tc) }
-
-isAssocFamily :: TyCon -> Bool	-- Is an assocaited type
-isAssocFamily tycon
-  = case tyConFamInst_maybe tycon of
-          Nothing       -> panic "isAssocFamily: no family?!?"
-          Just (fam, _) -> isTyConAssoc fam
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name
- = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
-   ptext (sLit "must be inside a class instance")
-
-
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
-
-  -- "type instance"
-tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
-    do { -- check that the family declaration is for a synonym
-         checkTc (isFamilyTyCon family) (notFamily family)
-       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
-
-       ; -- (1) kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
-       	       	  -- ToDo: the ExpKind could be better
-
-         -- we need the exact same number of type parameters as the family
-         -- declaration 
-       ; let famArity = tyConArity family
-       ; checkTc (length k_typats == famArity) $ 
-           wrongNumberOfParmsErr famArity
-
-         -- (2) type check type equation
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
-       ; t_typats <- mapM tcHsKindedType k_typats
-       ; t_rhs    <- tcHsKindedType k_rhs
-
-         -- (3) check the well-formedness of the instance
-       ; checkValidTypeInst t_typats t_rhs
-
-         -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
-       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
-                       (typeKind t_rhs) 
-                       NoParentTyCon (Just (family, t_typats))
-       }}
-
-  -- "newtype instance" and "data instance"
-tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
-			     tcdCons = cons})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
-    do { -- check that the family declaration is for the right kind
-         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
-       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
-
-       ; -- (1) kind check the data declaration as usual
-       ; k_decl <- kcDataDecl decl k_tvs
-       ; let k_ctxt = tcdCtxt k_decl
-	     k_cons = tcdCons k_decl
-
-         -- result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
-
-         -- (2) type check indexed data type declaration
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
-       ; unbox_strict <- doptM Opt_UnboxStrictFields
-
-         -- kind check the type indexes and the context
-       ; t_typats     <- mapM tcHsKindedType k_typats
-       ; stupid_theta <- tcHsKindedContext k_ctxt
-
-         -- (3) Check that
-         --     (a) left-hand side contains no type family applications
-         --         (vanilla synonyms are fine, though, and we checked for
-         --         foralls earlier)
-       ; mapM_ checkTyFamFreeness t_typats
-
-	 -- Check that we don't use GADT syntax in H98 world
-       ; gadt_ok <- xoptM Opt_GADTs
-       ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-
-	 --     (b) a newtype has exactly one constructor
-       ; checkTc (new_or_data == DataType || isSingleton k_cons) $
-	         newtypeConError tc_name (length k_cons)
-
-         -- (4) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
-       ; let ex_ok = True	-- Existentials ok for type families!
-       ; fixM (\ rep_tycon -> do 
-	     { let orig_res_ty = mkTyConApp fam_tycon t_typats
-	     ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
-				       (t_tvs, orig_res_ty) k_cons
-	     ; tc_rhs <-
-		 case new_or_data of
-		   DataType -> return (mkDataTyConRhs data_cons)
-		   NewType  -> ASSERT( not (null data_cons) )
-			       mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
-	     ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-			     False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
-                 -- We always assume that indexed types are recursive.  Why?
-                 -- (1) Due to their open nature, we can never be sure that a
-                 -- further instance might not introduce a new recursive
-                 -- dependency.  (2) They are always valid loop breakers as
-                 -- they involve a coercion.
-	     })
-       }}
-       where
-	 h98_syntax = case cons of 	-- All constructors have same shape
-			L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
-			_ -> True
-
-tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
-
--- Kind checking of indexed types
--- -
-
--- Kind check type patterns and kind annotate the embedded type variables.
---
--- * Here we check that a type instance matches its kind signature, but we do
---   not check whether there is a pattern for each type index; the latter
---   check is only required for type synonym instances.
-
-kcIdxTyPats :: TyClDecl Name
-	    -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
-	       -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
-	    -> TcM a
-kcIdxTyPats decl thing_inside
-  = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
-    do { let tc_name = tcdLName decl
-       ; fam_tycon <- tcLookupLocatedTyCon tc_name
-       ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
-	     ; hs_typats	= fromJust $ tcdTyPats decl }
-
-         -- we may not have more parameters than the kind indicates
-       ; checkTc (length kinds >= length hs_typats) $
-	   tooManyParmsErr (tcdLName decl)
-
-         -- type functions can have a higher-kinded result
-       ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
-       ; typats <- zipWithM kcCheckLHsType hs_typats 
-       	 	   	    [ EK kind (EkArg (ppr tc_name) n) 
-                            | (kind,n) <- kinds `zip` [1..]]
-       ; thing_inside tvs typats resultKind fam_tycon
-       }
-\end{code}
-
-
-%************************************************************************
-%*									*
 		Kind checking
 %*									*
 %************************************************************************
@@ -488,6 +308,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   where
     kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
 				   ; return (TypeSig nm op_ty') }
+    kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+				      ; return (GenericSig nm op_ty') }
     kc_sig other_sig	      = return other_sig
 
 kcTyClDecl decl@(ForeignType {})
@@ -634,7 +456,7 @@ tcTyClDecl1 parent _calc_isrec
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-               DataFamilyTyCon Recursive False True 
+               DataFamilyTyCon Recursive True 
                parent Nothing
   ; return [ATyCon tycon]
   }
@@ -660,36 +482,18 @@ tcTyClDecl1 _parent calc_isrec
   { extra_tvs <- tcDataKindSig mb_ksig
   ; let final_tvs = tvs' ++ extra_tvs
   ; stupid_theta <- tcHsKindedContext ctxt
-  ; want_generic <- xoptM Opt_Generics
   ; unbox_strict <- doptM Opt_UnboxStrictFields
-  ; empty_data_decls <- xoptM Opt_EmptyDataDecls
   ; kind_signatures <- xoptM Opt_KindSignatures
   ; existential_ok <- xoptM Opt_ExistentialQuantification
   ; gadt_ok      <- xoptM Opt_GADTs
-  ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
   ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
   ; let ex_ok = existential_ok || gadt_ok	-- Data cons can have existential context
 
-	-- Check that we don't use GADT syntax in H98 world
-  ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-
 	-- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
 
-	-- Check that the stupid theta is empty for a GADT-style declaration
-  ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
-
-	-- Check that a newtype has exactly one constructor
-	-- Do this before checking for empty data decls, so that
-	-- we don't suggest -XEmptyDataDecls for newtypes
-  ; checkTc (new_or_data == DataType || isSingleton cons) 
-	    (newtypeConError tc_name (length cons))
+  ; dataDeclChecks tc_name new_or_data stupid_theta cons
 
-	-- Check that there's at least one condecl,
-	-- or else we're reading an hs-boot file, or -XEmptyDataDecls
-  ; checkTc (not (null cons) || empty_data_decls || is_boot)
-	    (emptyConDeclsErr tc_name)
-    
   ; tycon <- fixM (\ tycon -> do 
 	{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
 	; data_cons <- tcConDecls unbox_strict ex_ok 
@@ -702,8 +506,7 @@ tcTyClDecl1 _parent calc_isrec
 		   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
 	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-	    (want_generic && canDoGenerics data_cons) (not h98_syntax) 
-            NoParentTyCon Nothing
+	    (not h98_syntax) NoParentTyCon Nothing
 	})
   ; return [ATyCon tycon]
   }
@@ -719,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec
     tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mapM (addLocM tc_fundep) fundeps
-  ; sig_stuff <- tcClassSigs class_name sigs meths
+  ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
   ; clas <- fixM $ \ clas -> do
 	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
@@ -732,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec
             ; buildClass False {- Must include unfoldings for selectors -}
 			 class_name tvs' ctxt' fds' (concat atss')
 			 sig_stuff tc_isrec }
-  ; return (AClass clas : map ATyCon (classATs clas))
+
+  ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+                     | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+                     , let gen_dm_tau = expectJust "tcTyClDecl1" $
+                                        lookupNameEnv gen_dm_env (idName sel_id)
+		     , let gen_dm_ty = mkSigmaTy tvs' 
+                                                 [mkClassPred clas (mkTyVarTys tvs')] 
+                                                 gen_dm_tau
+                     ]
+        class_ats = map ATyCon (classATs clas)
+
+  ; return (AClass clas : gen_dm_ids ++ class_ats )
       -- NB: Order is important due to the call to `mkGlobalThings' when
       --     tying the the type and class declaration type checking knot.
   }
@@ -747,6 +561,29 @@ tcTyClDecl1 _ _
 
 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
 
+dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
+dataDeclChecks tc_name new_or_data stupid_theta cons
+  = do {   -- Check that we don't use GADT syntax in H98 world
+         gadtSyntax_ok <- xoptM Opt_GADTSyntax
+       ; let h98_syntax = consUseH98Syntax cons
+       ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
+
+	   -- Check that the stupid theta is empty for a GADT-style declaration
+       ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
+
+	-- Check that a newtype has exactly one constructor
+	-- Do this before checking for empty data decls, so that
+	-- we don't suggest -XEmptyDataDecls for newtypes
+      ; checkTc (new_or_data == DataType || isSingleton cons) 
+	        (newtypeConError tc_name (length cons))
+
+ 	-- Check that there's at least one condecl,
+	-- or else we're reading an hs-boot file, or -XEmptyDataDecls
+      ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+      ; is_boot <- tcIsHsBoot	-- Are we compiling an hs-boot file?
+      ; checkTc (not (null cons) || empty_data_decls || is_boot)
+                (emptyConDeclsErr tc_name) }
+    
 -----------------------------------
 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
 	   -> [LConDecl Name] -> TcM [DataCon]
@@ -974,6 +811,8 @@ checkValidTyCl decl
 	    ATyCon tc -> checkValidTyCon tc
 	    AClass cl -> do { checkValidClass cl 
                             ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+            AnId _    -> return ()  -- Generic default methods are checked
+	    	      	 	    -- with their parent class
             _         -> panic "checkValidTyCl"
 	; traceTc "Done validity of" (ppr thing)	
 	}
@@ -1099,14 +938,14 @@ checkNewDataCon con
 		-- One argument
 	; checkTc (null eq_spec) (newtypePredError con)
 		-- Return type is (T a b c)
-	; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
+	; checkTc (null ex_tvs && null theta) (newtypeExError con)
 		-- No existentials
 	; checkTc (not (any isBanged (dataConStrictMarks con))) 
 		  (newtypeStrictError con)
 		-- No strictness
     }
   where
-    (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
 
 -------------------------------
 checkValidClass :: Class -> TcM ()
@@ -1134,7 +973,7 @@ checkValidClass cls
   where
     (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
     unary 	= isSingleton tyvars
-    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+    no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
     check_op constrained_class_methods (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
@@ -1155,10 +994,10 @@ checkValidClass cls
 	; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
 	          (noClassTyVarErr cls sel_id)
 
-		-- Check that for a generic method, the type of 
-		-- the method is sufficiently simple
-	; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
-		  (badGenericMethodType op_name op_ty)
+        ; case dm of
+            GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+                                     ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+            _                  -> return ()
 	}
 	where
 	  op_name = idName sel_id
@@ -1186,7 +1025,7 @@ checkValidClass cls
 mkDefaultMethodIds :: [TyThing] -> [Id]
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds things
-  = [ mkDefaultMethodId sel_id dm_name
+  = [ mkExportedLocalId dm_name (idType sel_id)
     | AClass cls <- things
     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
 \end{code}
@@ -1208,16 +1047,16 @@ must bring the default method Ids into scope first (so they can be seen
 when typechecking the [d| .. |] quote, and typecheck them later.
 
 \begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyCon] -> HsValBinds Name
 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
 --    This makes life easier, because the later type checking will add
 --    all necessary type abstractions and applications
-mkRecSelBinds ty_things
+mkRecSelBinds tycons
   = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
   where
     (sigs, binds) = unzip rec_sels
     rec_sels = map mkRecSelBind [ (tc,fld) 
-       	 	     	        | ATyCon tc <- ty_things 
+       	 	     	        | tc <- tycons
 				, fld <- tyConFields tc ]
 
 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
@@ -1424,12 +1263,6 @@ genericMultiParamErr clas
   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> 
     ptext (sLit "cannot have generic methods")
 
-badGenericMethodType :: Name -> Kind -> SDoc
-badGenericMethodType op op_ty
-  = hang (ptext (sLit "Generic method type is too complex"))
-       2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
-		ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
-
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls
   = setSrcSpan (getLoc (head sorted_decls)) $
@@ -1511,39 +1344,6 @@ badFamInstDecl tc_name
 	   quotes (ppr tc_name)
 	 , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
 
-tooManyParmsErr :: Located Name -> SDoc
-tooManyParmsErr tc_name
-  = ptext (sLit "Family instance has too many parameters:") <+> 
-    quotes (ppr tc_name)
-
-tooFewParmsErr :: Arity -> SDoc
-tooFewParmsErr arity
-  = ptext (sLit "Family instance has too few parameters; expected") <+> 
-    ppr arity
-
-wrongNumberOfParmsErr :: Arity -> SDoc
-wrongNumberOfParmsErr exp_arity
-  = ptext (sLit "Number of parameters must match family declaration; expected")
-    <+> ppr exp_arity
-
-badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr
-  = ptext (sLit "Illegal family instance in hs-boot file")
-
-notFamily :: TyCon -> SDoc
-notFamily tycon
-  = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
-         , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
-  
-wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family
-  = ptext (sLit "Wrong category of family instance; declaration was for a")
-    <+> kindOfFamily
-  where
-    kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
-		 | isAlgTyCon family = ptext (sLit "data type")
-		 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
-
 emptyConDeclsErr :: Name -> SDoc
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index a9ea11a..15c817a 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -30,7 +30,7 @@ import NameSet
 import Digraph
 import BasicTypes
 import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
 import Util ( isSingleton )
 import Data.List
 \end{code}
@@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss
                 nt_loop_breakers  `unionNameSets`
                 prod_loop_breakers
 
-    all_tycons = [ tc | tycls <- tyclss,
+    all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
                            -- Recursion of newtypes/data types can happen via
                            -- the class TyCon, so tyclss includes the class tycons
-                        let tc = getTyCon tycls,
-                        not (tyConName tc `elemNameSet` boot_name_set) ]
+                      , not (tyConName tc `elemNameSet` boot_name_set) ]
                            -- Remove the boot_name_set because they are going
                            -- to be loop breakers regardless.
 
@@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss
 new_tc_rhs :: TyCon -> Type
 new_tc_rhs tc = snd (newTyConRhs tc)    -- Ignore the type variables
 
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _           = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _           = Nothing
 
 findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
 -- Finds a set of tycons that cut all loops
@@ -356,8 +355,8 @@ tcTyConsOfType ty
      go (FunTy a b)                = go a `plusNameEnv` go b
      go (PredTy (IParam _ ty))     = go ty
      go (PredTy (ClassP cls tys))  = go_tc (classTyCon cls) tys
+     go (PredTy (EqPred ty1 ty2))  = go ty1 `plusNameEnv` go ty2
      go (ForAllTy _ ty)            = go ty
-     go _                          = panic "tcTyConsOfType"
 
      go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index d9166d1..a825d23 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -19,7 +19,7 @@ module TcType (
   --------------------------------
   -- Types 
   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, 
-  TcTyVar, TcTyVarSet, TcKind, TcCoVar,
+  TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
 
   --------------------------------
   -- MetaDetails
@@ -50,7 +50,7 @@ module TcType (
   ---------------------------------
   -- Predicates. 
   -- Again, newtypes are opaque
-  tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
+  eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
   eqKind, 
   isSigmaTy, isOverloadedTy,
   isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
@@ -61,18 +61,11 @@ module TcType (
   ---------------------------------
   -- Misc type manipulators
   deNoteType,
-  orphNamesOfType, orphNamesOfDFunHead, 
+  orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
   getDFunTyKey,
 
   ---------------------------------
   -- Predicate types  
-  getClassPredTys_maybe, getClassPredTys, 
-  isClassPred, isTyVarClassPred, isEqPred, 
-  mkClassPred, mkIPPred, tcSplitPredTy_maybe, 
-  mkDictTy, evVarPred,
-  isPredTy, isDictTy, isDictLikeTy,
-  tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 
-  isIPPred, 
   mkMinimalBySCs, transSuperClasses, immSuperClasses,
 
   -- * Tidying type related things up for printing
@@ -81,7 +74,8 @@ module TcType (
   tidyTyVarBndr, tidyFreeTyVars,
   tidyOpenTyVar, tidyOpenTyVars,
   tidyTopType,   tidyPred,
-  tidyKind,
+  tidyKind, 
+  tidyCo, tidyCos,
 
   ---------------------------------
   -- Foreign import and export
@@ -101,32 +95,38 @@ module TcType (
   tcSplitIOType_maybe, -- :: Type -> Maybe Type  
 
   --------------------------------
-  -- Rexported from Coercion
-  typeKind,
-
-  --------------------------------
-  -- Rexported from Type
-  Kind, 	-- Stuff to do with kinds is insensitive to pre/post Tc
+  -- Rexported from Kind
+  Kind, typeKind,
   unliftedTypeKind, liftedTypeKind, argTypeKind,
   openTypeKind, mkArrowKind, mkArrowKinds, 
   isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, 
   isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
   kindVarRef, mkKindVar,  
 
-  Type, PredType(..), ThetaType, 
+  --------------------------------
+  -- Rexported from Type
+  Type, Pred(..), PredType, ThetaType,
   mkForAllTy, mkForAllTys, 
   mkFunTy, mkFunTys, zipFunTys, 
   mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
   mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, 
 
+  getClassPredTys_maybe, getClassPredTys, 
+  isClassPred, isTyVarClassPred, isEqPred, 
+  mkClassPred, mkIPPred, splitPredTy_maybe, 
+  mkDictTy, isPredTy, isDictTy, isDictLikeTy,
+  tcSplitDFunTy, tcSplitDFunHead, 
+  isIPPred, mkEqPred,
+
   -- Type substitutions
   TvSubst(..), 	-- Representation visible to a few friends
-  TvSubstEnv, emptyTvSubst, substEqSpec,
+  TvSubstEnv, emptyTvSubst, 
   mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, 
   mkTopTvSubst, notElemTvSubst, unionTvSubst,
-  getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
-  extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
-  substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
+  getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, 
+  Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
+  extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
+  Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, 
 
   isUnLiftedType,	-- Source types are always lifted
   isUnboxedTupleType,	-- Ditto
@@ -138,13 +138,14 @@ module TcType (
 
   pprKind, pprParendKind,
   pprType, pprParendType, pprTypeApp, pprTyThingCategory,
-  pprPred, pprTheta, pprThetaArrow, pprClassPred
+  pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred
 
   ) where
 
 #include "HsVersions.h"
 
 -- friends:
+import Kind
 import TypeRep
 import Class
 import Var
@@ -156,7 +157,7 @@ import TyCon
 
 -- others:
 import DynFlags
-import Name
+import Name hiding (varName)
 import NameSet
 import VarEnv
 import PrelNames
@@ -216,6 +217,8 @@ type TcType = Type 	-- A TcType can have mutable type variables
 	-- a cannot occur inside a MutTyVar in T; that is,
 	-- T is "flattened" before quantifying over a
 
+type TcCoercion = Coercion  -- A TcCoercion can contain TcTypes.
+
 -- These types do not have boxy type variables in them
 type TcPredType     = PredType
 type TcThetaType    = ThetaType
@@ -262,7 +265,7 @@ the same type variable in both type signatures.  But that takes explanation.
 
 The alternative (currently implemented) is to have a special kind of skolem
 constant, SigTv, which can unify with other SigTvs.  These are *not* treated
-as righd for the purposes of GADTs.  And they are used *only* for pattern 
+as rigid for the purposes of GADTs.  And they are used *only* for pattern
 bindings and mutually recursive function bindings.  See the function
 TcBinds.tcInstSig, and its use_skols parameter.
 
@@ -390,7 +393,7 @@ kind_var_occ = mkOccName tvName "k"
 \begin{code}
 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 -- For debugging
-pprTcTyVarDetails (SkolemTv {})    = ptext (sLit "sk")
+pprTcTyVarDetails (SkolemTv {})     = ptext (sLit "sk")
 pprTcTyVarDetails (RuntimeUnk {})  = ptext (sLit "rt")
 pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
 pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
@@ -426,19 +429,13 @@ pprUserTypeCtxt GenSigCtxt      = ptext (sLit "a type expected by the context")
 -- 
 -- It doesn't change the uniques at all, just the print names.
 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr env@(tidy_env, subst) tyvar
+tidyTyVarBndr (tidy_env, subst) tyvar
   = case tidyOccName tidy_env occ1 of
-      (tidy', occ') -> ((tidy', subst'), tyvar'')
+      (tidy', occ') -> ((tidy', subst'), tyvar')
 	where
-          subst' = extendVarEnv subst tyvar tyvar''
+          subst' = extendVarEnv subst tyvar tyvar'
           tyvar' = setTyVarName tyvar name'
-
-          name' = tidyNameOcc name occ'
-
-                -- Don't forget to tidy the kind for coercions!
-	  tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
-		  | otherwise	  = tyvar'
-	  kind'  = tidyType env (tyVarKind tyvar)
+          name'  = tidyNameOcc name occ'
   where
     name = tyVarName tyvar
     occ  = getOccName name
@@ -527,6 +524,40 @@ tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
 tidyKind env k = tidyOpenType env k
 \end{code}
 
+%************************************************************************
+%*									*
+                            Tidying coercions
+%*									*
+%************************************************************************
+
+\begin{code}
+
+tidyCo :: TidyEnv -> Coercion -> Coercion
+tidyCo env@(_, subst) co
+  = go co
+  where
+    go (Refl ty)             = Refl (tidyType env ty)
+    go (TyConAppCo tc cos)   = let args = map go cos
+                               in args `seqList` TyConAppCo tc args
+    go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2
+    go (ForAllCo tv co)      = ForAllCo tvp $! (tidyCo envp co)
+                               where
+                                 (envp, tvp) = tidyTyVarBndr env tv
+    go (CoVarCo cv)          = case lookupVarEnv subst cv of
+                                 Nothing  -> CoVarCo cv
+                                 Just cv' -> CoVarCo cv'
+    go (AxiomInstCo con cos) = let args = tidyCos env cos
+                               in  args `seqList` AxiomInstCo con args
+    go (UnsafeCo ty1 ty2)    = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
+    go (SymCo co)            = SymCo $! go co
+    go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
+    go (NthCo d co)          = NthCo d $! go co
+    go (InstCo co ty)        = (InstCo $! go co) $! tidyType env ty
+
+tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
+tidyCos env = map (tidyCo env)
+
+\end{code}
 
 %************************************************************************
 %*									*
@@ -670,22 +701,19 @@ tcSplitForAllTys :: Type -> ([TyVar], Type)
 tcSplitForAllTys ty = split ty ty []
    where
      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
-     split _ (ForAllTy tv ty) tvs 
-       | not (isCoVar tv) = split ty ty (tv:tvs)
-     split orig_ty _ tvs = (reverse tvs, orig_ty)
+     split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+     split orig_ty _          tvs = (reverse tvs, orig_ty)
 
 tcIsForAllTy :: Type -> Bool
 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
-tcIsForAllTy _               = False
+tcIsForAllTy (ForAllTy {}) = True
+tcIsForAllTy _             = False
 
 tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
 -- Split off the first predicate argument from a type
 tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
-tcSplitPredFunTy_maybe (ForAllTy tv ty)
-  | isCoVar tv = Just (coVarPred tv, ty)
 tcSplitPredFunTy_maybe (FunTy arg res)
-  | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+  | Just p <- splitPredTy_maybe arg = Just (p, res)
 tcSplitPredFunTy_maybe _
   = Nothing
 
@@ -835,13 +863,12 @@ tcSplitDFunTy ty
     -- coercion and class constraints; or (in the general NDP case)
     -- some other function argument
     split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
-    split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
     split_dfun_args n (FunTy _ ty)     = split_dfun_args (n+1) ty
     split_dfun_args n ty               = (n, ty)
 
 tcSplitDFunHead :: Type -> (Class, [Type])
 tcSplitDFunHead tau  
-  = case tcSplitPredTy_maybe tau of 
+  = case splitPredTy_maybe tau of 
 	Just (ClassP clas tys) -> (clas, tys)
 	_ -> pprPanic "tcSplitDFunHead" (ppr tau)
 
@@ -884,60 +911,6 @@ tcInstHeadTyAppAllTyVars ty
 %*									*
 %************************************************************************
 
-\begin{code}
-evVarPred :: EvVar -> PredType
-evVarPred var
-  = case tcSplitPredTy_maybe (varType var) of
-      Just pred -> pred
-      Nothing   -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
-
-tcSplitPredTy_maybe :: Type -> Maybe PredType
-   -- Returns Just for predicates only
-tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
-tcSplitPredTy_maybe (PredTy p)    = Just p
-tcSplitPredTy_maybe _             = Nothing
-
-predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _)    = getUnique (ipNameName n)
-predTyUnique (ClassP clas _) = getUnique clas
-predTyUnique (EqPred a b)    = pprPanic "predTyUnique" (ppr (EqPred a b))
-\end{code}
-
-
---------------------- Dictionary types ---------------------------------
-
-\begin{code}
-mkClassPred :: Class -> [Type] -> PredType
-mkClassPred clas tys = ClassP clas tys
-
-isClassPred :: PredType -> Bool
-isClassPred (ClassP _ _) = True
-isClassPred _            = False
-
-isTyVarClassPred :: PredType -> Bool
-isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys
-isTyVarClassPred _              = False
-
-getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
-getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
-getClassPredTys_maybe _                 = Nothing
-
-getClassPredTys :: PredType -> (Class, [Type])
-getClassPredTys (ClassP clas tys) = (clas, tys)
-getClassPredTys _ = panic "getClassPredTys"
-
-mkDictTy :: Class -> [Type] -> Type
-mkDictTy clas tys = mkPredTy (ClassP clas tys)
-
-isDictLikeTy :: Type -> Bool
--- Note [Dictionary-like types]
-isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
-isDictLikeTy (PredTy p) = isClassPred p
-isDictLikeTy (TyConApp tc tys) 
-  | isTupleTyCon tc     = all isDictLikeTy tys
-isDictLikeTy _          = False
-\end{code}
-
 Superclasses
 
 \begin{code}
@@ -947,7 +920,7 @@ mkMinimalBySCs ptys = [ ploc |  ploc <- ptys
                              ,  ploc `not_in_preds` rec_scs ]
  where
    rec_scs = concatMap trans_super_classes ptys
-   not_in_preds p ps = null (filter (tcEqPred p) ps)
+   not_in_preds p ps = null (filter (eqPred p) ps)
    trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
    trans_super_classes _other_pty       = []
 
@@ -967,53 +940,6 @@ immSuperClasses cls tys
   where (tyvars,sc_theta,_,_) = classBigSig cls
 \end{code}
 
-Note [Dictionary-like types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Being "dictionary-like" means either a dictionary type or a tuple thereof.
-In GHC 6.10 we build implication constraints which construct such tuples,
-and if we land up with a binding
-    t :: (C [a], Eq [a])
-    t = blah
-then we want to treat t as cheap under "-fdicts-cheap" for example.
-(Implication constraints are normally inlined, but sadly not if the
-occurrence is itself inside an INLINE function!  Until we revise the 
-handling of implication constraints, that is.)  This turned out to
-be important in getting good arities in DPH code.  Example:
-
-    class C a
-    class D a where { foo :: a -> a }
-    instance C a => D (Maybe a) where { foo x = x }
-
-    bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
-    {-# INLINE bar #-}
-    bar x y = (foo (Just x), foo (Just y))
-
-Then 'bar' should jolly well have arity 4 (two dicts, two args), but
-we ended up with something like
-   bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
-                                in \x,y. <blah>)
-
-This is all a bit ad-hoc; eg it relies on knowing that implication
-constraints build tuples.
-
---------------------- Implicit parameters ---------------------------------
-
-\begin{code}
-mkIPPred :: IPName Name -> Type -> PredType
-mkIPPred ip ty = IParam ip ty
-
-isIPPred :: PredType -> Bool
-isIPPred (IParam _ _) = True
-isIPPred _            = False
-\end{code}
-
---------------------- Equality predicates ---------------------------------
-\begin{code}
-substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
-substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
-			    | (tv,ty) <- eq_spec]
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -1035,17 +961,10 @@ isSigmaTy _              = False
 isOverloadedTy :: Type -> Bool
 -- Yes for a type of a function that might require evidence-passing
 -- Used only by bindLocalMethods
--- NB: be sure to check for type with an equality predicate; hence isCoVar
 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
-isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty
-isOverloadedTy (FunTy a _)      = isPredTy a
-isOverloadedTy _                = False
-
-isPredTy :: Type -> Bool	-- Belongs in TcType because it does 
-				-- not look through newtypes, or predtypes (of course)
-isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
-isPredTy (PredTy _) = True
-isPredTy _          = False
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a _)     = isPredTy a
+isOverloadedTy _               = False
 \end{code}
 
 \begin{code}
@@ -1107,14 +1026,9 @@ tcTyVarsOfType (TyConApp _ tys)     = tcTyVarsOfTypes tys
 tcTyVarsOfType (PredTy sty)	    = tcTyVarsOfPred sty
 tcTyVarsOfType (FunTy arg res)	    = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
 tcTyVarsOfType (AppTy fun arg)	    = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
-tcTyVarsOfType (ForAllTy tyvar ty)  = (tcTyVarsOfType ty `delVarSet` tyvar)
-                                      `unionVarSet` tcTyVarsOfTyVar tyvar
+tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
 	-- We do sometimes quantify over skolem TcTyVars
 
-tcTyVarsOfTyVar :: TcTyVar -> TyVarSet
-tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv)
-                   | otherwise  = emptyVarSet
-
 tcTyVarsOfTypes :: [Type] -> TyVarSet
 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
 
@@ -1124,61 +1038,6 @@ tcTyVarsOfPred (ClassP _ tys) 	= tcTyVarsOfTypes tys
 tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
 \end{code}
 
-Note [Silly type synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-	type T a = Int
-What are the free tyvars of (T x)?  Empty, of course!  
-Here's the example that Ralf Laemmel showed me:
-	foo :: (forall a. C u a -> C u a) -> u
-	mappend :: Monoid u => u -> u -> u
-
-	bar :: Monoid u => u
-	bar = foo (\t -> t `mappend` t)
-We have to generalise at the arg to f, and we don't
-want to capture the constraint (Monad (C u a)) because
-it appears to mention a.  Pretty silly, but it was useful to him.
-
-exactTyVarsOfType is used by the type checker to figure out exactly
-which type variables are mentioned in a type.  It's also used in the
-smart-app checking code --- see TcExpr.tcIdApp
-
-On the other hand, consider a *top-level* definition
-	f = (\x -> x) :: T a -> T a
-If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
-if we have an application like (f "x") we get a confusing error message 
-involving Any.  So the conclusion is this: when generalising
-  - at top level use tyVarsOfType
-  - in nested bindings use exactTyVarsOfType
-See Trac #1813 for example.
-
-\begin{code}
-exactTyVarsOfType :: TcType -> TyVarSet
--- Find the free type variables (of any kind)
--- but *expand* type synonyms.  See Note [Silly type synonym] above.
-exactTyVarsOfType ty
-  = go ty
-  where
-    go ty | Just ty' <- tcView ty = go ty'	-- This is the key line
-    go (TyVarTy tv)         = unitVarSet tv
-    go (TyConApp _ tys)     = exactTyVarsOfTypes tys
-    go (PredTy ty)	    = go_pred ty
-    go (FunTy arg res)	    = go arg `unionVarSet` go res
-    go (AppTy fun arg)	    = go fun `unionVarSet` go arg
-    go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
-                              `unionVarSet` go_tv tyvar
-
-    go_pred (IParam _ ty)    = go ty
-    go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
-    go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
-
-    go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar)
-                | otherwise     = emptyVarSet
-
-exactTyVarsOfTypes :: [TcType] -> TyVarSet
-exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
-\end{code}
-
 Find the free tycons and classes of a type.  This is used in the front
 end of the compiler.
 
@@ -1211,6 +1070,26 @@ orphNamesOfDFunHead :: Type -> NameSet
 orphNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
 	(_, _, head_ty) -> orphNamesOfType head_ty
+        
+orphNamesOfCo :: Coercion -> NameSet
+orphNamesOfCo (Refl ty)             = orphNamesOfType ty
+orphNamesOfCo (TyConAppCo tc cos)   = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (ForAllCo _ co)       = orphNamesOfCo co
+orphNamesOfCo (CoVarCo _)           = emptyNameSet
+orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (UnsafeCo ty1 ty2)    = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCo (SymCo co)            = orphNamesOfCo co
+orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co
+orphNamesOfCo (InstCo co ty)        = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
+
+orphNamesOfCos :: [Coercion] -> NameSet
+orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
+
+orphNamesOfCoCon :: CoAxiom -> NameSet
+orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
+  = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
 \end{code}
 
 
@@ -1225,7 +1104,7 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
 -- (isIOType t) returns Just (IO,t',co)
 --				if co : t ~ IO t'
 --		returns Nothing otherwise
@@ -1236,7 +1115,7 @@ tcSplitIOType_maybe ty
 
 	Just (io_tycon, [io_res_ty]) 
 	   |  io_tycon `hasKey` ioTyConKey 
-	   -> Just (io_tycon, io_res_ty, IdCo ty)
+           -> Just (io_tycon, io_res_ty, mkReflCo ty)
 
 	Just (tc, tys)
 	   | not (isRecursiveTyCon tc)
@@ -1244,7 +1123,7 @@ tcSplitIOType_maybe ty
 		  -- Newtypes that require a coercion are ok
 	   -> case tcSplitIOType_maybe ty of
 		Nothing		    -> Nothing
-		Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
+		Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
 
 	_ -> Nothing
 
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 31352e1..572ad44 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -20,7 +20,7 @@ module TcUnify (
   matchExpectedListTy, matchExpectedPArrTy, 
   matchExpectedTyConApp, matchExpectedAppTy, 
   matchExpectedFunTys, matchExpectedFunKind,
-  wrapFunResCoercion
+  wrapFunResCoercion, failWithMisMatch
   ) where
 
 #include "HsVersions.h"
@@ -28,7 +28,7 @@ module TcUnify (
 import HsSyn
 import TypeRep
 import CoreUtils( mkPiTypes )
-import TcErrors ( unifyCtxt )
+import TcErrors	( unifyCtxt )
 import TcMType
 import TcIface
 import TcRnMonad
@@ -44,7 +44,6 @@ import VarEnv
 import Name
 import ErrUtils
 import BasicTypes
-
 import Maybes ( allMaybes )  
 import Util
 import Outputable
@@ -103,7 +102,7 @@ expected type, becuase it expects that to have been done already
 matchExpectedFunTys :: SDoc 	-- See Note [Herald for matchExpectedFunTys]
             	    -> Arity
             	    -> TcRhoType 
-            	    -> TcM (CoercionI, [TcSigmaType], TcRhoType)	 		
+                    -> TcM (Coercion, [TcSigmaType], TcRhoType)
 
 -- If    matchExpectFunTys n ty = (co, [t1,..,tn], ty_r)
 -- then  co : ty ~ (t1 -> ... -> tn -> ty_r)
@@ -122,7 +121,7 @@ matchExpectedFunTys herald arity orig_ty
     -- then   co : ty ~ t1 -> .. -> tn -> ty_r
 
     go n_req ty
-      | n_req == 0 = return (IdCo ty, [], ty)
+      | n_req == 0 = return (mkReflCo ty, [], ty)
 
     go n_req ty
       | Just ty' <- tcView ty = go n_req ty'
@@ -130,7 +129,7 @@ matchExpectedFunTys herald arity orig_ty
     go n_req (FunTy arg_ty res_ty)
       | not (isPredTy arg_ty) 
       = do { (coi, tys, ty_r) <- go (n_req-1) res_ty
-           ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) }
+           ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) }
 
     go _ (TyConApp tc _)	      -- A common case
       | not (isSynFamilyTyCon tc)
@@ -173,14 +172,14 @@ matchExpectedFunTys herald arity orig_ty
 
 \begin{code}
 ----------------------
-matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType)
 -- Special case for lists
 matchExpectedListTy exp_ty
  = do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
       ; return (coi, elt_ty) }
 
 ----------------------
-matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType)
 -- Special case for parrs
 matchExpectedPArrTy exp_ty
   = do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty
@@ -189,7 +188,7 @@ matchExpectedPArrTy exp_ty
 ----------------------
 matchExpectedTyConApp :: TyCon                -- T :: k1 -> ... -> kn -> *
                       -> TcRhoType 	      -- orig_ty
-                      -> TcM (CoercionI,      -- T a b c ~ orig_ty
+                      -> TcM (Coercion,      -- T a b c ~ orig_ty
                               [TcSigmaType])  -- Element types, a b c
                               
 -- It's used for wired-in tycons, so we call checkWiredInTyCon
@@ -200,7 +199,7 @@ matchExpectedTyConApp tc orig_ty
   = do  { checkWiredInTyCon tc
         ; go (tyConArity tc) orig_ty [] }
   where
-    go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType])
+    go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType])
     -- If     go n ty tys = (co, [t1..tn] ++ tys)
     -- then   co : T t1..tn ~ ty
 
@@ -217,12 +216,12 @@ matchExpectedTyConApp tc orig_ty
     go n_req ty@(TyConApp tycon args) tys
       | tc == tycon
       = ASSERT( n_req == length args)   -- ty::*
-        return (IdCo ty, args ++ tys)
+        return (mkReflCo ty, args ++ tys)
 
     go n_req (AppTy fun arg) tys
       | n_req > 0
       = do { (coi, args) <- go (n_req - 1) fun (arg : tys) 
-           ; return (mkAppTyCoI coi (IdCo arg), args) }
+           ; return (mkAppCo coi (mkReflCo arg), args) }
 
     go n_req ty tys = defer n_req ty tys
 
@@ -236,7 +235,7 @@ matchExpectedTyConApp tc orig_ty
 
 ----------------------
 matchExpectedAppTy :: TcRhoType                         -- orig_ty
-                   -> TcM (CoercionI,                   -- m a ~ orig_ty
+                   -> TcM (Coercion,                   -- m a ~ orig_ty
                            (TcSigmaType, TcSigmaType))  -- Returns m, a
 -- If the incoming type is a mutable type variable of kind k, then
 -- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
@@ -248,7 +247,7 @@ matchExpectedAppTy orig_ty
       | Just ty' <- tcView ty = go ty'
 
       | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
-      = return (IdCo orig_ty, (fun_ty, arg_ty))
+      = return (mkReflCo orig_ty, (fun_ty, arg_ty))
 
     go (TyVarTy tv)
       | ASSERT( isTcTyVar tv) isMetaTyVar tv
@@ -306,14 +305,14 @@ tcSubType origin ctxt ty_actual ty_expected
             <- tcGen ctxt ty_expected $ \ _ sk_rho -> do
             { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual
             ; coi <- unifyType in_rho sk_rho
-            ; return (coiToHsWrapper coi <.> in_wrap) }
+            ; return (coToHsWrapper coi <.> in_wrap) }
        ; return (sk_wrap <.> inst_wrap) }
 
   | otherwise	-- Urgh!  It seems deeply weird to have equality
     		-- when actual is not a polytype, and it makes a big 
 		-- difference e.g. tcfail104
   = do { coi <- unifyType ty_actual ty_expected
-       ; return (coiToHsWrapper coi) }
+       ; return (coToHsWrapper coi) }
   
 tcInfer :: (TcType -> TcM a) -> TcM (a, TcType)
 tcInfer tc_infer = do { ty  <- newFlexiTyVarTy openTypeKind
@@ -325,7 +324,7 @@ tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId)
 tcWrapResult expr actual_ty res_ty
   = do { coi <- unifyType actual_ty res_ty
        	        -- Both types are deeply skolemised
-       ; return (mkHsWrapCoI coi expr) }
+       ; return (mkHsWrapCo coi expr) }
 
 -----------------------------------
 wrapFunResCoercion
@@ -451,18 +450,18 @@ non-exported generic functions.
 
 \begin{code}
 ---------------
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
 -- Actual and expected types
 -- Returns a coercion : ty1 ~ ty2
 unifyType ty1 ty2 = uType [] ty1 ty2
 
 ---------------
-unifyPred :: PredType -> PredType -> TcM CoercionI
+unifyPred :: PredType -> PredType -> TcM Coercion
 -- Actual and expected types
 unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2
 
 ---------------
-unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI]
+unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion]
 -- Actual and expected types
 unifyTheta theta1 theta2
   = do  { checkTc (equalLength theta1 theta2)
@@ -513,7 +512,7 @@ uType, uType_np, uType_defer
   :: [EqOrigin]
   -> TcType    -- ty1 is the *actual* type
   -> TcType    -- ty2 is the *expected* type
-  -> TcM CoercionI
+  -> TcM Coercion
 
 --------------
 -- It is always safe to defer unification to the main constraint solver
@@ -529,7 +528,7 @@ uType_defer (item : origin) ty1 ty2
        ; doc <- mkErrInfo emptyTidyEnv ctxt
        ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc])
 
-       ; return $ ACo $ mkTyVarTy co_var }
+       ; return $ mkCoVarCo co_var }
 uType_defer [] _ _
   = panic "uType_defer"
 
@@ -545,15 +544,15 @@ uType_np origin orig_ty1 orig_ty2
               [ sep [ ppr orig_ty1, text "~", ppr orig_ty2]
               , ppr origin]
        ; coi <- go orig_ty1 orig_ty2
-       ; case coi of
-            ACo co -> traceTc "u_tys yields coercion:" (ppr co)
-            IdCo _ -> traceTc "u_tys yields no coercion" empty
+       ; if isReflCo coi
+            then traceTc "u_tys yields no coercion" empty
+            else traceTc "u_tys yields coercion:" (ppr coi)
        ; return coi }
   where
     bale_out :: [EqOrigin] -> TcM a
     bale_out origin = failWithMisMatch origin
 
-    go :: TcType -> TcType -> TcM CoercionI
+    go :: TcType -> TcType -> TcM Coercion
 	-- The arguments to 'go' are always semantically identical 
 	-- to orig_ty{1,2} except for looking through type synonyms
 
@@ -579,24 +578,14 @@ uType_np origin orig_ty1 orig_ty2
       | Just ty1' <- tcView ty1 = go ty1' ty2
       | Just ty2' <- tcView ty2 = go ty1  ty2'
       	     
-
         -- Predicates
     go (PredTy p1) (PredTy p2) = uPred origin p1 p2
 
-        -- Coercion functions: (t1a ~ t1b) => t1c  ~  (t2a ~ t2b) => t2c
-    go ty1 ty2 
-      | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe ty1, 
-        Just (t2a,t2b,t2c) <- splitCoPredTy_maybe ty2
-      = do { co1 <- uType origin t1a t2a 
-           ; co2 <- uType origin t1b t2b
-           ; co3 <- uType origin t1c t2c 
-           ; return $ mkCoPredCoI co1 co2 co3 }
-
         -- Functions (or predicate functions) just check the two parts
     go (FunTy fun1 arg1) (FunTy fun2 arg2)
       = do { coi_l <- uType origin fun1 fun2
            ; coi_r <- uType origin arg1 arg2
-           ; return $ mkFunTyCoI coi_l coi_r }
+           ; return $ mkFunCo coi_l coi_r }
 
         -- Always defer if a type synonym family (type function)
       	-- is involved.  (Data families behave rigidly.)
@@ -608,20 +597,20 @@ uType_np origin orig_ty1 orig_ty2
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       | tc1 == tc2	   -- See Note [TyCon app]
       = do { cois <- uList origin uType tys1 tys2
-           ; return $ mkTyConAppCoI tc1 cois }
+           ; return $ mkTyConAppCo tc1 cois }
      
 	-- See Note [Care with type applications]
     go (AppTy s1 t1) ty2
       | Just (s2,t2) <- tcSplitAppTy_maybe ty2
       = do { coi_s <- uType_np origin s1 s2  -- See Note [Unifying AppTy]
            ; coi_t <- uType origin t1 t2        
-           ; return $ mkAppTyCoI coi_s coi_t }
+           ; return $ mkAppCo coi_s coi_t }
 
     go ty1 (AppTy s2 t2)
       | Just (s1,t1) <- tcSplitAppTy_maybe ty1
       = do { coi_s <- uType_np origin s1 s2
            ; coi_t <- uType origin t1 t2
-           ; return $ mkAppTyCoI coi_s coi_t }
+           ; return $ mkAppCo coi_s coi_t }
 
     go ty1 ty2
       | tcIsForAllTy ty1 || tcIsForAllTy ty2 
@@ -630,7 +619,7 @@ uType_np origin orig_ty1 orig_ty2
         -- Anything else fails
     go _ _ = bale_out origin
 
-unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI
+unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion
 unifySigmaTy origin ty1 ty2
   = do { let (tvs1, body1) = tcSplitForAllTys ty1
              (tvs2, body2) = tcSplitForAllTys ty2
@@ -639,9 +628,8 @@ unifySigmaTy origin ty1 ty2
                   -- Get location from monad, not from tvs1
        ; let tys      = mkTyVarTys skol_tvs
              in_scope = mkInScopeSet (mkVarSet skol_tvs)
-             phi1     = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
-             phi2     = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
---             untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+             phi1     = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
+             phi2     = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
 
        ; ((coi, _untch), lie) <- captureConstraints $ 
                                  captureUntouchables $ 
@@ -656,23 +644,24 @@ unifySigmaTy origin ty1 ty2
               (failWithMisMatch origin)	-- ToDo: give details from bad_lie
 
        ; emitConstraints lie
-       ; return (foldr mkForAllTyCoI coi skol_tvs) }
+       ; return (foldr mkForAllCo coi skol_tvs) }
 
 ----------
-uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI
+uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion
 uPred origin (IParam n1 t1) (IParam n2 t2)
   | n1 == n2
   = do { coi <- uType origin t1 t2
-       ; return $ mkIParamPredCoI n1 coi }
+       ; return $ mkPredCo $ IParam n1 coi }
 uPred origin (ClassP c1 tys1) (ClassP c2 tys2)
   | c1 == c2 
   = do { cois <- uList origin uType tys1 tys2
           -- Guaranteed equal lengths because the kinds check
-       ; return $ mkClassPPredCoI c1 cois }
+       ; return $ mkPredCo $ ClassP c1 cois }
+
 uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b)
-  = do { coia <- uType origin ty1a ty2a
-       ; coib <- uType origin ty1b ty2b
-       ; return $ mkEqPredCoI coia coib }
+  = do { coa <- uType origin ty1a ty2a
+       ; cob <- uType origin ty1b ty2b
+       ; return $ mkPredCo $ EqPred coa cob }
 
 uPred origin _ _ = failWithMisMatch origin
 
@@ -816,7 +805,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips
 back into @uTys@ if it turns out that the variable is already bound.
 
 \begin{code}
-uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI
+uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion
 uVar origin swapped tv1 ty2
   = do  { traceTc "uVar" (vcat [ ppr origin
                                 , ppr swapped
@@ -834,13 +823,13 @@ uUnfilledVar :: [EqOrigin]
              -> SwapFlag
              -> TcTyVar -> TcTyVarDetails       -- Tyvar 1
              -> TcTauType  			-- Type 2
-             -> TcM CoercionI
+             -> TcM Coercion
 -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
 --            It might be a skolem, or untouchable, or meta
 
 uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2)
   | tv1 == tv2  -- Same type variable => no-op
-  = return (IdCo (mkTyVarTy tv1))
+  = return (mkReflCo (mkTyVarTy tv1))
 
   | otherwise  -- Distinct type variables
   = do  { lookup2 <- lookupTcTyVar tv2
@@ -874,7 +863,7 @@ uUnfilledVars :: [EqOrigin]
               -> SwapFlag
               -> TcTyVar -> TcTyVarDetails      -- Tyvar 1
               -> TcTyVar -> TcTyVarDetails      -- Tyvar 2
-              -> TcM CoercionI
+              -> TcM Coercion
 -- Invarant: The type variables are distinct,
 --           Neither is filled in yet
 
@@ -1053,10 +1042,10 @@ lookupTcTyVar tyvar
     details = ASSERT2( isTcTyVar tyvar, ppr tyvar )
               tcTyVarDetails tyvar
 
-updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI
+updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion
 updateMeta tv1 ref1 ty2
   = do { writeMetaTyVarRef tv1 ref1 ty2
-       ; return (IdCo ty2) }
+       ; return (mkReflCo ty2) }
 \end{code}
 
 Note [Unifying untouchables]
diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot
index 244f0cb..e7ad418 100644
--- a/compiler/typecheck/TcUnify.lhs-boot
+++ b/compiler/typecheck/TcUnify.lhs-boot
@@ -2,10 +2,10 @@
 module TcUnify where
 import TcType	( TcTauType )
 import TcRnTypes( TcM )
-import Coercion (CoercionI)
+import Coercion (Coercion)
 
 -- This boot file exists only to tie the knot between
 --		TcUnify and TcSimplify
 
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
 \end{code}
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 1e16bc4..d9e44e5 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -81,7 +81,7 @@ type ClassOpItem = (Id, DefMeth)
 
 data DefMeth = NoDefMeth 		-- No default method
 	     | DefMeth Name  		-- A polymorphic default method
-	     | GenDefMeth 		-- A generic default method
+	     | GenDefMeth Name 		-- A generic default method
              deriving Eq  
 
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
@@ -91,7 +91,7 @@ defMethSpecOfDefMeth meth
  = case meth of
 	NoDefMeth	-> NoDM
 	DefMeth _	-> VanillaDM
-	GenDefMeth	-> GenericDM
+	GenDefMeth _	-> GenericDM
 
 \end{code}
 
@@ -208,9 +208,9 @@ instance Show Class where
     showsPrec p c = showsPrecSDoc p (ppr c)
 
 instance Outputable DefMeth where
-    ppr (DefMeth n) =  ptext (sLit "Default method") <+> ppr n
-    ppr GenDefMeth  =  ptext (sLit "Generic default method")
-    ppr NoDefMeth   =  empty   -- No default method
+    ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
+    ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
+    ppr NoDefMeth      =  empty   -- No default method
 
 pprFundeps :: Outputable a => [FunDep a] -> SDoc
 pprFundeps []  = empty
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index faab463..7df5b8e 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -7,15 +7,9 @@
 -- as used in System FC. See 'CoreSyn.Expr' for
 -- more on System FC and how coercions fit into it.
 --
--- Coercions are represented as types, and their kinds tell what types the 
--- coercion works on. The coercion kind constructor is a special TyCon that 
--- must always be saturated, like so:
---
--- > typeKind (symCoercion type) :: TyConApp CoTyCon{...} [type, type]
 module Coercion (
         -- * Main data type
-        Coercion, Kind,
-        typeKind,
+        Coercion(..), Var, CoVar,
 
         -- ** Deconstructing Kinds 
         kindFunResult, kindAppResult, synTyConResKind,
@@ -24,237 +18,454 @@ module Coercion (
         -- ** Predicates on Kinds
         isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
         isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, 
-        isCoSuperKind, isSuperKind, isCoercionKind, 
+        isSuperKind, isCoercionKind, 
 	mkArrowKind, mkArrowKinds,
 
         isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
         isSubKindCon,
 
-        mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe,
-        coercionKind, coercionKinds, isIdentityCoercion,
-
-	-- ** Equality predicates
-	isEqPred, mkEqPred, getEqPredTys, isEqPredTy,  
-
-	-- ** Coercion transformations
-	mkCoercion,
-        mkSymCoercion, mkTransCoercion,
-        mkLeftCoercion, mkRightCoercion, 
-	mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion,
-        mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion,
-        mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
-        mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion, 
-
-	mkClassPPredCo, mkIParamPredCo, mkEqPredCo, 
-        mkCoVarCoercion, mkCoPredCo, 
+        mkCoType, coVarKind, coVarKind_maybe,
+        coercionType, coercionKind, coercionKinds, isReflCo,
 
-
-        unsafeCoercionTyCon, symCoercionTyCon,
-        transCoercionTyCon, leftCoercionTyCon, 
-        rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn
-        csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon, 
+	-- ** Constructing coercions
+        mkReflCo, mkCoVarCo,
+        mkAxInstCo, mkPiCo, mkPiCos,
+        mkSymCo, mkTransCo, mkNthCo,
+	mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
+        mkForAllCo, mkUnsafeCo,
+        mkNewTypeCo, mkFamInstCo, 
+        mkPredCo,
 
         -- ** Decomposition
-        decompLR_maybe, decompCsel_maybe, decompInst_maybe,
         splitCoPredTy_maybe,
         splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
-
+        getCoVar_maybe,
+
+        splitTyConAppCo_maybe,
+        splitAppCo_maybe,
+        splitForAllCo_maybe,
+
+	-- ** Coercion variables
+	mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique,
+
+        -- ** Free variables
+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize,
+	
+        -- ** Substitution
+        CvSubstEnv, emptyCvSubstEnv, 
+ 	CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar,
+	isEmptyCvSubst, zapCvSubstEnv, getCvInScope,
+        substCo, substCos, substCoVar, substCoVars,
+        substCoWithTy, substCoWithTys, 
+	cvTvSubst, tvCvSubst, zipOpenCvSubst,
+        substTy, extendTvSubst,
+	substTyVarBndr, substCoVarBndr,
+
+	-- ** Lifting
+	liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, 
+        
         -- ** Comparison
         coreEqCoercion, coreEqCoercion2,
 
-	-- * CoercionI
-	CoercionI(..),
-	isIdentityCoI,
-	mkSymCoI, mkTransCoI, 
-	mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
-	mkForAllTyCoI,
-	fromCoI, 
-	mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI, mkCoPredCoI 
+        -- ** Forcing evaluation of coercions
+        seqCo,
+        
+        -- * Pretty-printing
+        pprCo, pprParendCo, pprCoAxiom,
 
+        -- * Other
+        applyCo, coVarPred
+        
        ) where 
 
 #include "HsVersions.h"
 
+import Unify	( MatchEnv(..), ruleMatchTyX, matchList )
 import TypeRep
-import Type
+import qualified Type
+import Type hiding( substTy, substTyVarBndr, extendTvSubst )
+import Kind
+import Class	( classTyCon )
 import TyCon
-import Class
 import Var
 import VarEnv
 import VarSet
-import Name
-import PrelNames
+import UniqFM   ( minusUFM )
+import Maybes	( orElse )
+import Name	( Name, NamedThing(..), nameUnique )
+import OccName 	( isSymOcc )
 import Util
 import BasicTypes
 import Outputable
+import Unique
+import Pair
+import TysPrim		( eqPredPrimTyCon )
+import PrelNames	( funTyConKey )
+import Control.Applicative
+import Data.Traversable (traverse, sequenceA)
+import Control.Arrow (second)
 import FastString
+
+import qualified Data.Data as Data hiding ( TyCon )
 \end{code}
 
 %************************************************************************
 %*									*
-	Functions over Kinds		
+            Coercions
 %*									*
 %************************************************************************
 
 \begin{code}
--- | Essentially 'funResultTy' on kinds
-kindFunResult :: Kind -> Kind
-kindFunResult k = funResultTy k
-
-kindAppResult :: Kind -> [arg] -> Kind
-kindAppResult k []     = k
-kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
-
--- | Essentially 'splitFunTys' on kinds
-splitKindFunTys :: Kind -> ([Kind],Kind)
-splitKindFunTys k = splitFunTys k
-
-splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
-splitKindFunTy_maybe = splitFunTy_maybe
-
--- | Essentially 'splitFunTysN' on kinds
-splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
-splitKindFunTysN k = splitFunTysN k
-
--- | Find the result 'Kind' of a type synonym, 
--- after applying it to its 'arity' number of type variables
--- Actually this function works fine on data types too, 
--- but they'd always return '*', so we never need to ask
-synTyConResKind :: TyCon -> Kind
-synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
-isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
-        isUnliftedTypeKindCon, isSubArgTypeKindCon      :: TyCon -> Bool
-
-isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey
-
-isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
-isOpenTypeKind _               = False
-
-isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
-
-isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
-isUbxTupleKind _               = False
-
-isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
-
-isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
-isArgTypeKind _               = False
-
-isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
-
-isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
-isUnliftedTypeKind _               = False
-
-isSubOpenTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
-isSubOpenTypeKind (FunTy k1 k2)    = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) 
-                                     ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) 
-                                     False
-isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
-isSubOpenTypeKind other            = ASSERT( isKind other ) False
-         -- This is a conservative answer
-         -- It matters in the call to isSubKind in
-	 -- checkExpectedKind.
-
-isSubArgTypeKindCon kc
-  | isUnliftedTypeKindCon kc = True
-  | isLiftedTypeKindCon kc   = True
-  | isArgTypeKindCon kc      = True
-  | otherwise                = False
-
-isSubArgTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of ArgTypeKind 
-isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
-isSubArgTypeKind _                = False
-
--- | Is this a super-kind (i.e. a type-of-kinds)?
-isSuperKind :: Type -> Bool
-isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
-isSuperKind _                   = False
-
--- | Is this a kind (i.e. a type-of-types)?
-isKind :: Kind -> Bool
-isKind k = isSuperKind (typeKind k)
-
-isSubKind :: Kind -> Kind -> Bool
--- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
-isSubKind (FunTy a1 r1) (FunTy a2 r2)	      = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) 
-  = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2'
-isSubKind _             _                     = False
-
-eqKind :: Kind -> Kind -> Bool
-eqKind = tcEqType
-
-isSubKindCon :: TyCon -> TyCon -> Bool
--- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
-isSubKindCon kc1 kc2
-  | isLiftedTypeKindCon kc1   && isLiftedTypeKindCon kc2   = True
-  | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
-  | isUbxTupleKindCon kc1     && isUbxTupleKindCon kc2     = True
-  | isOpenTypeKindCon kc2                                  = True 
-                           -- we already know kc1 is not a fun, its a TyCon
-  | isArgTypeKindCon kc2      && isSubArgTypeKindCon kc1   = True
-  | otherwise                                              = False
-
-defaultKind :: Kind -> Kind
--- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
--- information on what that means
-
--- When we generalise, we make generic type variables whose kind is
--- simple (* or *->* etc).  So generic type variables (other than
--- built-in constants like 'error') always have simple kinds.  This is important;
--- consider
---	f x = True
--- We want f to get type
---	f :: forall (a::*). a -> Bool
--- Not 
---	f :: forall (a::??). a -> Bool
--- because that would allow a call like (f 3#) as well as (f True),
---and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
-defaultKind k 
-  | isSubOpenTypeKind k = liftedTypeKind
-  | isSubArgTypeKind k  = liftedTypeKind
-  | otherwise        = k
+-- | A 'Coercion' is concrete evidence of the equality/convertibility
+-- of two types.
+
+data Coercion 
+  -- These ones mirror the shape of types
+  = Refl Type  -- See Note [Refl invariant]
+          -- Invariant: applications of (Refl T) to a bunch of identity coercions
+          --            always show up as Refl.
+          -- For example  (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).
+
+          -- Applications of (Refl T) to some coercions, at least one of
+          -- which is NOT the identity, show up as TyConAppCo.
+          -- (They may not be fully saturated however.)
+          -- ConAppCo coercions (like all coercions other than Refl)
+          -- are NEVER the identity.
+
+  -- These ones simply lift the correspondingly-named 
+  -- Type constructors into Coercions
+  | TyConAppCo TyCon [Coercion]    -- lift TyConApp 
+    	       -- The TyCon is never a synonym; 
+	       -- we expand synonyms eagerly
+
+  | AppCo Coercion Coercion        -- lift AppTy
+
+  -- See Note [Forall coercions]
+  | ForAllCo TyVar Coercion       -- forall a. g
+
+  -- These are special
+  | CoVarCo CoVar
+  | AxiomInstCo CoAxiom [Coercion]  -- The coercion arguments always *precisely*
+                                    -- saturate arity of CoAxiom.
+                                    -- See [Coercion axioms applied to coercions]
+  | UnsafeCo Type Type
+  | SymCo Coercion
+  | TransCo Coercion Coercion
+
+  -- These are destructors
+  | NthCo Int Coercion          -- Zero-indexed
+  | InstCo Coercion Type
+  deriving (Data.Data, Data.Typeable)
 \end{code}
 
+Note [Refl invariant]
+~~~~~~~~~~~~~~~~~~~~~
+Coercions have the following invariant 
+     Refl is always lifted as far as possible.  
+
+You might think that a consequencs is:
+     Every identity coercions has Refl at the root
+
+But that's not quite true because of coercion variables.  Consider
+     g         where g :: Int~Int
+     Left h    where h :: Maybe Int ~ Maybe Int
+etc.  So the consequence is only true of coercions that
+have no coercion variables.
+
+Note [Coercion axioms applied to coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The reason coercion axioms can be applied to coercions and not just
+types is to allow for better optimization.  There are some cases where
+we need to be able to "push transitivity inside" an axiom in order to
+expose further opportunities for optimization.  
+
+For example, suppose we have
+
+  C a : t[a] ~ F a
+  g   : b ~ c
+
+and we want to optimize
+
+  sym (C b) ; t[g] ; C c
+
+which has the kind
+
+  F b ~ F c
+
+(stopping through t[b] and t[c] along the way).
+
+We'd like to optimize this to just F g -- but how?  The key is
+that we need to allow axioms to be instantiated by *coercions*,
+not just by types.  Then we can (in certain cases) push
+transitivity inside the axiom instantiations, and then react
+opposite-polarity instantiations of the same axiom.  In this
+case, e.g., we match t[g] against the LHS of (C c)'s kind, to
+obtain the substitution  a |-> g  (note this operation is sort
+of the dual of lifting!) and hence end up with
+
+  C g : t[b] ~ F c
+
+which indeed has the same kind as  t[g] ; C c.
+
+Now we have
+
+  sym (C b) ; C g
+
+which can be optimized to F g.
+
+
+Note [Forall coercions]
+~~~~~~~~~~~~~~~~~~~~~~~
+Constructing coercions between forall-types can be a bit tricky.
+Currently, the situation is as follows:
+
+  ForAllCo TyVar Coercion
+
+represents a coercion between polymorphic types, with the rule
+
+           v : k       g : t1 ~ t2
+  ----------------------------------------------
+  ForAllCo v g : (all v:k . t1) ~ (all v:k . t2)
+
+Note that it's only necessary to coerce between polymorphic types
+where the type variables have identical kinds, because equality on
+kinds is trivial.
+
+Note [Predicate coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   g :: a~b
+How can we coerce between types
+   ([c]~a) => [a] -> c
+and
+   ([c]~b) => [b] -> c
+where the equality predicate *itself* differs?
+
+Answer: we simply treat (~) as an ordinary type constructor, so these
+types really look like
+
+   ((~) [c] a) -> [a] -> c
+   ((~) [c] b) -> [b] -> c
+
+So the coercion between the two is obviously
+
+   ((~) [c] g) -> [g] -> c
+
+Another way to see this to say that we simply collapse predicates to
+their representation type (see Type.coreView and Type.predTypeRep).
+
+This collapse is done by mkPredCo; there is no PredCo constructor
+in Coercion.  This is important because we need Nth to work on 
+predicates too:
+    Nth 1 ((~) [c] g) = g
+See Simplify.simplCoercionF, which generates such selections.
+
 %************************************************************************
 %*									*
-            Coercions
+\subsection{Coercion variables}
+%*									*
+%************************************************************************
+
+\begin{code}
+coVarName :: CoVar -> Name
+coVarName = varName
+
+setCoVarUnique :: CoVar -> Unique -> CoVar
+setCoVarUnique = setVarUnique
+
+setCoVarName :: CoVar -> Name -> CoVar
+setCoVarName   = setVarName
+
+isCoVar :: Var -> Bool
+isCoVar v = isCoVarType (varType v)
+
+isCoVarType :: Type -> Bool
+isCoVarType = isEqPredTy
+\end{code}
+
+
+\begin{code}
+tyCoVarsOfCo :: Coercion -> VarSet
+-- Extracts type and coercion variables from a coercion
+tyCoVarsOfCo (Refl ty)           = tyVarsOfType ty
+tyCoVarsOfCo (TyConAppCo _ cos)  = tyCoVarsOfCos cos
+tyCoVarsOfCo (AppCo co1 co2)     = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (ForAllCo tv co)    = tyCoVarsOfCo co `delVarSet` tv
+tyCoVarsOfCo (CoVarCo v)         = unitVarSet v
+tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (UnsafeCo ty1 ty2)  = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyCoVarsOfCo (SymCo co)          = tyCoVarsOfCo co
+tyCoVarsOfCo (TransCo co1 co2)   = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (NthCo _ co)        = tyCoVarsOfCo co
+tyCoVarsOfCo (InstCo co ty)      = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
+
+tyCoVarsOfCos :: [Coercion] -> VarSet
+tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
+
+coVarsOfCo :: Coercion -> VarSet
+-- Extract *coerction* variables only.  Tiresome to repeat the code, but easy.
+coVarsOfCo (Refl _)            = emptyVarSet
+coVarsOfCo (TyConAppCo _ cos)  = coVarsOfCos cos
+coVarsOfCo (AppCo co1 co2)     = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (ForAllCo _ co)     = coVarsOfCo co
+coVarsOfCo (CoVarCo v)         = unitVarSet v
+coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos
+coVarsOfCo (UnsafeCo _ _)      = emptyVarSet
+coVarsOfCo (SymCo co)          = coVarsOfCo co
+coVarsOfCo (TransCo co1 co2)   = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (NthCo _ co)        = coVarsOfCo co
+coVarsOfCo (InstCo co _)       = coVarsOfCo co
+
+coVarsOfCos :: [Coercion] -> VarSet
+coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
+
+coercionSize :: Coercion -> Int
+coercionSize (Refl ty)           = typeSize ty
+coercionSize (TyConAppCo _ cos)  = 1 + sum (map coercionSize cos)
+coercionSize (AppCo co1 co2)     = coercionSize co1 + coercionSize co2
+coercionSize (ForAllCo _ co)     = 1 + coercionSize co
+coercionSize (CoVarCo _)         = 1
+coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (UnsafeCo ty1 ty2)  = typeSize ty1 + typeSize ty2
+coercionSize (SymCo co)          = 1 + coercionSize co
+coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2
+coercionSize (NthCo _ co)        = 1 + coercionSize co
+coercionSize (InstCo co ty)      = 1 + coercionSize co + typeSize ty
+\end{code}
+
+%************************************************************************
 %*									*
+                   Pretty-printing coercions
+%*                                                                      *
 %************************************************************************
 
+@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@
+function is defined to use this.  @pprParendCo@ is the same, except it
+puts parens around the type, except for the atomic cases.
+@pprParendCo@ works just by setting the initial context precedence
+very high.
 
 \begin{code}
--- | A 'Coercion' represents a 'Type' something should be coerced to.
-type Coercion     = Type
+instance Outputable Coercion where
+  ppr = pprCo
+
+pprCo, pprParendCo :: Coercion -> SDoc
+pprCo       co = ppr_co TopPrec   co
+pprParendCo co = ppr_co TyConPrec co
+
+ppr_co :: Prec -> Coercion -> SDoc
+ppr_co _ (Refl ty) = angles (ppr ty)
+
+ppr_co p co@(TyConAppCo tc cos)
+  | tc `hasKey` funTyConKey = ppr_fun_co p co
+  | otherwise               = pprTcApp   p ppr_co tc cos
+
+ppr_co p (AppCo co1 co2)    = maybeParen p TyConPrec $
+                              pprCo co1 <+> ppr_co TyConPrec co2
+
+ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
+
+ppr_co _ (CoVarCo cv)
+  | isSymOcc (getOccName cv) = parens (ppr cv)
+  | otherwise                = ppr cv
+
+ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
 
--- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the
--- types that a 'Coercion' will work on.
-type CoercionKind = Kind
 
-------------------------------
+ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $
+                             ppr_co FunPrec co1
+                             <+> ptext (sLit ";")
+                             <+> ppr_co FunPrec co2
+ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
+                          pprParendCo co <> ptext (sLit "@") <> pprType ty
 
--- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into
+ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2]
+ppr_co p (SymCo co)         = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co]
+ppr_co p (NthCo n co)       = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co]
+
+
+angles :: SDoc -> SDoc
+angles p = char '<' <> p <> char '>'
+
+ppr_fun_co :: Prec -> Coercion -> SDoc
+ppr_fun_co p co = pprArrowChain p (split co)
+  where
+    split (TyConAppCo f [arg,res])
+      | f `hasKey` funTyConKey
+      = ppr_co FunPrec arg : split res
+    split co = [ppr_co TopPrec co]
+
+ppr_forall_co :: Prec -> Coercion -> SDoc
+ppr_forall_co p ty
+  = maybeParen p FunPrec $
+    sep [pprForAll tvs, ppr_co TopPrec rho]
+  where
+    (tvs,  rho) = split1 [] ty
+    split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty
+    split1 tvs ty               = (reverse tvs, ty)
+\end{code}
+
+\begin{code}
+pprCoAxiom :: CoAxiom -> SDoc
+pprCoAxiom ax
+  = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax)
+        , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ]
+\end{code}
+
+%************************************************************************
+%*									*
+	Functions over Kinds		
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into
 -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:
 --
--- > decomposeCo 3 c = [right (left (left c)), right (left c), right c]
+-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]
 decomposeCo :: Arity -> Coercion -> [Coercion]
-decomposeCo n co
-  = go n co []
-  where
-    go 0 _  cos = cos
-    go n co cos = go (n-1) (mkLeftCoercion co)
-			   (mkRightCoercion co : cos)
-
+decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ]
+
+-- | Attempts to obtain the type variable underlying a 'Coercion'
+getCoVar_maybe :: Coercion -> Maybe CoVar
+getCoVar_maybe (CoVarCo cv) = Just cv  
+getCoVar_maybe _            = Nothing
+
+-- | Attempts to tease a coercion apart into a type constructor and the application
+-- of a number of coercion arguments to that constructor
+splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
+splitTyConAppCo_maybe (Refl ty)           = (fmap . second . map) Refl (splitTyConApp_maybe ty)
+splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos)
+splitTyConAppCo_maybe _                   = Nothing
+
+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
+-- ^ Attempt to take a coercion application apart.
+splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2)
+splitAppCo_maybe (TyConAppCo tc cos)
+  | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc 
+  , Just (cos', co') <- snocView cos
+  = Just (mkTyConAppCo tc cos', co')    -- Never create unsaturated type family apps!
+       -- Use mkTyConAppCo to preserve the invariant
+       --  that identity coercions are always represented by Refl
+splitAppCo_maybe (Refl ty) 
+  | Just (ty1, ty2) <- splitAppTy_maybe ty 
+  = Just (Refl ty1, Refl ty2)
+splitAppCo_maybe _ = Nothing
+
+splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co)
+splitForAllCo_maybe _                = Nothing
 
 -------------------------------------------------------
 -- and some coercion kind stuff
 
+coVarPred :: CoVar -> PredType
+coVarPred cv
+  = ASSERT( isCoVar cv )
+    case splitPredTy_maybe (varType cv) of
+	Just pred -> pred
+	other	  -> pprPanic "coVarPred" (ppr cv $$ ppr other)
+
 coVarKind :: CoVar -> (Type,Type) 
 -- c :: t1 ~ t2
 coVarKind cv = case coVarKind_maybe cv of
@@ -262,31 +473,12 @@ coVarKind cv = case coVarKind_maybe cv of
                  Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv))
 
 coVarKind_maybe :: CoVar -> Maybe (Type,Type) 
-coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv)
-
--- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'.
--- Panics if the argument is not a valid 'CoercionKind'
-splitCoKind_maybe :: Kind -> Maybe (Type, Type)
-splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co'
-splitCoKind_maybe (PredTy (EqPred ty1 ty2))    = Just (ty1, ty2)
-splitCoKind_maybe _                            = Nothing
+coVarKind_maybe cv = splitEqPredTy_maybe (varType cv)
 
--- | Makes a 'CoercionKind' from two types: the types whose equality 
+-- | Makes a coercion type from two types: the types whose equality 
 -- is proven by the relevant 'Coercion'
-mkCoKind :: Type -> Type -> CoercionKind
-mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2)
-
--- | (mkCoPredTy s t r) produces the type:   (s~t) => r
-mkCoPredTy :: Type -> Type -> Type -> Type
-mkCoPredTy s t r = ASSERT( not (co_var `elemVarSet` tyVarsOfType r) )
-                   ForAllTy co_var r
-  where
-    co_var = mkWildCoVar (mkCoKind s t)
-
-mkCoPredCo :: Coercion -> Coercion -> Coercion -> Coercion 
--- Creates a coercion between (s1~t1) => r1  and (s2~t2) => r2 
-mkCoPredCo = mkCoPredTy 
-
+mkCoType :: Type -> Type -> Type
+mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2)
 
 splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type)
 splitCoPredTy_maybe ty
@@ -297,25 +489,13 @@ splitCoPredTy_maybe ty
   | otherwise
   = Nothing
 
--- | Tests whether a type is just a type equality predicate
-isEqPredTy :: Type -> Bool
-isEqPredTy (PredTy pred) = isEqPred pred
-isEqPredTy _             = False
-
--- | Creates a type equality predicate
-mkEqPred :: (Type, Type) -> PredType
-mkEqPred (ty1, ty2) = EqPred ty1 ty2
-
--- | Splits apart a type equality predicate, if the supplied 'PredType' is one.
--- Panics otherwise
-getEqPredTys :: PredType -> (Type,Type)
-getEqPredTys (EqPred ty1 ty2) = (ty1, ty2)
-getEqPredTys other	      = pprPanic "getEqPredTys" (ppr other)
-
-isIdentityCoercion :: Coercion -> Bool
-isIdentityCoercion co  
-  = case coercionKind co of
-       (t1,t2) -> t1 `coreEqType` t2
+isReflCo :: Coercion -> Bool
+isReflCo (Refl {}) = True
+isReflCo _         = False
+
+isReflCo_maybe :: Coercion -> Maybe Type
+isReflCo_maybe (Refl ty) = Just ty
+isReflCo_maybe _         = Nothing
 \end{code}
 
 %************************************************************************
@@ -324,236 +504,157 @@ isIdentityCoercion co
 %*									*
 %************************************************************************
 
-Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args)
-
 \begin{code}
--- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to
--- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function
--- if possible
-mkCoercion :: TyCon -> [Type] -> Coercion
-mkCoercion coCon args = ASSERT( tyConArity coCon == length args ) 
-                        TyConApp coCon args
+mkCoVarCo :: CoVar -> Coercion
+mkCoVarCo cv
+  | ty1 `eqType` ty2 = Refl ty1
+  | otherwise        = CoVarCo cv
+  where
+    (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
 
-mkCoVarCoercion :: CoVar -> Coercion 
-mkCoVarCoercion cv = mkTyVarTy cv 
+mkReflCo :: Type -> Coercion
+mkReflCo = Refl
 
--- | Apply a 'Coercion' to another 'Coercion', which is presumably a
--- 'Coercion' constructor of some kind
-mkAppCoercion :: Coercion -> Coercion -> Coercion
-mkAppCoercion co1 co2 = mkAppTy co1 co2
+mkAxInstCo :: CoAxiom -> [Type] -> Coercion
+mkAxInstCo ax tys
+  | arity == n_tys = AxiomInstCo ax rtys
+  | otherwise      = ASSERT( arity < n_tys )
+                     foldl AppCo (AxiomInstCo ax (take arity rtys))
+                                 (drop arity rtys)
+  where
+    n_tys = length tys
+    arity = coAxiomArity ax
+    rtys  = map Refl tys
+
+-- | Apply a 'Coercion' to another 'Coercion'.
+mkAppCo :: Coercion -> Coercion -> Coercion
+mkAppCo (Refl ty1) (Refl ty2)       = Refl (mkAppTy ty1 ty2)
+mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co])
+mkAppCo (TyConAppCo tc cos) co      = TyConAppCo tc (cos ++ [co])
+mkAppCo co1 co2                     = AppCo co1 co2
+-- Note, mkAppCo is careful to maintain invariants regarding
+-- where Refl constructors appear; see the comments in the definition
+-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs.
 
 -- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
--- See also 'mkAppCoercion'
-mkAppsCoercion :: Coercion -> [Coercion] -> Coercion
-mkAppsCoercion co1 tys = foldl mkAppTy co1 tys
+-- See also 'mkAppCo'
+mkAppCos :: Coercion -> [Coercion] -> Coercion
+mkAppCos co1 tys = foldl mkAppCo co1 tys
 
 -- | Apply a type constructor to a list of coercions.
-mkTyConCoercion :: TyCon -> [Coercion] -> Coercion
-mkTyConCoercion con cos = mkTyConApp con cos
+mkTyConAppCo :: TyCon -> [Coercion] -> Coercion
+mkTyConAppCo tc cos
+	       -- Expand type synonyms
+  | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos
+  = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos
+
+  | Just tys <- traverse isReflCo_maybe cos 
+  = Refl (mkTyConApp tc tys)	-- See Note [Refl invariant]
+
+  | otherwise = TyConAppCo tc cos
 
 -- | Make a function 'Coercion' between two other 'Coercion's
-mkFunCoercion :: Coercion -> Coercion -> Coercion
-mkFunCoercion co1 co2 = mkFunTy co1 co2 -- NB: Handles correctly the forall for eqpreds!
+mkFunCo :: Coercion -> Coercion -> Coercion
+mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2]
 
 -- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
-mkForAllCoercion :: Var -> Coercion -> Coercion
+mkForAllCo :: Var -> Coercion -> Coercion
 -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkForAllCoercion tv  co  = ASSERT ( isTyCoVar tv ) mkForAllTy tv co
+mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty)
+mkForAllCo tv  co       = ASSERT ( isTyVar tv ) ForAllCo tv co
 
+mkPredCo :: Pred Coercion -> Coercion
+-- See Note [Predicate coercions]
+mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2]
+mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos
+mkPredCo (IParam _ co)    = co
 
 -------------------------------
 
-mkSymCoercion :: Coercion -> Coercion
--- ^ Create a symmetric version of the given 'Coercion' that asserts equality
--- between the same types but in the other "direction", so a kind of @t1 ~ t2@ 
--- becomes the kind @t2 ~ t1@.
-mkSymCoercion g = mkCoercion symCoercionTyCon [g]
-
-mkTransCoercion :: Coercion -> Coercion -> Coercion
--- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's.
-mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2]
-
-mkLeftCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of 
--- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: f ~ g
-mkLeftCoercion co = mkCoercion leftCoercionTyCon [co]
-
-mkRightCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of 
--- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: x ~ y
-mkRightCoercion co = mkCoercion rightCoercionTyCon [co]
-
-mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion
-mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co]
-mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co]
-mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co]
-
--------------------------------
-mkInstCoercion :: Coercion -> Type -> Coercion
--- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
--- the resulting beta-reduction, otherwise it creates a suspended instantiation.
-mkInstCoercion co ty = mkCoercion instCoercionTyCon  [co, ty]
-
-mkInstsCoercion :: Coercion -> [Type] -> Coercion
--- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right
-mkInstsCoercion co tys = foldl mkInstCoercion co tys
-
--- | Manufacture a coercion from this air. Needless to say, this is not usually safe,
--- but it is used when we know we are dealing with bottom, which is one case in which 
--- it is safe.  This is also used implement the @unsafeCoerce#@ primitive.
--- Optimise by pushing down through type constructors
-mkUnsafeCoercion :: Type -> Type -> Coercion
-mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+-- | Create a symmetric version of the given 'Coercion' that asserts
+--   equality between the same types but in the other "direction", so
+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.
+mkSymCo :: Coercion -> Coercion
+
+-- Do a few simple optimizations, but don't bother pushing occurrences
+-- of symmetry to the leaves; the optimizer will take care of that.
+mkSymCo co@(Refl {})              = co
+mkSymCo    (UnsafeCo ty1 ty2)    = UnsafeCo ty2 ty1
+mkSymCo    (SymCo co)            = co
+mkSymCo co                       = SymCo co
+
+-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
+mkTransCo :: Coercion -> Coercion -> Coercion
+mkTransCo (Refl _) co = co
+mkTransCo co (Refl _) = co
+mkTransCo co1 co2     = TransCo co1 co2
+
+mkNthCo :: Int -> Coercion -> Coercion
+mkNthCo n (Refl ty) = Refl (getNth n ty)
+mkNthCo n co        = NthCo n co
+
+-- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
+--   the resulting beta-reduction, otherwise it creates a suspended instantiation.
+mkInstCo :: Coercion -> Type -> Coercion
+mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co
+mkInstCo co ty               = InstCo co ty
+
+-- | Manufacture a coercion from thin air. Needless to say, this is
+--   not usually safe, but it is used when we know we are dealing with
+--   bottom, which is one case in which it is safe.  This is also used
+--   to implement the @unsafeCoerce#@ primitive.  Optimise by pushing
+--   down through type constructors.
+mkUnsafeCo :: Type -> Type -> Coercion
+mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1
+mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2)
   | tc1 == tc2
-  = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2)
+  = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2)
 
-mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2)
-  = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2)
+mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2)
+  = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2)
 
-mkUnsafeCoercion ty1 ty2 
-  | ty1 `coreEqType` ty2 = ty1
-  | otherwise            = mkCoercion unsafeCoercionTyCon [ty1, ty2]
+mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
 
 -- See note [Newtype coercions] in TyCon
 
--- | Create a coercion suitable for the given 'TyCon'. The 'Name' should be that of a
--- new coercion 'TyCon', the 'TyVar's the arguments expected by the @newtype@ and the
--- type the appropriate right hand side of the @newtype@, with the free variables
--- a subset of those 'TyVar's.
-mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon
-mkNewTypeCoercion name tycon tvs rhs_ty
-  = mkCoercionTyCon name arity desc
-  where
-    arity = length tvs
-    desc = CoAxiom { co_ax_tvs = tvs 
-                   , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
-                   , co_ax_rhs = rhs_ty }
+-- | Create a coercion constructor (axiom) suitable for the given
+--   newtype 'TyCon'. The 'Name' should be that of a new coercion
+--   'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
+--   the type the appropriate right hand side of the @newtype@, with
+--   the free variables a subset of those 'TyVar's.
+mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom
+mkNewTypeCo name tycon tvs rhs_ty
+  = CoAxiom { co_ax_unique = nameUnique name
+            , co_ax_name   = name
+            , co_ax_tvs    = tvs
+            , co_ax_lhs    = mkTyConApp tycon (mkTyVarTys tvs)
+            , co_ax_rhs    = rhs_ty }
 
 -- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type
 -- and its family instance.  It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is 
--- the coercion tycon built here, @F@ the family tycon and @R@ the (derived)
+-- the coercion constructor built here, @F@ the family tycon and @R@ the (derived)
 -- representation tycon.
-mkFamInstCoercion :: Name	-- ^ Unique name for the coercion tycon
+mkFamInstCo :: Name	-- ^ Unique name for the coercion tycon
 		  -> [TyVar]	-- ^ Type parameters of the coercion (@tvs@)
 		  -> TyCon	-- ^ Family tycon (@F@)
 		  -> [Type]	-- ^ Type instance (@ts@)
 		  -> TyCon	-- ^ Representation tycon (@R@)
-		  -> TyCon	-- ^ Coercion tycon (@Co@)
-mkFamInstCoercion name tvs family inst_tys rep_tycon
-  = mkCoercionTyCon name arity desc
-  where
-    arity = length tvs
-    desc = CoAxiom { co_ax_tvs = tvs
-                   , co_ax_lhs = mkTyConApp family inst_tys 
-                   , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) }
-
-
-mkClassPPredCo :: Class -> [Coercion] -> Coercion
-mkClassPPredCo cls = (PredTy . ClassP cls)
-
-mkIParamPredCo :: (IPName Name) -> Coercion -> Coercion
-mkIParamPredCo ipn = (PredTy . IParam ipn)
-
-mkEqPredCo :: Coercion -> Coercion -> Coercion 
-mkEqPredCo co1 co2 = PredTy (EqPred co1 co2)
-
-
+		  -> CoAxiom	-- ^ Coercion constructor (@Co@)
+mkFamInstCo name tvs family inst_tys rep_tycon
+  = CoAxiom { co_ax_unique = nameUnique name
+            , co_ax_name   = name
+            , co_ax_tvs    = tvs
+            , co_ax_lhs    = mkTyConApp family inst_tys 
+            , co_ax_rhs    = mkTyConApp rep_tycon (mkTyVarTys tvs) }
+
+mkPiCos :: [Var] -> Coercion -> Coercion
+mkPiCos vs co = foldr mkPiCo co vs
+
+mkPiCo  :: Var -> Coercion -> Coercion
+mkPiCo v co | isTyVar v = mkForAllCo v co
+            | otherwise = mkFunCo (mkReflCo (varType v)) co
 \end{code}
 
-
-%************************************************************************
-%*									*
-            Coercion Type Constructors
-%*									*
-%************************************************************************
-
-Example.  The coercion ((sym c) (sym d) (sym e))
-will be represented by (TyConApp sym [c, sym d, sym e])
-If sym c :: p1=q1
-   sym d :: p2=q2
-   sym e :: p3=q3
-then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3)
-
-\begin{code}
--- | Coercion type constructors: avoid using these directly and instead use 
--- the @mk*Coercion@ and @split*Coercion@ family of functions if possible.
---
--- Each coercion TyCon is built with the special CoercionTyCon record and
--- carries its own kinding rule.  Such CoercionTyCons must be fully applied
--- by any TyConApp in which they are applied, however they may also be over
--- applied (see example above) and the kinding function must deal with this.
-symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, 
-  rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon,
-  csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon
-
-symCoercionTyCon    = mkCoercionTyCon symCoercionTyConName   1 CoSym
-transCoercionTyCon  = mkCoercionTyCon transCoercionTyConName 2 CoTrans
-leftCoercionTyCon   = mkCoercionTyCon leftCoercionTyConName  1 CoLeft
-rightCoercionTyCon  = mkCoercionTyCon rightCoercionTyConName 1 CoRight
-instCoercionTyCon   =  mkCoercionTyCon instCoercionTyConName 2 CoInst
-csel1CoercionTyCon  = mkCoercionTyCon csel1CoercionTyConName 1 CoCsel1
-csel2CoercionTyCon  = mkCoercionTyCon csel2CoercionTyConName 1 CoCsel2
-cselRCoercionTyCon  = mkCoercionTyCon cselRCoercionTyConName 1 CoCselR
-unsafeCoercionTyCon = mkCoercionTyCon unsafeCoercionTyConName 2 CoUnsafe
-
-transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName, 
-   rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName,
-   csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name
-
-transCoercionTyConName 	= mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon
-symCoercionTyConName   	= mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon
-leftCoercionTyConName  	= mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon
-rightCoercionTyConName 	= mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon
-instCoercionTyConName  	= mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon
-csel1CoercionTyConName  = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon
-csel2CoercionTyConName  = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon
-cselRCoercionTyConName  = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon
-unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon
-
-mkCoConName :: FastString -> Unique -> TyCon -> Name
-mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
-                            key (ATyCon coCon) BuiltInSyntax
-\end{code}
-
-\begin{code}
-------------
-decompLR_maybe :: (Type,Type) -> Maybe ((Type,Type), (Type,Type))
--- Helper for left and right.  Finds coercion kind of its input and
--- returns the left and right projections of the coercion...
---
--- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2))
-decompLR_maybe (ty1,ty2)
-  | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1
-  , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2
-  = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2))
-decompLR_maybe _ = Nothing
-
-------------
-decompInst_maybe :: (Type, Type) -> Maybe ((TyVar,TyVar), (Type,Type))
-decompInst_maybe (ty1, ty2)
-  | Just (tv1,r1) <- splitForAllTy_maybe ty1
-  , Just (tv2,r2) <- splitForAllTy_maybe ty2
-  = Just ((tv1,tv2), (r1,r2))
-decompInst_maybe _ = Nothing
-
-------------
-decompCsel_maybe :: (Type, Type) -> Maybe ((Type,Type), (Type,Type), (Type,Type))
---   If         co :: (s1~t1 => r1) ~ (s2~t2 => r2)
--- Then   csel1 co ::            s1 ~ s2
---        csel2 co :: 		 t1 ~ t2
---        cselR co :: 		 r1 ~ r2
-decompCsel_maybe (ty1, ty2)
-  | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1
-  , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2
-  = Just ((s1,s2), (t1,t2), (r1,r2))
-decompCsel_maybe _ = Nothing
-\end{code}
-
-
 %************************************************************************
 %*									*
             Newtypes
@@ -561,17 +662,14 @@ decompCsel_maybe _ = Nothing
 %************************************************************************
 
 \begin{code}
-instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI)
+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
 -- ^ If @co :: T ts ~ rep_ty@ then:
 --
 -- > instNewTyCon_maybe T ts = Just (rep_ty, co)
 instNewTyCon_maybe tc tys
-  | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc
+  | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc
   = ASSERT( tys `lengthIs` tyConArity tc )
-    Just (substTyWith tvs tys ty, 
-	  case mb_co_tc of
-	     Nothing    -> IdCo (mkTyConApp tc    tys)
-	     Just co_tc -> ACo  (mkTyConApp co_tc tys))
+    Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys)
   | otherwise
   = Nothing
 
@@ -588,270 +686,425 @@ splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)
 splitNewTypeRepCo_maybe ty 
   | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
 splitNewTypeRepCo_maybe (TyConApp tc tys)
-  | Just (ty', coi) <- instNewTyCon_maybe tc tys
-  = case coi of
-	ACo co -> Just (ty', co)
-	IdCo _ -> panic "splitNewTypeRepCo_maybe"
+  | Just (ty', co) <- instNewTyCon_maybe tc tys
+  = case co of
+	Refl _ -> panic "splitNewTypeRepCo_maybe"
 			-- This case handled by coreView
+	_      -> Just (ty', co)
 splitNewTypeRepCo_maybe _
   = Nothing
 
 -- | Determines syntactic equality of coercions
 coreEqCoercion :: Coercion -> Coercion -> Bool
-coreEqCoercion = coreEqType
+coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2
+  where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2))
 
 coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool
-coreEqCoercion2 = coreEqType2
-\end{code}
+coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2
+coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2)
+  = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22)
+  = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2)
+  = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2
+
+coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2)
+  = rnOccL env cv1 == rnOccR env cv2
+
+coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2)
+  = con1 == con2
+    && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22)
+  = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22
+
+coreEqCoercion2 env (SymCo co1) (SymCo co2)
+  = coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22)
+  = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2)
+  = d1 == d2 && coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2)
+  = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2
 
+coreEqCoercion2 _ _ _ = False
+\end{code}
 
 %************************************************************************
 %*									*
-            CoercionI and its constructors
-%*									*
+                   Substitution of coercions
+%*                                                                      *
 %************************************************************************
 
---------------------------------------
--- CoercionI smart constructors
---	lifted smart constructors of ordinary coercions
+\begin{code}
+-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when
+--   doing a \"lifting\" substitution)
+type CvSubstEnv = VarEnv Coercion
+
+emptyCvSubstEnv :: CvSubstEnv
+emptyCvSubstEnv = emptyVarEnv
+
+data CvSubst 		
+  = CvSubst InScopeSet 	-- The in-scope type variables
+	    TvSubstEnv	-- Substitution of types
+            CvSubstEnv  -- Substitution of coercions
+
+instance Outputable CvSubst where
+  ppr (CvSubst ins tenv cenv)
+    = brackets $ sep[ ptext (sLit "CvSubst"),
+		      nest 2 (ptext (sLit "In scope:") <+> ppr ins), 
+		      nest 2 (ptext (sLit "Type env:") <+> ppr tenv),
+		      nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ]
+
+emptyCvSubst :: CvSubst
+emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+isEmptyCvSubst :: CvSubst -> Bool
+isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv
+
+getCvInScope :: CvSubst -> InScopeSet
+getCvInScope (CvSubst in_scope _ _) = in_scope
+
+zapCvSubstEnv :: CvSubst -> CvSubst
+zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv
+
+cvTvSubst :: CvSubst -> TvSubst
+cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs
+
+tvCvSubst :: TvSubst -> CvSubst
+tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv
+
+extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst
+extendTvSubst (CvSubst in_scope tenv cenv) tv ty
+  = CvSubst in_scope (extendVarEnv tenv tv ty) cenv
+
+substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar)
+substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var
+  = ASSERT( isCoVar old_var )
+    (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)
+  where
+    -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t)
+    -- In that case, mkCoVarCo will return a ReflCoercion, and
+    -- we want to substitute that (not new_var) for old_var
+    new_co    = mkCoVarCo new_var
+    no_change = new_var == old_var && not (isReflCo new_co)
+
+    new_cenv | no_change = delVarEnv cenv old_var
+             | otherwise = extendVarEnv cenv old_var new_co
+
+    new_var = uniqAway in_scope subst_old_var
+    subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var))
+		  -- It's important to do the substitution for coercions,
+		  -- because only they can have free type variables
+
+substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+substTyVarBndr (CvSubst in_scope tenv cenv) old_var
+  = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of
+      (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var)
+
+zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst
+zipOpenCvSubst vs cos
+  | debugIsOn && (length vs /= length cos)
+  = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst
+  | otherwise 
+  = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos)
+
+mkTopCvSubst :: [(Var,Coercion)] -> CvSubst
+mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs)
+
+substCoWithTy :: TyVar -> Type -> Coercion -> Coercion
+substCoWithTy tv ty = substCoWithTys [tv] [ty]
+
+substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion
+substCoWithTys tvs tys co
+  | debugIsOn && (length tvs /= length tys)
+  = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co
+  | otherwise 
+  = ASSERT( length tvs == length tys )
+    substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co
+  where
+    in_scope = mkInScopeSet (tyVarsOfTypes tys)
+
+-- | Substitute within a 'Coercion'
+substCo :: CvSubst -> Coercion -> Coercion
+substCo subst co | isEmptyCvSubst subst = co
+                 | otherwise            = subst_co subst co
+
+-- | Substitute within several 'Coercion's
+substCos :: CvSubst -> [Coercion] -> [Coercion]
+substCos subst cos | isEmptyCvSubst subst = cos
+                   | otherwise            = map (substCo subst) cos
+
+substTy :: CvSubst -> Type -> Type
+substTy subst = Type.substTy (cvTvSubst subst)
+
+subst_co :: CvSubst -> Coercion -> Coercion
+subst_co subst co
+  = go co
+  where
+    go_ty :: Type -> Type
+    go_ty = Coercion.substTy subst
+
+    go :: Coercion -> Coercion
+    go (Refl ty)             = Refl $! go_ty ty
+    go (TyConAppCo tc cos)   = let args = map go cos
+                               in  args `seqList` TyConAppCo tc args
+    go (AppCo co1 co2)       = mkAppCo (go co1) $! go co2
+    go (ForAllCo tv co)      = case substTyVarBndr subst tv of
+                                 (subst', tv') ->
+                                   ForAllCo tv' $! subst_co subst' co
+    go (CoVarCo cv)          = substCoVar subst cv
+    go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos
+    go (UnsafeCo ty1 ty2)    = (UnsafeCo $! go_ty ty1) $! go_ty ty2
+    go (SymCo co)            = mkSymCo (go co)
+    go (TransCo co1 co2)     = mkTransCo (go co1) (go co2)
+    go (NthCo d co)          = mkNthCo d (go co)
+    go (InstCo co ty)        = mkInstCo (go co) $! go_ty ty
+
+substCoVar :: CvSubst -> CoVar -> Coercion
+substCoVar (CvSubst in_scope _ cenv) cv
+  | Just co  <- lookupVarEnv cenv cv      = co
+  | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
+  | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv )
+                ASSERT( isCoVar cv ) CoVarCo cv
+
+substCoVars :: CvSubst -> [CoVar] -> [Coercion]
+substCoVars subst cvs = map (substCoVar subst) cvs
+
+lookupTyVar :: CvSubst -> TyVar  -> Maybe Type
+lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv
+
+lookupCoVar :: CvSubst -> Var  -> Maybe Coercion
+lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v
+\end{code}
+
+%************************************************************************
+%*									*
+                   "Lifting" substitution
+	   [(TyVar,Coercion)] -> Type -> Coercion
+%*                                                                      *
+%************************************************************************
 
 \begin{code}
--- | 'CoercionI' represents a /lifted/ ordinary 'Coercion', in that it
--- can represent either one of:
---
--- 1. A proper 'Coercion'
+liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion
+liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos)
+
+-- | The \"lifting\" operation which substitutes coercions for type
+--   variables in a type to produce a coercion.
 --
--- 2. The identity coercion
-data CoercionI = IdCo Type | ACo Coercion
+--   For the inverse operation, see 'liftCoMatch' 
+liftCoSubst :: CvSubst -> Type -> Coercion
+-- The CvSubst maps TyVar -> Type      (mainly for cloning foralls)
+--                  TyVar -> Coercion  (this is the payload)
+-- The unusual thing is that the *coercion* substitution maps
+-- some *type* variables. That's the whole point of this function!
+liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty
+                     | otherwise            = ty_co_subst subst ty
+
+ty_co_subst :: CvSubst -> Type -> Coercion
+ty_co_subst subst ty
+  = go ty
+  where
+    go (TyVarTy tv)      = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv)
+    go (AppTy ty1 ty2)   = mkAppCo (go ty1) (go ty2)
+    go (TyConApp tc tys) = mkTyConAppCo tc (map go tys)
+    go (FunTy ty1 ty2)   = mkFunCo (go ty1) (go ty2)
+    go (ForAllTy v ty)   = mkForAllCo v' $! (ty_co_subst subst' ty)
+                         where
+                           (subst', v') = liftCoSubstTyVarBndr subst v
+    go (PredTy p)        = mkPredCo (go <$> p)
+
+liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion
+liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv
+  = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of
+      (Nothing, Nothing) -> Nothing
+      (Just ty, Nothing) -> Just (Refl ty)
+      (Nothing, Just co) -> Just co
+      (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst)
+                                    
+liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var
+  = (CvSubst (in_scope `extendInScopeSet` new_var) 
+             new_tenv
+             (delVarEnv cenv old_var)	-- See Note [Lifting substitutions]
+    , new_var)		
+  where
+    new_tenv | no_change = delVarEnv tenv old_var
+	     | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
+
+    no_change = new_var == old_var
+    new_var = uniqAway in_scope old_var
+\end{code}
 
-liftCoI :: (Type -> Type) -> CoercionI -> CoercionI
-liftCoI f (IdCo ty) = IdCo (f ty)
-liftCoI f (ACo ty)  = ACo (f ty)
+Note [Lifting substitutions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider liftCoSubstWith [a] [co] (a, forall a. a)
+Then we want to substitute for the free 'a', but obviously not for
+the bound 'a'.  hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr.
 
-liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI
-liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2)
-liftCoI2 f coi1       coi2       = ACo (f (fromCoI coi1) (fromCoI coi2))
+This also why we need a full CvSubst when doing lifting substitutions.
 
-liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI
-liftCoIs f cois = go_id [] cois
+\begin{code}
+-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if
+--   @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@.
+--   That is, it matches a type against a coercion of the same
+--   "shape", and returns a lifting substitution which could have been
+--   used to produce the given coercion from the given type.
+liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst
+liftCoMatch tmpls ty co 
+  = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of
+      Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env)
+      Nothing               -> Nothing
   where
-    go_id rev_tys []               = IdCo (f (reverse rev_tys))
-    go_id rev_tys (IdCo ty : cois) = go_id  (ty:rev_tys) cois
-    go_id rev_tys (ACo  co : cois) = go_aco (co:rev_tys) cois
-
-    go_aco rev_tys []               = ACo (f (reverse rev_tys))
-    go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois
-    go_aco rev_tys (ACo  co : cois) = go_aco (co:rev_tys) cois
-
-instance Outputable CoercionI where
-  ppr (IdCo _) = ptext (sLit "IdCo")
-  ppr (ACo co) = ppr co
-
-isIdentityCoI :: CoercionI -> Bool
-isIdentityCoI (IdCo _) = True
-isIdentityCoI (ACo _)  = False
-
--- | Return either the 'Coercion' contained within the 'CoercionI' or the given
--- 'Type' if the 'CoercionI' is the identity 'Coercion'
-fromCoI :: CoercionI -> Type
-fromCoI (IdCo ty) = ty	-- Identity coercion represented 
-fromCoI (ACo co)  = co	-- 	by the type itself
-
--- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion'
-mkSymCoI :: CoercionI -> CoercionI
-mkSymCoI (IdCo ty) = IdCo ty
-mkSymCoI (ACo co)  = ACo $ mkCoercion symCoercionTyCon [co] 
-				-- the smart constructor
-				-- is too smart with tyvars
-
--- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion'
-mkTransCoI :: CoercionI -> CoercionI -> CoercionI
-mkTransCoI (IdCo _) aco = aco
-mkTransCoI aco (IdCo _) = aco
-mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
-
--- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion'
-mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI
-mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois
-
--- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion'
-mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkAppTyCoI = liftCoI2 mkAppTy
-
-mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkFunTyCoI = liftCoI2 mkFunTy
-
--- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion'
-mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
-mkForAllTyCoI tv = liftCoI (ForAllTy tv)
-
--- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies:
---
--- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois))
-mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI
-mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls)
+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }
+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)
+    -- Like tcMatchTy, assume all the interesting variables 
+    -- in ty are in tmpls
+
+type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv)
+     -- Used locally inside ty_co_match only
+
+-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.
+ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv
+ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co
+
+   -- Deal with the Refl case by delegating to type matching
+ty_co_match menv (tenv, cenv) ty co
+  | Just ty' <- isReflCo_maybe co
+  = case ruleMatchTyX ty_menv tenv ty ty' of
+      Just tenv' -> Just (tenv', cenv) 
+      Nothing    -> Nothing
+  where
+    ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv }
+    -- Remove from the template set any variables already bound to non-refl coercions
+
+  -- Match a type variable against a non-refl coercion
+ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co
+  | Just {} <- lookupVarEnv tenv tv1'      -- tv1' is already bound to (Refl ty)
+  = Nothing    -- The coercion 'co' is not Refl
+
+  | Just co1' <- lookupVarEnv cenv tv1'      -- tv1' is already bound to co1
+  = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co
+    then Just subst
+    else Nothing       -- no match since tv1 matches two different coercions
+
+  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var
+  = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co))
+    then Nothing      -- occurs check failed
+    else return (tenv, extendVarEnv cenv tv1' co)
+        -- BAY: I don't think we need to do any kind matching here yet
+        -- (compare 'match'), but we probably will when moving to SHE.
+
+  | otherwise    -- tv1 is not a template ty var, so the only thing it
+                 -- can match is a reflexivity coercion for itself.
+		 -- But that case is dealt with already
+  = Nothing
 
--- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI 
-mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn)
+  where
+    rn_env = me_env menv
+    tv1' = rnOccL rn_env tv1
 
--- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI
-mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2))
+ty_co_match menv subst (AppTy ty1 ty2) co
+  | Just (co1, co2) <- splitAppCo_maybe co	-- c.f. Unify.match on AppTy
+  = do { subst' <- ty_co_match menv subst ty1 co1 
+       ; ty_co_match menv subst' ty2 co2 }
 
-mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI 
-mkCoPredCoI coi1 coi2 coi3 =   mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3
+ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos)
+  | tc1 == tc2 = ty_co_matches menv subst tys cos
 
+ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos)
+  | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos
 
+ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) 
+  = ty_co_match menv' subst ty co
+  where
+    menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 }
+
+ty_co_match _ _ _ _ = Nothing
+
+ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv
+ty_co_matches menv = matchList (ty_co_match menv)
 \end{code}
 
 %************************************************************************
 %*									*
-	     The kind of a type, and of a coercion
+            Sequencing on coercions
 %*									*
 %************************************************************************
 
 \begin{code}
-typeKind :: Type -> Kind
-typeKind ty@(TyConApp tc tys) 
-  | isCoercionTyCon tc = typeKind (fst (coercionKind ty))
-  | otherwise          = kindAppResult (tyConKind tc) tys
-	-- During coercion optimisation we *do* match a type
-	-- against a coercion (see OptCoercion.matchesAxiomLhs)
-	-- So the use of typeKind in Unify.match_kind must work on coercions too
-	-- Hence the isCoercionTyCon case above
-
-typeKind (PredTy pred)	      = predKind pred
-typeKind (AppTy fun _)        = kindFunResult (typeKind fun)
-typeKind (ForAllTy _ ty)      = typeKind ty
-typeKind (TyVarTy tyvar)      = tyVarKind tyvar
-typeKind (FunTy _arg res)
-    -- Hack alert.  The kind of (Int -> Int#) is liftedTypeKind (*), 
-    --              not unliftedTypKind (#)
-    -- The only things that can be after a function arrow are
-    --   (a) types (of kind openTypeKind or its sub-kinds)
-    --   (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
-    | isTySuperKind k         = k
-    | otherwise               = ASSERT( isSubOpenTypeKind k) liftedTypeKind 
-    where
-      k = typeKind res
+seqCo :: Coercion -> ()
+seqCo (Refl ty)             = seqType ty
+seqCo (TyConAppCo tc cos)   = tc `seq` seqCos cos
+seqCo (AppCo co1 co2)       = seqCo co1 `seq` seqCo co2
+seqCo (ForAllCo tv co)      = tv `seq` seqCo co
+seqCo (CoVarCo cv)          = cv `seq` ()
+seqCo (AxiomInstCo con cos) = con `seq` seqCos cos
+seqCo (UnsafeCo ty1 ty2)    = seqType ty1 `seq` seqType ty2
+seqCo (SymCo co)            = seqCo co
+seqCo (TransCo co1 co2)     = seqCo co1 `seq` seqCo co2
+seqCo (NthCo _ co)          = seqCo co
+seqCo (InstCo co ty)        = seqCo co `seq` seqType ty
+
+seqCos :: [Coercion] -> ()
+seqCos []       = ()
+seqCos (co:cos) = seqCo co `seq` seqCos cos
+\end{code}
 
-------------------
-predKind :: PredType -> Kind
-predKind (EqPred {}) = coSuperKind	-- A coercion kind!
-predKind (ClassP {}) = liftedTypeKind	-- Class and implicitPredicates are
-predKind (IParam {}) = liftedTypeKind 	-- always represented by lifted types
+
+%************************************************************************
+%*									*
+	     The kind of a type, and of a coercion
+%*									*
+%************************************************************************
+
+\begin{code}
+coercionType :: Coercion -> Type
+coercionType co = case coercionKind co of
+                    Pair ty1 ty2 -> mkCoType ty1 ty2
 
 ------------------
 -- | If it is the case that
 --
 -- > c :: (t1 ~ t2)
 --
--- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@, 
--- then @coercionKind c = (t1, t2)@.
-coercionKind :: Coercion -> (Type, Type)
-coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a
-                            | otherwise = (ty, ty)
-coercionKind (AppTy ty1 ty2) 
-  = let (s1, t1) = coercionKind ty1
-        (s2, t2) = coercionKind ty2 in
-    (mkAppTy s1 s2, mkAppTy t1 t2)
-coercionKind co@(TyConApp tc args)
-  | Just (ar, desc) <- isCoercionTyCon_maybe tc 
-    -- CoercionTyCons carry their kinding rule, so we use it here
-  = WARN( not (length args >= ar), ppr co )	-- Always saturated
-    (let (ty1,  ty2)  = coTyConAppKind desc (take ar args)
-	 (tys1, tys2) = coercionKinds (drop ar args)
-     in (mkAppTys ty1 tys1, mkAppTys ty2 tys2))
-
-  | otherwise
-  = let (lArgs, rArgs) = coercionKinds args in
-    (TyConApp tc lArgs, TyConApp tc rArgs)
-
-coercionKind (FunTy ty1 ty2) 
-  = let (t1, t2) = coercionKind ty1
-        (s1, s2) = coercionKind ty2 in
-    (mkFunTy t1 s1, mkFunTy t2 s2)
-
-coercionKind (ForAllTy tv ty)
-  | isCoVar tv
---     c1 :: s1~s2  c2 :: t1~t2   c3 :: r1~r2
---    ----------------------------------------------
---    c1~c2 => c3  ::  (s1~t1) => r1 ~ (s2~t2) => r2
---      or
---    forall (_:c1~c2)
-  = let (c1,c2) = coVarKind tv
-    	(s1,s2) = coercionKind c1
-    	(t1,t2) = coercionKind c2
-    	(r1,r2) = coercionKind ty
-    in
-    (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2)
-
-  | otherwise
---     c1 :: s1~s2  c2 :: t1~t2   c3 :: r1~r2
---   ----------------------------------------------
---    forall a:k. c :: forall a:k. t1 ~ forall a:k. t2
-  = let (ty1, ty2) = coercionKind ty in
-    (ForAllTy tv ty1, ForAllTy tv ty2)
-
-coercionKind (PredTy (ClassP cl args)) 
-  = let (lArgs, rArgs) = coercionKinds args in
-    (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs))
-coercionKind (PredTy (IParam name ty))
-  = let (ty1, ty2) = coercionKind ty in
-    (PredTy (IParam name ty1), PredTy (IParam name ty2))
-coercionKind (PredTy (EqPred c1 c2)) 
-  = pprTrace "coercionKind" (pprEqPred (c1,c2)) $
-  -- These should not show up in coercions at all
-  -- becuase they are in the form of for-alls
-    let k1 = coercionKindPredTy c1
-        k2 = coercionKindPredTy c2 in
-    (k1,k2)
-  where
-    coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2
+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
+coercionKind :: Coercion -> Pair Type
+coercionKind (Refl ty)            = Pair ty ty
+coercionKind (TyConAppCo tc cos)  = mkTyConApp tc <$> (sequenceA $ map coercionKind cos)
+coercionKind (AppCo co1 co2)      = mkAppTy <$> coercionKind co1 <*> coercionKind co2
+coercionKind (ForAllCo tv co)     = mkForAllTy tv <$> coercionKind co
+coercionKind (CoVarCo cv)         = ASSERT( isCoVar cv ) toPair $ coVarKind cv
+coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos
+                                    in  Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax)) 
+                                             (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
+coercionKind (UnsafeCo ty1 ty2)   = Pair ty1 ty2
+coercionKind (SymCo co)           = swap $ coercionKind co
+coercionKind (TransCo co1 co2)    = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2)
+coercionKind (NthCo d co)         = getNth d <$> coercionKind co
+coercionKind co@(InstCo aco ty)    | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco
+                                  = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks
+				  | otherwise = pprPanic "coercionKind" (ppr co)
 
-------------------
 -- | Apply 'coercionKind' to multiple 'Coercion's
-coercionKinds :: [Coercion] -> ([Type], [Type])
-coercionKinds tys = unzip $ map coercionKind tys
+coercionKinds :: [Coercion] -> Pair [Type]
+coercionKinds tys = sequenceA $ map coercionKind tys
 
-------------------
--- | 'coTyConAppKind' is given a list of the type arguments to the 'CoTyCon',
--- and constructs the types that the resulting coercion relates.
--- Fails (in the monad) if ill-kinded.
--- Typically the monad is 
---   either the Lint monad (with the consistency-check flag = True), 
---   or the ID monad with a panic on failure (and the consistency-check flag = False)
-coTyConAppKind 
-    :: CoTyConDesc
-    -> [Type]	  		-- Exactly right number of args
-    -> (Type, Type)		-- Kind of this application
-coTyConAppKind CoUnsafe (ty1:ty2:_)
-  = (ty1,ty2)
-coTyConAppKind CoSym (co:_) 
-  | (ty1,ty2) <- coercionKind co = (ty2,ty1)
-coTyConAppKind CoTrans (co1:co2:_) 
-  = (fst (coercionKind co1), snd (coercionKind co2))
-coTyConAppKind CoLeft (co:_) 
-  | Just (res,_) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoRight (co:_) 
-  | Just (_,res) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoCsel1 (co:_) 
-  | Just (res,_,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCsel2 (co:_) 
-  | Just (_,res,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCselR (co:_) 
-  | Just (_,_,res) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoInst (co:ty:_) 
-  | Just ((tv1,tv2), (ty1,ty2)) <- decompInst_maybe (coercionKind co)
-  = (substTyWith [tv1] [ty] ty1, substTyWith [tv2] [ty] ty2) 
-coTyConAppKind (CoAxiom { co_ax_tvs = tvs 
-                        , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
-  = (substTyWith tvs tys1 lhs_ty, substTyWith tvs tys2 rhs_ty)
-  where
-    (tys1, tys2) = coercionKinds cos
-coTyConAppKind desc cos = pprTrace "coTyConAppKind" (ppr desc $$ braces (vcat 
-                             [ ppr co <+> dcolon <+> pprEqPred (coercionKind co)
-                             | co <- cos ])) $
-                          coercionKind (head cos)
+getNth :: Int -> Type -> Type
+getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty
+            = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
+getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty)
 \end{code}
+
+\begin{code}
+applyCo :: Type -> Coercion -> Type
+-- Gives the type of (e co) where e :: (a~b) => ty
+applyCo ty co | Just ty' <- coreView ty = applyCo ty' co
+applyCo (FunTy _ ty) _ = ty
+applyCo _            _ = panic "applyCo"
+\end{code}
\ No newline at end of file
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 93a67a7..5b4374a 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -29,7 +29,6 @@ import TypeRep
 import TyCon
 import Coercion
 import VarSet
-import Var
 import Name
 import UniqFM
 import Outputable
@@ -85,7 +84,12 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
-	2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
+       2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax)
+               , ptext (sLit "--") <+> pprNameLoc (getName famInst)])
+  where
+    pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of
+              Just ax -> ppr ax
+              Nothing -> ptext (sLit "<not there!>")
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_tycon = rep_tc})
@@ -303,7 +307,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
       --   anything else would be difficult to test for at this stage.
     conflicting old_fam_inst subst 
       | isAlgTyCon fam = True
-      | otherwise      = not (old_rhs `tcEqType` new_rhs)
+      | otherwise      = not (old_rhs `eqType` new_rhs)
       where
         old_tycon = famInstTyCon old_fam_inst
         old_tvs   = tyConTyVars old_tycon
@@ -439,35 +443,34 @@ topNormaliseType env ty
     go rec_nts ty | Just ty' <- coreView ty 	-- Expand synonyms
 	= go rec_nts ty'	
 
-    go rec_nts (TyConApp tc tys)		-- Expand newtypes
-	| Just co_con <- newTyConCo_maybe tc	-- See Note [Expanding newtypes]
-	= if tc `elem` rec_nts 			--  in Type.lhs
+    go rec_nts (TyConApp tc tys)
+        | isNewTyCon tc		-- Expand newtypes
+	= if tc `elem` rec_nts 	-- See Note [Expanding newtypes] in Type.lhs
 	  then Nothing
-	  else let nt_co = mkTyConApp co_con tys
-	       in add_co nt_co rec_nts' nt_rhs
-	where
-	  nt_rhs = newTyConInstRhs tc tys
-	  rec_nts' | isRecursiveTyCon tc = tc:rec_nts
-		   | otherwise		 = rec_nts
-
-    go rec_nts (TyConApp tc tys)		-- Expand open tycons
-	| isFamilyTyCon tc
-	, (ACo co, ty) <- normaliseTcApp env tc tys
-	= 	-- The ACo says "something happened"
-		-- Note that normaliseType fully normalises, but it has do to so
-		-- to be sure that 
-	   add_co co rec_nts ty
+          else let nt_co = mkAxInstCo (newTyConCo tc) tys
+               in add_co nt_co rec_nts' nt_rhs
+
+	| isFamilyTyCon tc		-- Expand open tycons
+	, (co, ty) <- normaliseTcApp env tc tys
+		-- Note that normaliseType fully normalises, 
+		-- but it has do to so to be sure that 
+        , not (isReflCo co)
+        = add_co co rec_nts ty
+        where
+          nt_rhs = newTyConInstRhs tc tys
+          rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+                   | otherwise           = rec_nts
 
     go _ _ = Nothing
 
     add_co co rec_nts ty 
 	= case go rec_nts ty of
 		Nothing 	-> Just (co, ty)
-		Just (co', ty') -> Just (mkTransCoercion co co', ty')
+		Just (co', ty') -> Just (mkTransCo co co', ty')
 	 
 
 ---------------
-normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
+normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type)
 normaliseTcApp env tc tys
   | isFamilyTyCon tc
   , tyConArity tc <= length tys	   -- Unsaturated data families are possible
@@ -475,29 +478,30 @@ normaliseTcApp env tc tys
   = let    -- A matching family instance exists
 	rep_tc         	= famInstTyCon fam_inst
 	co_tycon       	= expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
-	co	       	= mkTyConApp co_tycon inst_tys
-	first_coi      	= mkTransCoI tycon_coi (ACo co)
-	(rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
-	fix_coi         = mkTransCoI first_coi rest_coi
+	co              = mkAxInstCo co_tycon inst_tys
+	first_coi       = mkTransCo tycon_coi co
+	(rest_coi,nty)  = normaliseType env (mkTyConApp rep_tc inst_tys)
+	fix_coi         = mkTransCo first_coi rest_coi
     in 
     (fix_coi, nty)
 
-  | otherwise
+  | otherwise   -- No unique matching family instance exists;
+		-- we do not do anything
   = (tycon_coi, TyConApp tc ntys)
 
   where
 	-- Normalise the arg types so that they'll match 
 	-- when we lookup in in the instance envt
     (cois, ntys) = mapAndUnzip (normaliseType env) tys
-    tycon_coi    = mkTyConAppCoI tc cois
+    tycon_coi    = mkTyConAppCo tc cois
 
 ---------------
 normaliseType :: FamInstEnvs 		-- environment with family instances
 	      -> Type  			-- old type
-	      -> (CoercionI, Type)	-- (coercion,new type), where
+	      -> (Coercion, Type)	-- (coercion,new type), where
 					-- co :: old-type ~ new_type
 -- Normalise the input type, by eliminating *all* type-function redexes
--- Returns with IdCo if nothing happens
+-- Returns with Refl if nothing happens
 
 normaliseType env ty 
   | Just ty' <- coreView ty = normaliseType env ty' 
@@ -506,29 +510,29 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2)
+    in  (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
 normaliseType env (FunTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2)
+    in  (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
-    in  (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
+    in  (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
 normaliseType _   ty@(TyVarTy _)
-  = (IdCo ty,ty)
+  = (Refl ty,ty)
 normaliseType env (PredTy predty)
   = normalisePred env predty
 
 ---------------
-normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
+normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type)
 normalisePred env (ClassP cls tys)
-  =	let (cois,tys') = mapAndUnzip (normaliseType env) tys
-	in  (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
+  = let (cos,tys') = mapAndUnzip (normaliseType env) tys
+    in  (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys')
 normalisePred env (IParam ipn ty)
-  = 	let (coi,ty') = normaliseType env ty
-	in  (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
+  = let (co,ty') = normaliseType env ty
+    in  (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty')
 normalisePred env (EqPred ty1 ty2)
-  = 	let (coi1,ty1') = normaliseType env ty1
-            (coi2,ty2') = normaliseType env ty2
-	in  (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
+  = let (co1,ty1') = normaliseType env ty1
+        (co2,ty2') = normaliseType env ty2
+    in  (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2')
 \end{code}
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 6ce932b..f1c9347 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -271,8 +271,8 @@ improveFromAnother pred1@(ClassP cls1 tys1, _) pred2@(ClassP cls2 tys2, _)
     , fd <- cls_fds
     , let (ltys1, rs1)  = instFD         fd cls_tvs tys1
           (ltys2, irs2) = instFD_WithPos fd cls_tvs tys2
-    , tcEqTypes ltys1 ltys2		-- The LHSs match
-    , let eqs = zipAndComputeFDEqs tcEqType rs1 irs2
+    , eqTypes ltys1 ltys2		-- The LHSs match
+    , let eqs = zipAndComputeFDEqs eqType rs1 irs2
     , not (null eqs) ]
 
 improveFromAnother _ _ = []
@@ -386,7 +386,7 @@ checkClsFD qtvs fd clas_tvs tys1 tys2
                     fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2'
                         -- Don't discard anything! 
                         -- We could discard equal types but it's an overkill to call 
-                        -- tcEqType again, since we know for sure that /at least one/ 
+                        -- eqType again, since we know for sure that /at least one/ 
                         -- equation in there is useful)
 
 		    qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs
diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 604db8d..323da41 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -1,18 +1,12 @@
 %
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2011
 %
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module Generics ( canDoGenerics, mkTyConGenericBinds,
-		  mkGenericRhs, 
-		  validGenericInstanceType, validGenericMethodType
+
+module Generics ( canDoGenerics,
+		  mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
+		  MetaTyCons(..), metaTyCons2TyCons
     ) where
 
 
@@ -22,17 +16,20 @@ import TcType
 import DataCon
 
 import TyCon
-import Name
+import Name hiding (varName)
+import Module (moduleName, moduleNameString)
 import RdrName
 import BasicTypes
-import Var
-import VarSet
-import Id
 import TysWiredIn
 import PrelNames
-	
+
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad
+import HscTypes
+import BuildTyCl
+
 import SrcLoc
-import Util
 import Bag
 import Outputable 
 import FastString
@@ -40,185 +37,6 @@ import FastString
 #include "HsVersions.h"
 \end{code}
 
-Roadmap of what's where in the Generics work.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Parser
-No real checks.
-
-RnSource.rnHsType
-  Checks that HsNumTy has a "1" in it.
-
-TcInstDcls.mkGenericInstance:
-  Checks for invalid type patterns, such as f {| Int |}
-
-TcClassDcl.tcClassSig
-  Checks for a method type that is too complicated;
-	e.g. has for-alls or lists in it
-  We could lift this restriction
-
-TcClassDecl.mkDefMethRhs
-  Checks that the instance type is simple, in an instance decl 
-  where we let the compiler fill in a generic method.
-	e.g.  instance C (T Int)
-  	is not valid if C has generic methods.
-
-TcClassDecl.checkGenericClassIsUnary
-  Checks that we don't have generic methods in a multi-parameter class
-
-TcClassDecl.checkDefaultBinds
-  Checks that all the equations for a method in a class decl
-  are generic, or all are non-generic
-
-
-			
-Checking that the type constructors which are present in Generic
-patterns (not Unit, this is done differently) is done in mk_inst_info
-(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
-HsOpTy is tied to Generic definitions which is not a very good design
-feature, indeed a bug. However, the check is easy to move from
-tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5. [I don't think that this is the case anymore after SPJ's latest
-changes in that regard.  Delete this comment?  -=chak/7Jun2]
-
-Generics.lhs
-
-Making generic information to put into a tycon. Constructs the
-representation type, which, I think, are not used later. Perhaps it is
-worth removing them from the GI datatype. Although it does get used in
-the construction of conversion functions (internally).
-
-TyCon.lhs
-
-Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
-
-TysWiredIn.lhs
-
-Defines generic and other type and data constructors.
-
-This is sadly incomplete, but will be added to.
-
-
-Bugs & shortcomings of existing implementation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-2. Another pretty big bug I dscovered at the last minute when I was
-testing the code is that at the moment the type variable of the class
-is scoped over the entire declaration, including the patterns. For
-instance, if I have the following code,
-
-class Er a where
- ...
-  er {| Plus a b |} (Inl x) (Inl y) = er x y 
-  er {| Plus a b |} (Inr x) (Inr y) = er x y 
-  er {| Plus a b |} _ _ = False
- 
-and I print out the types of the generic patterns, I get the
-following.  Note that all the variable names for "a" are the same,
-while for "b" they are all different.
-
-check_ty
-    [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
-     std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
-     std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
-
-This is a bug as if I change the code to
-
- er {| Plus c b |} (Inl x)  (Inl y) = er x y 
-
-all the names come out to be different.
-
-Thus, all the types (Plus a b) come out to be different, so I cannot
-compare them and test whether they are all the same and thus cannot
-return an error if the type variables are different.
-
-Temporary fix/hack. I am not checking for this, I just assume they are
-the same, see line "check_ty = True" in TcInstDecls. When we resolve
-the issue with variables, though - I assume that we will make them to
-be the same in all the type patterns, jus uncomment the check and
-everything should work smoothly.
-
-Hence, I have also left the rather silly construction of:
-* extracting all the type variables from all the types
-* putting them *all* into the environment
-* typechecking all the types
-* selecting one of them and using it as the instance_ty.
-
-(the alternative is to make sure that all the types are the same,
-taking one, extracting its variables, putting them into the environment,
-type checking it, using it as the instance_ty)
- 
-6. What happens if we do not supply all of the generic patterns? At
-the moment, the compiler crashes with an error message "Non-exhaustive
-patterns in a generic declaration" 
-
-
-What has not been addressed:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Contexts. In the generated instance declarations for the 3 primitive
-type constructors, we need contexts. It is unclear what those should
-be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
-
-Type application. We have type application in expressions
-(essentially) on the lhs of an equation. Do we want to allow it on the
-RHS?
-
-Scoping of type variables in a generic definition. At the moment, (see
-TcInstDecls) we extract the type variables inside the type patterns
-and add them to the environment. See my bug #2 above. This seems pretty
-important.
-
-
-
-%************************************************************************
-%*									*
-\subsection{Getting the representation type out}
-%*									*
-%************************************************************************
-
-\begin{code}
-validGenericInstanceType :: Type -> Bool
-  -- Checks for validity of the type pattern in a generic
-  -- declaration.  It's ok to have  
-  --	f {| a + b |} ...
-  -- but it's not OK to have
-  --	f {| a + Int |}
-
-validGenericInstanceType inst_ty
-  = case tcSplitTyConApp_maybe inst_ty of
-	Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
-	Nothing		  ->  False
-
-validGenericMethodType :: Type -> Bool
-  -- At the moment we only allow method types built from
-  -- 	* type variables
-  --	* function arrow
-  --	* boxed tuples
-  --    * lists
-  --	* an arbitrary type not involving the class type variables
-  --		e.g. this is ok: 	forall b. Ord b => [b] -> a
-  --	             where a is the class variable
-validGenericMethodType ty 
-  = valid tau
-  where
-    (local_tvs, _, tau) = tcSplitSigmaTy ty
-
-    valid ty
-      | not (isTauTy ty) = False 	-- Note [Higher ramk methods]
-      | isTyVarTy ty     = True
-      | no_tyvars_in_ty	 = True
-      | otherwise	 = case tcSplitTyConApp_maybe ty of
-				Just (tc,tys) -> valid_tycon tc && all valid tys
-				Nothing	      -> False
-      where
-	no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-
-    valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc 
-	-- Compare bimapApp, below
-\end{code}
-
-
 %************************************************************************
 %*									*
 \subsection{Generating representation types}
@@ -226,25 +44,47 @@ validGenericMethodType ty
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
 -- Called on source-code data types, to see if we should generate
--- generic functions for them.  (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics data_cons
-  =  not (any bad_con data_cons) 	-- See comment below
-  && not (null data_cons)		-- No values of the type
+-- generic functions for them.
+-- Nothing == yes
+-- Just s  == no, because of `s`
+
+canDoGenerics tycon
+  =  mergeErrors (
+          -- We do not support datatypes with context
+              (if (not (null (tyConStupidTheta tycon)))
+                then (Just (ppr tycon <+> text "must not have a datatype context"))
+                else Nothing)
+          -- We don't like type families
+            : (if (isFamilyTyCon tycon)
+                then (Just (ppr tycon <+> text "must not be a family instance"))
+                else Nothing)
+          -- See comment below
+            : (map bad_con (tyConDataCons tycon)))
   where
-    bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
-  	-- If any of the constructor has an unboxed type as argument,
-	-- then we can't build the embedding-projection pair, because
-	-- it relies on instantiating *polymorphic* sum and product types
-	-- at the argument types of the constructors
+        -- If any of the constructor has an unboxed type as argument,
+        -- then we can't build the embedding-projection pair, because
+        -- it relies on instantiating *polymorphic* sum and product types
+        -- at the argument types of the constructors
+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+                  then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+                  else (if (not (isVanillaDataCon dc))
+                          then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+                          else Nothing)
+
 
 	-- Nor can we do the job if it's an existential data constructor,
 
 	-- Nor if the args are polymorphic types (I don't think)
     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+    
+    mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+    mergeErrors []           = Nothing
+    mergeErrors ((Just s):t) = case mergeErrors t of
+                                 Nothing -> Just s
+                                 Just s' -> Just (s <> text ", and" $$ s')
+    mergeErrors (Nothing :t) = mergeErrors t
 \end{code}
 
 %************************************************************************
@@ -255,320 +95,302 @@ canDoGenerics data_cons
 
 \begin{code}
 type US = Int	-- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
+type Alt = (LPat RdrName, LHsExpr RdrName)
 
-mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon
-  = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
-	`unionBags`
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon = 
+    unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+  `unionBags`
     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+      where
+        from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
+        loc           = srcLocSpan (getSrcLoc tycon)
+        datacons      = tyConDataCons tycon
+
+        -- Recurse over the sum first
+        from_alts, to_alts :: [Alt]
+        (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
+        
+--------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+--       type instance Rep (D a b) = Rep_D a b
+--       type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon           -- The type to generate representation for
+               -> MetaTyCons      -- Metadata datatypes to refer to
+               -> TcM TyCon       -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts = 
+-- Consider the example input tycon `D`, where data D a b = D_ a
+  do { -- `rep0` = GHC.Generics.Rep (type family)
+       rep0 <- tcLookupTyCon repTyConName
+
+       -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+     ; rep0Ty <- tc_mkRepTy tycon metaDts
+    
+       -- `rep_name` is a name we generate for the synonym
+     ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+     ; let -- `tyvars` = [a,b]
+           tyvars  = tyConTyVars tycon
+
+           -- rep0Ty has kind * -> *
+           rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+           -- `appT` = D a b
+           appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+     ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+                     NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRepTy :: -- The type to generate representation for
+               TyCon 
+               -- Metadata datatypes to refer to
+            -> MetaTyCons 
+               -- Generated representation0 type
+            -> TcM Type
+tc_mkRepTy tycon metaDts = 
+  do
+    d1    <- tcLookupTyCon d1TyConName
+    c1    <- tcLookupTyCon c1TyConName
+    s1    <- tcLookupTyCon s1TyConName
+    nS1   <- tcLookupTyCon noSelTyConName
+    rec0  <- tcLookupTyCon rec0TyConName
+    par0  <- tcLookupTyCon par0TyConName
+    u1    <- tcLookupTyCon u1TyConName
+    v1    <- tcLookupTyCon v1TyConName
+    plus  <- tcLookupTyCon sumTyConName
+    times <- tcLookupTyCon prodTyConName
+    
+    let mkSum' a b = mkTyConApp plus  [a,b]
+        mkProd a b = mkTyConApp times [a,b]
+        mkRec0 a   = mkTyConApp rec0  [a]
+        mkPar0 a   = mkTyConApp par0  [a]
+        mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a) 
+                                                 (null (dataConFieldLabels a))]
+        -- This field has no label
+        mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+        -- This field has a  label
+        mkS False d a = mkTyConApp s1 [d, a]
+        
+        sumP [] = mkTyConTy v1
+        sumP l  = ASSERT (length metaCTyCons == length l)
+                    foldBal mkSum' [ mkC i d a
+                                   | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+        -- The Bool is True if this constructor has labelled fields
+        prod :: Int -> [Type] -> Bool -> Type
+        prod i [] _ = ASSERT (length metaSTyCons > i)
+                        ASSERT (length (metaSTyCons !! i) == 0)
+                          mkTyConTy u1
+        prod i l b  = ASSERT (length metaSTyCons > i)
+                        ASSERT (length l == length (metaSTyCons !! i))
+                          foldBal mkProd [ arg d t b
+                                         | (d,t) <- zip (metaSTyCons !! i) l ]
+        
+        arg :: Type -> Type -> Bool -> Type
+        arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+        -- Argument is not a type variable, use Rec0
+        recOrPar t Nothing  = mkRec0 t
+        -- Argument is a type variable, use Par0
+        recOrPar t (Just _) = mkPar0 t
+        
+        metaDTyCon  = mkTyConTy (metaD metaDts)
+        metaCTyCons = map mkTyConTy (metaC metaDts)
+        metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+        
+    return (mkD tycon)
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+                               metaD :: TyCon
+                               -- One meta datatype per constructor
+                             , metaC :: [TyCon]
+                               -- One meta datatype per selector per constructor
+                             , metaS :: [[TyCon]] }
+                             
+instance Outputable MetaTyCons where
+  ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
+                                   
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon 
+             -> ( LHsBinds RdrName      -- Datatype instance
+                , [LHsBinds RdrName]    -- Constructor instances
+                , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+      where
+        mkBag l = foldr1 unionBags 
+                    [ unitBag (L loc (mkFunBind (L loc name) matches)) 
+                        | (name, matches) <- l ]
+        dtBinds       = mkBag [ (datatypeName_RDR, dtName_matches)
+                              , (moduleName_RDR, moduleName_matches)]
+
+        allConBinds   = map conBinds datacons
+        conBinds c    = mkBag ( [ (conName_RDR, conName_matches c)]
+                              ++ ifElseEmpty (dataConIsInfix c)
+                                   [ (conFixity_RDR, conFixity_matches c) ]
+                              ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+                                   [ (conIsRecord_RDR, conIsRecord_matches c) ]
+                              )
+
+        ifElseEmpty p x = if p then x else []
+        fixity c      = case lookupFixity fix_env (dataConName c) of
+                          Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+                          Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+                          Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+        buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+                                                     , nlHsIntLit (toInteger n)]
+
+        allSelBinds   = map (map selBinds) datasels
+        selBinds s    = mkBag [(selName_RDR, selName_matches s)]
+
+        loc           = srcLocSpan (getSrcLoc tycon)
+        mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+        datacons      = tyConDataCons tycon
+        datasels      = map dataConFieldLabels datacons
+
+        dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName 
+                           $ tycon
+        moduleName_matches = mkStringLHS . moduleNameString . moduleName 
+                           . nameModule . tyConName $ tycon
+
+        conName_matches     c = mkStringLHS . showPpr . nameOccName
+                              . dataConName $ c
+        conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
+        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+        selName_matches     s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: US          -- Base for generating unique names
+      -> TyCon       -- The type constructor
+      -> [DataCon]   -- The data constructors
+      -> ([Alt],     -- Alternatives for the T->Trep "from" function
+          [Alt])     -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _us tycon [] = ([from_alt], [to_alt])
+  where
+    from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
+    to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
+               -- These M1s are meta-information for the datatype
+    makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
+    errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
+    errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+  unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: US        -- Base for generating unique names
+       -> Int       -- The index of this constructor
+       -> Int       -- Total number of constructors
+       -> DataCon   -- The data constructor
+       -> (Alt,     -- Alternative for the T->Trep "from" function
+           Alt)     -- Alternative for the Trep->T "to" function
+mk1Sum us i n datacon = (from_alt, to_alt)
   where
-    from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
-    to_matches   = [mkSimpleHsAlt to_pat to_body]
-    loc	     = srcLocSpan (getSrcLoc tycon)
-    datacons = tyConDataCons tycon
-    (from_RDR, to_RDR) = mkGenericNames tycon
-
-    -- Recurse over the sum first
-    from_alts :: [FromAlt]
-    (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
-    init_us = 1::Int		-- Unique supply
-
-----------------------------------------------------
---	Dealing with sums
-----------------------------------------------------
-
-mk_sum_stuff :: US 			-- Base for generating unique names
-	     -> [DataCon]	 	-- The data constructors
-	     -> ([FromAlt],				-- Alternatives for the T->Trep "from" function
-		 InPat RdrName, LHsExpr RdrName)	-- Arg and body of the Trep->T "to" function
-
--- For example, given
---	data T = C | D Int Int Int
--- 
--- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
---			   case cd of { Inl u -> C; 
---  					Inr abc -> case abc of { a :*: bc ->
---						   case bc  of { b :*: c ->
---						   D a b c }} },
---			   cd)
-
-mk_sum_stuff us [datacon]
-   = ([from_alt], to_pat, to_body_fn app_exp)
-   where
-     n_args = dataConSourceArity datacon	-- Existentials already excluded
-
-     datacon_vars = map mkGenericLocal [us .. us+n_args-1]
-     us'          = us + n_args
-
-     datacon_rdr  = getRdrName datacon
-     app_exp      = nlHsVarApps datacon_rdr datacon_vars
-     from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-
-     (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
-
-mk_sum_stuff us datacons
-  = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
-     nlVarPat to_arg,
-     noLoc (HsCase (nlHsVar to_arg) 
-	    (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
-			   mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
+    n_args = dataConSourceArity datacon	-- Existentials already excluded
+
+    datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+    us'          = us + n_args
+
+    datacon_rdr  = getRdrName datacon
+    app_exp      = nlHsVarApps datacon_rdr datacon_vars
+    
+    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+    from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
+    
+    to_alt     = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+                 -- These M1s are meta-information for the datatype
+    to_alt_rhs = app_exp
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
+genLR_P i n p
+  | n == 0       = error "impossible"
+  | n == 1       = p
+  | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+                     where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
+genLR_E i n e
+  | n == 0       = error "impossible"
+  | n == 1       = e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i     (div n 2) e
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m)     e
+                     where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: US	            -- Base for unique names
+	 -> [RdrName]       -- List of variables matched on the lhs
+	 -> LHsExpr RdrName -- Resulting product expression
+mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E _ vars = mkM1_E (foldBal prod appVars)
+                   -- These M1s are meta-information for the constructor
   where
-    (l_datacons, r_datacons)		= splitInHalf datacons
-    (l_from_alts, l_to_pat, l_to_body)	= mk_sum_stuff us' l_datacons
-    (r_from_alts, r_to_pat, r_to_body)	= mk_sum_stuff us' r_datacons
-
-    to_arg = mkGenericLocal us
-    us'	   = us+1
-
-    wrap :: RdrName -> [FromAlt] -> [FromAlt]
-	-- Wrap an application of the Inl or Inr constructor round each alternative
-    wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
-
-
-----------------------------------------------------
---	Dealing with products
-----------------------------------------------------
-mk_prod_stuff :: US			-- Base for unique names
-	      -> [RdrName]		-- arg-ids; args of the original user-defined constructor
-					-- 	They are bound enclosing from_rhs
-					-- 	Please bind these in the to_body_fn 
-	      -> (US,			-- Depleted unique-name supply
-		  LHsExpr RdrName, 			-- from-rhs: puts together the representation from the arg_ids
-		  InPat RdrName,			-- to_pat: 
-		  LHsExpr RdrName -> LHsExpr RdrName)	-- to_body_fn: takes apart the representation
-
--- For example:
--- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
---				 abc,
---			         \<body-code> -> case abc of { a :*: bc ->
---				 	         case bc  of { b :*: c  -> 
---					         <body-code> )
-
--- We need to use different uniques in the branches 
--- because the returned to_body_fns are nested.  
--- Hence the returned unqique-name supply
-
-mk_prod_stuff us []		-- Unit case
-  = (us+1,
-     nlHsVar genUnitDataCon_RDR,
-     noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) 
-	    	     (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
-	-- Give a signature to the pattern so we get 
-	--	data S a = Nil | S a
-	--	toS = \x -> case x of { Inl (g :: Unit) -> Nil
-	--				Inr x -> S x }
-	-- The (:: Unit) signature ensures that we'll infer the right
-	-- type for toS. If we leave it out, the type is too polymorphic
-
-     \x -> x)
-
-mk_prod_stuff us [arg_var]	-- Singleton case
-  = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
-
-mk_prod_stuff us arg_vars	-- Two or more
-  = (us'', 
-     nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
-     nlVarPat to_arg, 
--- gaw 2004 FIX?
-     \x -> noLoc (HsCase (nlHsVar to_arg) 
-		  (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
+    appVars = map wrapArg_E vars
+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: RdrName -> LHsExpr RdrName
+wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
+              -- This M1 is meta-information for the selector
+
+-- Build a product pattern
+mkProd_P :: US		        -- Base for unique names
+	       -> [RdrName]     -- List of variables to match
+	       -> LPat RdrName  -- Resulting product pattern
+mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P _ vars = mkM1_P (foldBal prod appVars)
+                   -- These M1s are meta-information for the constructor
   where
-    to_arg = mkGenericLocal us
-    (l_arg_vars, r_arg_vars) 		      = splitInHalf arg_vars
-    (us',  l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1)  l_arg_vars
-    (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
-    pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
-
-splitInHalf :: [a] -> ([a],[a])
-splitInHalf list = (left, right)
-		 where
-		   half  = length list `div` 2
-		   left  = take half list
-		   right = drop half list
+    appVars = map wrapArg_P vars
+    prod a b = prodDataCon_RDR `nlConPat` [a,b]
+    
+wrapArg_P :: RdrName -> LPat RdrName
+wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+              -- This M1 is meta-information for the selector
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 
-mkGenericNames :: TyCon -> (RdrName, RdrName)
-mkGenericNames tycon
-  = (from_RDR, to_RDR)
-  where
-    tc_name  = tyConName tycon
-    tc_occ   = nameOccName tc_name
-    tc_mod   = ASSERT( isExternalName tc_name ) nameModule tc_name
-    from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
-    to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Generating the RHS of a generic default method}
-%*									*
-%************************************************************************
-
-Generating the Generic default method.  Uses the bimaps to generate the
-actual method. All of this is rather incomplete, but it would be nice
-to make even this work.  Example
-
- 	class Foo a where
-	  op :: Op a
-
-	instance Foo T
-
-Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
-
-	instance Foo T where
-	   op = <mkGenericRhs op a T>
-
-To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
-
-	toOp   :: Op Trep -> Op T
-	fromOp :: Op T    -> Op Trep
-
-(the bimap) and then fill in the RHS with
-
-	instance Foo T where
-	   op = toOp op
-
-Remember, we're generating a RenamedHsExpr, so the result of all this
-will be fed to the type checker.  So the 'op' on the RHS will be 
-at the representation type for T, Trep.
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
 
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the class op is polymorphic:
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
 
-	class Baz a where
-	  op :: forall b. Ord b => a -> b -> b
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _  x []  = x
+foldBal' _  _ [y] = y
+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
+                    in foldBal' op x a `op` foldBal' op x b
 
-Then we can still generate a bimap with
-
-	toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
-
-and fill in the instance decl thus
-
-	instance Foo T where
-	   op = toOp op
-
-By the time the type checker has done its stuff we'll get
-
-	instance Foo T where
-	   op = \b. \dict::Ord b. toOp b (op Trep b dict)
-
-Note [Higher rank methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Higher-rank method types don't work, because we'd generate a bimap that
-needs impredicative polymorphism.  In principle that should be possible
-(with boxy types and all) but it would take a bit of working out.   Here's
-an example:
-  class ChurchEncode k where 
-    match :: k -> z 
-       	  -> (forall a b z. a -> b -> z)  {- product -} 
-       	  -> (forall a   z. a -> z)       {- left -} 
-       	  -> (forall a   z. a -> z)       {- right -} 
-       	  -> z 
-  
-    match {| Unit    |} Unit      unit prod left right = unit 
-    match {| a :*: b |} (x :*: y) unit prod left right = prod x y 
-    match {| a :+: b |} (Inl l)   unit prod left right = left l 
-    match {| a :+: b |} (Inr r)   unit prod left right = right r 
-
-\begin{code}
-mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
-mkGenericRhs sel_id tyvar tycon
-  = ASSERT( isSingleton ctxt ) 	-- Checks shape of selector-id context
---    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
-    mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
-  where 
-	-- Initialising the "Environment" with the from/to functions
-	-- on the datatype (actually tycon) in question
-	(from_RDR, to_RDR) = mkGenericNames tycon 
-
-        -- Instantiate the selector type, and strip off its class context
-	(ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
-
-        -- Do it again!  This deals with the case where the method type 
-	-- is polymorphic -- see Note [Polymorphic methods] above
-	(local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-
-	-- Now we probably have a tycon in front
-        -- of us, quite probably a FunTyCon.
-        ep    = EP (nlHsVar from_RDR) (nlHsVar to_RDR) 
-        bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
-
-type EPEnv = (TyVar,			-- The class type variable
-	      EP (LHsExpr RdrName),	-- The EP it maps to
-	      [TyVar]			-- Other in-scope tyvars; they have an identity EP
-	     )
-
--------------------
-generate_bimap :: EPEnv
-	       -> Type
-	       -> EP (LHsExpr RdrName)
--- Top level case - splitting the TyCon.
-generate_bimap env@(tv,ep,local_tvs) ty 
-  | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-  = idEP	-- A constant type
-
-  | Just tv1 <- getTyVar_maybe ty
-  = ASSERT( tv == tv1 ) ep					-- The class tyvar
-
-  | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
-  = bimapTyCon tycon (map (generate_bimap env) ty_args)
-
-  | otherwise
-  = pprPanic "generate_bimap" (ppr ty)
-
--------------------
-bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTyCon tycon arg_eps 
-  | tycon == funTyCon       = bimapArrow arg_eps
-  | tycon == listTyCon      = bimapList arg_eps
-  | isBoxedTupleTyCon tycon = bimapTuple arg_eps
-  | otherwise		    = pprPanic "bimapTyCon" (ppr tycon)
-
--------------------
--- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
-bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapArrow [ep1, ep2]
-  = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, 
-	 toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
-  where
-    from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP   ep1 `mkHsApp` nlHsVar b_RDR))
-    to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
-
--------------------
--- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
-bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTuple eps 
-  = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
-	 toEP   = mkHsLam [noLoc tuple_pat] to_body }
-  where
-    names	= takeList eps gs_RDR
-    tuple_pat	= TuplePat (map nlVarPat names) Boxed placeHolderType
-    eps_w_names = eps `zip` names
-    to_body     = mkLHsTupleExpr [toEP   ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-    from_body   = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-
--------------------
--- bimapList :: EP a b -> EP [a] [b]
-bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapList [ep]
-  = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
-	 toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
-
--------------------
-a_RDR, b_RDR :: RdrName
-a_RDR	= mkVarUnqual (fsLit "a")
-b_RDR	= mkVarUnqual (fsLit "b")
-
-gs_RDR :: [RdrName]
-gs_RDR	= [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
-
-idEP :: EP (LHsExpr RdrName)
-idEP = EP idexpr idexpr
-     where
-       idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
 \end{code}
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 07f68f7..7a2a65e 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -119,7 +119,7 @@ instanceDFunId = is_dfun
 
 setInstanceDFunId :: Instance -> DFunId -> Instance
 setInstanceDFunId ispec dfun
-   = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
+   = ASSERT( idType dfun `eqType` idType (is_dfun ispec) )
 	-- We need to create the cached fields afresh from
 	-- the new dfun id.  In particular, the is_tvs in
 	-- the Instance must match those in the dfun!
@@ -156,7 +156,7 @@ pprInstanceHdr ispec@(Instance { is_flag = flag })
           | debugStyle sty = theta
           | otherwise = drop (dfunNSilent dfun) theta
     in ptext (sLit "instance") <+> ppr flag
-       <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
+       <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
   where
     dfun = is_dfun ispec
     (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
new file mode 100644
index 0000000..32a9eac
--- /dev/null
+++ b/compiler/types/Kind.lhs
@@ -0,0 +1,238 @@
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module Kind (
+        -- * Main data type
+        Kind, typeKind,
+
+	-- Kinds
+	liftedTypeKind, unliftedTypeKind, openTypeKind,
+        argTypeKind, ubxTupleKind,
+        mkArrowKind, mkArrowKinds,
+
+        -- Kind constructors...
+        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+        argTypeKindTyCon, ubxTupleKindTyCon,
+        ecKind,
+
+        -- Super Kinds
+	tySuperKind, tySuperKindTyCon, 
+        
+	pprKind, pprParendKind,
+
+        -- ** Deconstructing Kinds
+        kindFunResult, kindAppResult, synTyConResKind,
+        splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
+
+        -- ** Predicates on Kinds
+        isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+        isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, 
+        isSuperKind, isCoercionKind, 
+        isLiftedTypeKindCon,
+
+        isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
+        isSubKindCon,
+
+       ) where
+
+#include "HsVersions.h"
+
+import TypeRep
+import TysPrim
+import TyCon
+import Var
+import PrelNames
+import Outputable
+\end{code}
+
+%************************************************************************
+%*									*
+        Predicates over Kinds
+%*									*
+%************************************************************************
+
+\begin{code}
+isTySuperKind :: SuperKind -> Bool
+isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
+isTySuperKind _                = False
+
+-------------------
+-- Lastly we need a few functions on Kinds
+
+isLiftedTypeKindCon :: TyCon -> Bool
+isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
+\end{code}
+
+%************************************************************************
+%*									*
+        The kind of a type
+%*									*
+%************************************************************************
+
+\begin{code}
+typeKind :: Type -> Kind
+typeKind _ty@(TyConApp tc tys) 
+  = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty )
+    	     -- Assertion checks for unsaturated application of (~)
+	     -- See Note [The (~) TyCon] in TysPrim
+    kindAppResult (tyConKind tc) tys
+
+typeKind (PredTy pred)	      = predKind pred
+typeKind (AppTy fun _)        = kindFunResult (typeKind fun)
+typeKind (ForAllTy _ ty)      = typeKind ty
+typeKind (TyVarTy tyvar)      = tyVarKind tyvar
+typeKind (FunTy _arg res)
+    -- Hack alert.  The kind of (Int -> Int#) is liftedTypeKind (*), 
+    --              not unliftedTypKind (#)
+    -- The only things that can be after a function arrow are
+    --   (a) types (of kind openTypeKind or its sub-kinds)
+    --   (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
+    | isTySuperKind k         = k
+    | otherwise               = ASSERT( isSubOpenTypeKind k) liftedTypeKind 
+    where
+      k = typeKind res
+
+------------------
+predKind :: PredType -> Kind
+predKind (EqPred {}) = unliftedTypeKind	-- Coercions are unlifted
+predKind (ClassP {}) = liftedTypeKind	-- Class and implicitPredicates are
+predKind (IParam {}) = liftedTypeKind 	-- always represented by lifted types
+\end{code}
+
+%************************************************************************
+%*									*
+	Functions over Kinds		
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | Essentially 'funResultTy' on kinds
+kindFunResult :: Kind -> Kind
+kindFunResult (FunTy _ res) = res
+kindFunResult k = pprPanic "kindFunResult" (ppr k)
+
+kindAppResult :: Kind -> [arg] -> Kind
+kindAppResult k []     = k
+kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+
+-- | Essentially 'splitFunTys' on kinds
+splitKindFunTys :: Kind -> ([Kind],Kind)
+splitKindFunTys (FunTy a r) = case splitKindFunTys r of
+                              (as, k) -> (a:as, k)
+splitKindFunTys k = ([], k)
+
+splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
+splitKindFunTy_maybe (FunTy a r) = Just (a,r)
+splitKindFunTy_maybe _           = Nothing
+
+-- | Essentially 'splitFunTysN' on kinds
+splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
+splitKindFunTysN 0 k           = ([], k)
+splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of
+                                   (as, k) -> (a:as, k)
+splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
+
+-- | Find the result 'Kind' of a type synonym, 
+-- after applying it to its 'arity' number of type variables
+-- Actually this function works fine on data types too, 
+-- but they'd always return '*', so we never need to ask
+synTyConResKind :: TyCon -> Kind
+synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
+isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
+        isUnliftedTypeKindCon, isSubArgTypeKindCon      :: TyCon -> Bool
+
+isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey
+
+isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
+isOpenTypeKind _               = False
+
+isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
+
+isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
+isUbxTupleKind _               = False
+
+isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
+
+isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
+isArgTypeKind _               = False
+
+isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
+
+isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
+isUnliftedTypeKind _               = False
+
+isSubOpenTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
+isSubOpenTypeKind (FunTy k1 k2)    = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) 
+                                     ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) 
+                                     False
+isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
+isSubOpenTypeKind other            = ASSERT( isKind other ) False
+         -- This is a conservative answer
+         -- It matters in the call to isSubKind in
+	 -- checkExpectedKind.
+
+isSubArgTypeKindCon kc
+  | isUnliftedTypeKindCon kc = True
+  | isLiftedTypeKindCon kc   = True
+  | isArgTypeKindCon kc      = True
+  | otherwise                = False
+
+isSubArgTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of ArgTypeKind 
+isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
+isSubArgTypeKind _                = False
+
+-- | Is this a super-kind (i.e. a type-of-kinds)?
+isSuperKind :: Type -> Bool
+isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
+isSuperKind _                   = False
+
+-- | Is this a kind (i.e. a type-of-types)?
+isKind :: Kind -> Bool
+isKind k = isSuperKind (typeKind k)
+
+isSubKind :: Kind -> Kind -> Bool
+-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
+isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
+isSubKind (FunTy a1 r1) (FunTy a2 r2)	      = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind _             _                     = False
+
+isSubKindCon :: TyCon -> TyCon -> Bool
+-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
+isSubKindCon kc1 kc2
+  | isLiftedTypeKindCon kc1   && isLiftedTypeKindCon kc2   = True
+  | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
+  | isUbxTupleKindCon kc1     && isUbxTupleKindCon kc2     = True
+  | isOpenTypeKindCon kc2                                  = True 
+                           -- we already know kc1 is not a fun, its a TyCon
+  | isArgTypeKindCon kc2      && isSubArgTypeKindCon kc1   = True
+  | otherwise                                              = False
+
+defaultKind :: Kind -> Kind
+-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
+-- information on what that means
+
+-- When we generalise, we make generic type variables whose kind is
+-- simple (* or *->* etc).  So generic type variables (other than
+-- built-in constants like 'error') always have simple kinds.  This is important;
+-- consider
+--	f x = True
+-- We want f to get type
+--	f :: forall (a::*). a -> Bool
+-- Not 
+--	f :: forall (a::??). a -> Bool
+-- because that would allow a call like (f 3#) as well as (f True),
+--and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
+defaultKind k 
+  | isSubOpenTypeKind k = liftedTypeKind
+  | isSubArgTypeKind k  = liftedTypeKind
+  | otherwise        = k
+
+ecKind           = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
+\end{code}
\ No newline at end of file
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index 26f3295..eef1ccf 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -1,456 +1,372 @@
-%
-% (c) The University of Glasgow 2006
-%
-
-\begin{code}
-{-# OPTIONS_GHC -w #-}
-module OptCoercion (
-	optCoercion
-   ) where 
-
-#include "HsVersions.h"
-
-import Unify	( tcMatchTy )
-import Coercion
-import Type
-import TypeRep
-import TyCon
-import Var
-import VarSet
-import VarEnv
-import PrelNames
-import StaticFlags	( opt_NoOptCoercion )
-import Util
-import Outputable
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-                 Optimising coercions									
-%*                                                                      *
-%************************************************************************
-
-Note [Subtle shadowing in coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Supose we optimising a coercion
-    optCoercion (forall (co_X5:t1~t2). ...co_B1...)
-The co_X5 is a wild-card; the bound variable of a coercion for-all
-should never appear in the body of the forall. Indeed we often
-write it like this
-    optCoercion ( (t1~t2) => ...co_B1... )
-
-Just because it's a wild-card doesn't mean we are free to choose
-whatever variable we like.  For example it'd be wrong for optCoercion
-to return
-   forall (co_B1:t1~t2). ...co_B1...
-because now the co_B1 (which is really free) has been captured, and
-subsequent substitutions will go wrong.  That's why we can't use
-mkCoPredTy in the ForAll case, where this note appears.  
-
-\begin{code}
-optCoercion :: TvSubst -> Coercion -> NormalCo
--- ^ optCoercion applies a substitution to a coercion, 
---   *and* optimises it to reduce its size
-optCoercion env co 
-  | opt_NoOptCoercion = substTy env co
-  | otherwise         = opt_co env False co
-
-type NormalCo = Coercion
-  -- Invariants: 
-  --  * The substitution has been fully applied
-  --  * For trans coercions (co1 `trans` co2)
-  --       co1 is not a trans, and neither co1 nor co2 is identity
-  --  * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)
-
-type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity
-
-opt_co, opt_co' :: TvSubst
-       		-> Bool	       -- True <=> return (sym co)
-       		-> Coercion
-       		-> NormalCo	
-opt_co = opt_co'
-
-{-    Debuggery 
-opt_co env sym co 
--- = pprTrace "opt_co {" (ppr sym <+> ppr co) $
---     	        co1 `seq` 
---               pprTrace "opt_co done }" (ppr co1) 
---               WARN( not same_co_kind, ppr co  <+> dcolon <+> pprEqPred (s1,t1) 
---                                   $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) )
- =   WARN( not (coreEqType co1 simple_result), 
-           (text "env=" <+> ppr env) $$
-           (text "input=" <+> ppr co) $$
-           (text "simple=" <+> ppr simple_result) $$
-           (text "opt=" <+> ppr co1) )
-     co1
- where
-   co1 = opt_co' env sym co
-   same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2
-   (s,t) = coercionKind (substTy env co)
-   (s1,t1) | sym = (t,s)
-           | otherwise = (s,t)
-   (s2,t2) = coercionKind co1
-
-   simple_result | sym = mkSymCoercion (substTy env co)
-                 | otherwise = substTy env co
--}
-
-opt_co' env sym (AppTy ty1 ty2) 	  = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (FunTy ty1 ty2) 	  = FunTy (opt_co env sym ty1) (opt_co env sym ty2)
-opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys))
-opt_co' env sym (PredTy (IParam n ty))    = PredTy (IParam n (opt_co env sym ty))
-opt_co' _   _   co@(PredTy (EqPred {}))   = pprPanic "optCoercion" (ppr co)
-
-opt_co' env sym co@(TyVarTy tv)
-  | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty
-  | not (isCoVar tv)     = co   -- Identity; does not mention a CoVar
-  | ty1 `coreEqType` ty2 = ty1	-- Identity; ..ditto..
-  | not sym              = co
-  | otherwise            = mkSymCoercion co
-  where
-    (ty1,ty2) = coVarKind tv
-
-opt_co' env sym (ForAllTy tv cor) 
-  | isTyVar tv  = case substTyVarBndr env tv of
-                   (env', tv') -> ForAllTy tv' (opt_co' env' sym cor)
-
-opt_co' env sym co@(ForAllTy co_var cor) 
-  | isCoVar co_var 
-  = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co )
-    ForAllTy co_var' cor'
-  where
-    (co1,co2) = coVarKind co_var
-    co1' = opt_co' env sym co1
-    co2' = opt_co' env sym co2
-    cor' = opt_co' env sym cor
-    co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2'))
-    -- See Note [Subtle shadowing in coercions]
-
-opt_co' env sym (TyConApp tc cos)
-  | Just (arity, desc) <- isCoercionTyCon_maybe tc
-  = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos))
-             (map (opt_co env sym) (drop arity cos))
-  | otherwise
-  = TyConApp tc (map (opt_co env sym) cos)
-
---------
-opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo
--- Used for CoercionTyCons only
--- Arguments are *not* already simplified/substituted
-opt_co_tc_app env sym tc desc cos
-  = case desc of
-      CoAxiom {} -- Do *not* push sym inside top-level axioms
-    		 -- e.g. if g is a top-level axiom
-    		 --   g a : F a ~ a
-		 -- Then (sym (g ty)) /= g (sym ty) !!
-        | sym       -> mkSymCoercion the_co  
-        | otherwise -> the_co
-        where
-           the_co = TyConApp tc (map (opt_co env False) cos)
-           -- Note that the_co does *not* have sym pushed into it
-    
-      CoTrans 
-        | sym       -> opt_trans opt_co2 opt_co1   -- sym (g `o` h) = sym h `o` sym g
-        | otherwise -> opt_trans opt_co1 opt_co2
-
-      CoUnsafe
-        | sym       -> mkUnsafeCoercion ty2' ty1'
-        | otherwise -> mkUnsafeCoercion ty1' ty2'
-
-      CoSym   -> opt_co env (not sym) co1
-      CoLeft  -> opt_lr fst
-      CoRight -> opt_lr snd
-      CoCsel1 -> opt_csel fstOf3
-      CoCsel2 -> opt_csel sndOf3
-      CoCselR -> opt_csel thirdOf3
-
-      CoInst        -- See if the first arg is already a forall
-		    -- ...then we can just extend the current substitution
-        | Just (tv, co1_body) <- splitForAllTy_maybe co1
-        -> opt_co (extendTvSubst env tv ty2') sym co1_body
-
-                    -- See if is *now* a forall
-        | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1
-        -> substTyWith [tv] [ty2'] opt_co1_body	-- An inefficient one-variable substitution
-
-        | otherwise
-        -> TyConApp tc [opt_co1, ty2']
-
-  where
-    (co1 : cos1) = cos
-    (co2 : _)    = cos1
-
-    ty1' = substTy env co1
-    ty2' = substTy env co2
-
-	-- These opt_cos have the sym pushed into them
-    opt_co1 = opt_co env sym co1
-    opt_co2 = opt_co env sym co2
-
-    the_unary_opt_co = TyConApp tc [opt_co1]
-
-    opt_lr   sel = case splitAppTy_maybe opt_co1 of
-                     Nothing -> the_unary_opt_co 
-                     Just lr -> sel lr
-    opt_csel sel = case splitCoPredTy_maybe opt_co1 of
-                     Nothing -> the_unary_opt_co 
-                     Just lr -> sel lr
-
--------------
-opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transL = zipWith opt_trans
-
-opt_trans :: NormalCo -> NormalCo -> NormalCo
-opt_trans co1 co2
-  | isIdNormCo co1 = co2
-  | otherwise      = opt_trans1 co1 co2
-
-opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
--- First arg is not the identity
-opt_trans1 co1 co2
-  | isIdNormCo co2 = co1
-  | otherwise      = opt_trans2 co1 co2
-
-opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
--- Neither arg is the identity
-opt_trans2 (TyConApp tc [co1a,co1b]) co2
-  | tc `hasKey` transCoercionTyConKey
-  = opt_trans1 co1a (opt_trans2 co1b co2)
-
-opt_trans2 co1 co2 
-  | Just co <- opt_trans_rule co1 co2
-  = co
-
-opt_trans2 co1 (TyConApp tc [co2a,co2b])
-  | tc `hasKey` transCoercionTyConKey
-  , Just co1_2a <- opt_trans_rule co1 co2a
-  = if isIdNormCo co1_2a
-    then co2b
-    else opt_trans2 co1_2a co2b
-
-opt_trans2 co1 co2
-  = mkTransCoercion co1 co2
-
-------
-opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
-opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2)
-  | tc1 == tc2
-  = case isCoercionTyCon_maybe tc1 of
-      Nothing 
-        -> Just (TyConApp tc1 (opt_transL args1 args2))
-      Just (arity, desc) 
-        | arity == length args1
-        -> opt_trans_rule_equal_tc desc args1 args2
-        | otherwise
-        -> case opt_trans_rule_equal_tc desc 
-                         (take arity args1) 
-                         (take arity args2) of
-              Just co -> Just $ mkAppTys co $ 
-                         opt_transL (drop arity args1) (drop arity args2)
-	      Nothing -> Nothing 
- 
--- Push transitivity inside apply
-opt_trans_rule co1 co2
-  | Just (co1a, co1b) <- splitAppTy_maybe co1
-  , Just (co2a, co2b) <- etaApp_maybe co2
-  = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
-
-  | Just (co2a, co2b) <- splitAppTy_maybe co2
-  , Just (co1a, co1b) <- etaApp_maybe co1
-  = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))
-
--- Push transitivity inside (s~t)=>r
--- We re-use the CoVar rather than using mkCoPredTy
--- See Note [Subtle shadowing in coercions]
-opt_trans_rule co1 co2
-  | Just (cv1,r1) <- splitForAllTy_maybe co1
-  , isCoVar cv1
-  , Just (s1,t1) <- coVarKind_maybe cv1
-  , Just (s2,t2,r2) <- etaCoPred_maybe co2
-  = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
-                   (opt_trans r1 r2))
-
-  | Just (cv2,r2) <- splitForAllTy_maybe co2
-  , isCoVar cv2
-  , Just (s2,t2) <- coVarKind_maybe cv2
-  , Just (s1,t1,r1) <- etaCoPred_maybe co1
-  = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))
-                   (opt_trans r1 r2))
-
--- Push transitivity inside forall
-opt_trans_rule co1 co2
-  | Just (tv1,r1) <- splitTypeForAll_maybe co1
-  , Just (tv2,r2) <- etaForAll_maybe co2
-  , let r2' = substTyWith [tv2] [TyVarTy tv1] r2
-  = Just (ForAllTy tv1 (opt_trans2 r1 r2'))
-
-  | Just (tv2,r2) <- splitTypeForAll_maybe co2
-  , Just (tv1,r1) <- etaForAll_maybe co1
-  , let r1' = substTyWith [tv1] [TyVarTy tv2] r1
-  = Just (ForAllTy tv1 (opt_trans2 r1' r2))
-
-opt_trans_rule co1 co2
-{- 	Omitting for now, because unsound
-  | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe
-  , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe
-  , ax_tc1 == ax_tc2
-  , sym1 /= sym2
-  = Just $
-    if sym1 
-    then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs
-    else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs
--}
-
-  | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe
-  , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2
-  = Just $ 
-    if sym 
-    then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args)
-    else                 TyConApp ax_tc (opt_transL ax_args cos)
-
-  | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2
-  , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1
-  = Just $ 
-    if sym 
-    then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos))
-    else                 TyConApp ax_tc (opt_transL cos ax_args)
-  where
-    co1_is_axiom_maybe = isAxiom_maybe co1
-    co2_is_axiom_maybe = isAxiom_maybe co2
-
-opt_trans_rule co1 co2	-- Identity rule
-  | (ty1,_) <- coercionKind co1
-  , (_,ty2) <- coercionKind co2
-  , ty1 `coreEqType` ty2
-  = Just ty2
-
-opt_trans_rule _ _ = Nothing
-
------------  
-isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type))
-isAxiom_maybe co
-  | Just (tc, args) <- splitTyConApp_maybe co
-  , Just (_, desc)  <- isCoercionTyCon_maybe tc
-  = case desc of
-      CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs } 
-            -> Just (False, (tc, args, tvs, lhs, rhs))
-      CoSym | (arg1:_) <- args  
-            -> case isAxiom_maybe arg1 of
-                 Nothing           -> Nothing
-                 Just (sym, stuff) -> Just (not sym, stuff)
-      _ -> Nothing
-  | otherwise
-  = Nothing
-
-matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type]
-matchesAxiomLhs tvs ty_tmpl ty 
-  = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of
-      Nothing    -> Nothing
-      Just subst -> Just (map (substTyVar subst) tvs)
-
------------  
-opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion
--- Rules for Coercion TyCons only
-
--- Push transitivity inside instantiation
-opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2]
-  | CoInst <- desc
-  , ty1 `coreEqType` ty2
-  , co1 `compatible_co` co2
-  = Just (mkInstCoercion (opt_trans2 co1 co2) ty1) 
-
-opt_trans_rule_equal_tc desc [co1] [co2]
-  | CoLeft  <- desc, is_compat = Just (mkLeftCoercion res_co)
-  | CoRight <- desc, is_compat = Just (mkRightCoercion res_co)
-  | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co)
-  | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co)
-  | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co)
-  where
-    is_compat = co1 `compatible_co` co2
-    res_co    = opt_trans2 co1 co2
-
-opt_trans_rule_equal_tc _ _ _ = Nothing
-
--------------
-compatible_co :: Coercion -> Coercion -> Bool
--- Check whether (co1 . co2) will be well-kinded
-compatible_co co1 co2
-  = x1 `coreEqType` x2		
-  where
-    (_,x1) = coercionKind co1
-    (x2,_) = coercionKind co2
-
--------------
-etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion)
--- Try to make the coercion be of form (forall tv. co)
-etaForAll_maybe co
-  | Just (tv, r) <- splitForAllTy_maybe co
-  , not (isCoVar tv)	-- Check it is a *type* forall, not a (t1~t2)=>co
-  = Just (tv, r)
-
-  | (ty1,ty2) <- coercionKind co
-  , Just (tv1, _) <- splitTypeForAll_maybe ty1
-  , Just (tv2, _) <- splitTypeForAll_maybe ty2
-  , tyVarKind tv1 `eqKind` tyVarKind tv2
-  = Just (tv1, mkInstCoercion co (mkTyVarTy tv1))
-
-  | otherwise
-  = Nothing
-
-etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion)
-etaCoPred_maybe co 
-  | Just (s,t,r) <- splitCoPredTy_maybe co
-  = Just (s,t,r)
-  
-  --  co :: (s1~t1)=>r1 ~ (s2~t2)=>r2
-  | (ty1,ty2) <- coercionKind co	-- We know ty1,ty2 have same kind
-  , Just (s1,_,_) <- splitCoPredTy_maybe ty1
-  , Just (s2,_,_) <- splitCoPredTy_maybe ty2
-  , typeKind s1 `eqKind` typeKind s2	-- t1,t2 have same kinds
-  = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co)
-  
-  | otherwise
-  = Nothing
-
-etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion)
--- Split a coercion g :: t1a t1b ~ t2a t2b
--- into (left g, right g) if possible
-etaApp_maybe co
-  | Just (co1, co2) <- splitAppTy_maybe co
-  = Just (co1, co2)
-
-  | (ty1,ty2) <- coercionKind co
-  , Just (ty1a, _) <- splitAppTy_maybe ty1
-  , Just (ty2a, _) <- splitAppTy_maybe ty2
-  , typeKind ty1a `eqKind` typeKind ty2a
-  = Just (mkLeftCoercion co, mkRightCoercion co)
-
-  | otherwise
-  = Nothing
-
--------------
-splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type)
--- Returns Just only for a *type* forall, not a (t1~t2)=>co
-splitTypeForAll_maybe ty
-  | Just (tv, rty) <- splitForAllTy_maybe ty
-  , not (isCoVar tv)
-  = Just (tv, rty)
-
-  | otherwise
-  = Nothing
-
--------------
-isIdNormCo :: NormalCo -> Bool
--- Cheap identity test: look for coercions with no coercion variables at all
--- So it'll return False for (sym g `trans` g)
-isIdNormCo ty = go ty
-  where
-    go (TyVarTy tv)  	       = not (isCoVar tv)
-    go (AppTy t1 t2) 	       = go t1 && go t2
-    go (FunTy t1 t2) 	       = go t1 && go t2
-    go (ForAllTy tv ty)        = go (tyVarKind tv) && go ty
-    go (TyConApp tc tys)       = not (isCoercionTyCon tc) && all go tys
-    go (PredTy (IParam _ ty))  = go ty
-    go (PredTy (ClassP _ tys)) = all go tys
-    go (PredTy (EqPred t1 t2)) = go t1 && go t2
-\end{code}  
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module OptCoercion ( optCoercion ) where 
+
+#include "HsVersions.h"
+
+import Coercion
+import Type hiding( substTyVarBndr, substTy, extendTvSubst )
+import TyCon
+import Var
+import VarSet
+import VarEnv
+import StaticFlags	( opt_NoOptCoercion )
+import Outputable
+import Pair
+import Maybes( allMaybes )
+import FastString
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+                 Optimising coercions									
+%*                                                                      *
+%************************************************************************
+
+Note [Subtle shadowing in coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose we optimising a coercion
+    optCoercion (forall (co_X5:t1~t2). ...co_B1...)
+The co_X5 is a wild-card; the bound variable of a coercion for-all
+should never appear in the body of the forall. Indeed we often
+write it like this
+    optCoercion ( (t1~t2) => ...co_B1... )
+
+Just because it's a wild-card doesn't mean we are free to choose
+whatever variable we like.  For example it'd be wrong for optCoercion
+to return
+   forall (co_B1:t1~t2). ...co_B1...
+because now the co_B1 (which is really free) has been captured, and
+subsequent substitutions will go wrong.  That's why we can't use
+mkCoPredTy in the ForAll case, where this note appears.  
+
+\begin{code}
+optCoercion :: CvSubst -> Coercion -> NormalCo
+-- ^ optCoercion applies a substitution to a coercion, 
+--   *and* optimises it to reduce its size
+optCoercion env co 
+  | opt_NoOptCoercion = substCo env co
+  | otherwise         = opt_co env False co
+
+type NormalCo = Coercion
+  -- Invariants: 
+  --  * The substitution has been fully applied
+  --  * For trans coercions (co1 `trans` co2)
+  --       co1 is not a trans, and neither co1 nor co2 is identity
+  --  * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)
+
+type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity
+
+opt_co, opt_co' :: CvSubst
+       		-> Bool	       -- True <=> return (sym co)
+       		-> Coercion
+       		-> NormalCo	
+opt_co = opt_co'
+{-
+opt_co env sym co
+ = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
+   co1 `seq`
+   pprTrace "opt_co done }" (ppr co1) $
+   (WARN( not same_co_kind, ppr co  <+> dcolon <+> pprEqPred (Pair s1 t1)
+                         $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
+    WARN( not (coreEqCoercion co1 simple_result),
+           (text "env=" <+> ppr env) $$
+           (text "input=" <+> ppr co) $$
+           (text "simple=" <+> ppr simple_result) $$
+           (text "opt=" <+> ppr co1) )
+   co1)
+ where
+   co1 = opt_co' env sym co
+   same_co_kind = s1 `eqType` s2 && t1 `eqType` t2
+   Pair s t = coercionKind (substCo env co)
+   (s1,t1) | sym = (t,s)
+           | otherwise = (s,t)
+   Pair s2 t2 = coercionKind co1
+
+   simple_result | sym = mkSymCo (substCo env co)
+                 | otherwise = substCo env co
+-}
+
+opt_co' env _   (Refl ty)           = Refl (substTy env ty)
+opt_co' env sym (SymCo co)          = opt_co env (not sym) co
+opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos)
+opt_co' env sym (AppCo co1 co2)     = mkAppCo (opt_co env sym co1) (opt_co env sym co2)
+opt_co' env sym (ForAllCo tv co)    = case substTyVarBndr env tv of
+                                         (env', tv') -> mkForAllCo tv' (opt_co env' sym co)
+     -- Use the "mk" functions to check for nested Refls
+
+opt_co' env sym (CoVarCo cv)
+  | Just co <- lookupCoVar env cv
+  = opt_co (zapCvSubstEnv env) sym co
+
+  | Just cv1 <- lookupInScope (getCvInScope env) cv
+  = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
+                -- cv1 might have a substituted kind!
+
+  | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
+                ASSERT( isCoVar cv )
+                wrapSym sym (CoVarCo cv)
+
+opt_co' env sym (AxiomInstCo con cos)
+    -- Do *not* push sym inside top-level axioms
+    -- e.g. if g is a top-level axiom
+    --   g a : f a ~ a
+    -- then (sym (g ty)) /= g (sym ty) !!
+  = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos)
+      -- Note that the_co does *not* have sym pushed into it
+
+opt_co' env sym (UnsafeCo ty1 ty2)
+  | ty1' `eqType` ty2' = Refl ty1'
+  | sym                = mkUnsafeCo ty2' ty1'
+  | otherwise          = mkUnsafeCo ty1' ty2'
+  where
+    ty1' = substTy env ty1
+    ty2' = substTy env ty2
+
+opt_co' env sym (TransCo co1 co2)
+  | sym       = opt_trans opt_co2 opt_co1   -- sym (g `o` h) = sym h `o` sym g
+  | otherwise = opt_trans opt_co1 opt_co2
+  where
+    opt_co1 = opt_co env sym co1
+    opt_co2 = opt_co env sym co2
+
+opt_co' env sym (NthCo n co)
+  | TyConAppCo tc cos <- co'
+  , isDecomposableTyCon tc		-- Not synonym families
+  = ASSERT( n < length cos )
+    cos !! n
+  | otherwise
+  = NthCo n co'
+  where
+    co' = opt_co env sym co
+
+opt_co' env sym (InstCo co ty)
+    -- See if the first arg is already a forall
+    -- ...then we can just extend the current substitution
+  | Just (tv, co_body) <- splitForAllCo_maybe co
+  = opt_co (extendTvSubst env tv ty') sym co_body
+
+    -- See if it is a forall after optimization
+  | Just (tv, co'_body) <- splitForAllCo_maybe co'
+  = substCoWithTy tv ty' co'_body   -- An inefficient one-variable substitution
+
+  | otherwise = InstCo co' ty'
+
+  where
+    co' = opt_co env sym co
+    ty' = substTy env ty
+
+-------------
+opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList = zipWith opt_trans
+
+opt_trans :: NormalCo -> NormalCo -> NormalCo
+opt_trans co1 co2
+  | isReflCo co1 = co2
+  | otherwise    = opt_trans1 co1 co2
+
+opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
+-- First arg is not the identity
+opt_trans1 co1 co2
+  | isReflCo co2 = co1
+  | otherwise    = opt_trans2 co1 co2
+
+opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
+-- Neither arg is the identity
+opt_trans2 (TransCo co1a co1b) co2
+    -- Don't know whether the sub-coercions are the identity
+  = opt_trans co1a (opt_trans co1b co2)  
+
+opt_trans2 co1 co2 
+  | Just co <- opt_trans_rule co1 co2
+  = co
+
+opt_trans2 co1 (TransCo co2a co2b)
+  | Just co1_2a <- opt_trans_rule co1 co2a
+  = if isReflCo co1_2a
+    then co2b
+    else opt_trans1 co1_2a co2b
+
+opt_trans2 co1 co2
+  = mkTransCo co1 co2
+
+------
+-- Optimize coercions with a top-level use of transitivity.
+opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+
+-- push transitivity down through matching top-level constructors.
+opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2)
+  | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $
+                 TyConAppCo tc1 (opt_transList cos1 cos2)
+
+-- push transitivity through matching destructors
+opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+  | d1 == d2
+  , co1 `compatible_co` co2
+  = fireTransRule "PushNth" in_co1 in_co2 $
+    mkNthCo d1 (opt_trans co1 co2)
+
+-- Push transitivity inside instantiation
+opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+  | ty1 `eqType` ty2
+  , co1 `compatible_co` co2
+  = fireTransRule "TrPushInst" in_co1 in_co2 $
+    mkInstCo (opt_trans co1 co2) ty1
+ 
+-- Push transitivity inside apply
+opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+  = fireTransRule "TrPushApp" in_co1 in_co2 $
+    mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b)
+
+opt_trans_rule co1@(TyConAppCo tc cos1) co2
+  | Just cos2 <- etaTyConAppCo_maybe tc co2
+  = ASSERT( length cos1 == length cos2 )
+    fireTransRule "EtaCompL" co1 co2 $
+    TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+opt_trans_rule co1 co2@(TyConAppCo tc cos2)
+  | Just cos1 <- etaTyConAppCo_maybe tc co1
+  = ASSERT( length cos1 == length cos2 )
+    fireTransRule "EtaCompR" co1 co2 $
+    TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+-- Push transitivity inside forall
+opt_trans_rule co1 co2
+  | Just (tv1,r1) <- splitForAllCo_maybe co1
+  , Just (tv2,r2) <- etaForAllCo_maybe co2
+  , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2
+  = fireTransRule "EtaAllL" co1 co2 $
+    mkForAllCo tv1 (opt_trans2 r1 r2')
+
+  | Just (tv2,r2) <- splitForAllCo_maybe co2
+  , Just (tv1,r1) <- etaForAllCo_maybe co1
+  , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1
+  = fireTransRule "EtaAllR" co1 co2 $
+    mkForAllCo tv1 (opt_trans2 r1' r2)
+
+-- Push transitivity inside axioms
+opt_trans_rule co1 co2
+
+  -- TrPushAxR/TrPushSymAxR
+  | Just (sym, con, cos1) <- co1_is_axiom_maybe
+  , Just cos2 <- matchAxiom sym con co2
+  = fireTransRule "TrPushAxR" co1 co2 $
+    if sym 
+    then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1)
+    else         AxiomInstCo con (opt_transList cos1 cos2)
+
+  -- TrPushAxL/TrPushSymAxL
+  | Just (sym, con, cos2) <- co2_is_axiom_maybe
+  , Just cos1 <- matchAxiom (not sym) con co1
+  = fireTransRule "TrPushAxL" co1 co2 $
+    if sym 
+    then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1))
+    else         AxiomInstCo con (opt_transList cos1 cos2)
+
+  -- TrPushAxSym/TrPushSymAx
+  | Just (sym1, con1, cos1) <- co1_is_axiom_maybe
+  , Just (sym2, con2, cos2) <- co2_is_axiom_maybe
+  , con1 == con2
+  , sym1 == not sym2
+  , let qtvs = co_ax_tvs con1
+        lhs  = co_ax_lhs con1 
+        rhs  = co_ax_rhs con1 
+        pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs)
+  , all (`elemVarSet` pivot_tvs) qtvs
+  = fireTransRule "TrPushAxSym" co1 co2 $
+    if sym2
+    then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs  -- TrPushAxSym
+    else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs  -- TrPushSymAx
+  where
+    co1_is_axiom_maybe = isAxiom_maybe co1
+    co2_is_axiom_maybe = isAxiom_maybe co2
+
+opt_trans_rule co1 co2	-- Identity rule
+  | Pair ty1 _ <- coercionKind co1
+  , Pair _ ty2 <- coercionKind co2
+  , ty1 `eqType` ty2
+  = fireTransRule "RedTypeDirRefl" co1 co2 $
+    Refl ty2
+
+opt_trans_rule _ _ = Nothing
+
+fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
+fireTransRule _rule _co1 _co2 res
+  = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $
+    Just res
+
+-----------
+wrapSym :: Bool -> Coercion -> Coercion
+wrapSym sym co | sym       = SymCo co
+               | otherwise = co
+
+-----------
+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion])
+isAxiom_maybe (SymCo co) 
+  | Just (sym, con, cos) <- isAxiom_maybe co
+  = Just (not sym, con, cos)
+isAxiom_maybe (AxiomInstCo con cos)
+  = Just (False, con, cos)
+isAxiom_maybe _ = Nothing
+
+matchAxiom :: Bool -- True = match LHS, False = match RHS
+           -> CoAxiom -> Coercion -> Maybe [Coercion]
+-- If we succeed in matching, then *all the quantified type variables are bound*
+-- E.g.   if tvs = [a,b], lhs/rhs = [b], we'll fail
+matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co
+  = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of
+      Nothing    -> Nothing
+      Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
+
+-------------
+compatible_co :: Coercion -> Coercion -> Bool
+-- Check whether (co1 . co2) will be well-kinded
+compatible_co co1 co2
+  = x1 `eqType` x2		
+  where
+    Pair _ x1 = coercionKind co1
+    Pair x2 _ = coercionKind co2
+
+-------------
+etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+-- Try to make the coercion be of form (forall tv. co)
+etaForAllCo_maybe co
+  | Just (tv, r) <- splitForAllCo_maybe co
+  = Just (tv, r)
+
+  | Pair ty1 ty2  <- coercionKind co
+  , Just (tv1, _) <- splitForAllTy_maybe ty1
+  , Just (tv2, _) <- splitForAllTy_maybe ty2
+  , tyVarKind tv1 `eqKind` tyVarKind tv2
+  = Just (tv1, mkInstCo co (mkTyVarTy tv1))
+
+  | otherwise
+  = Nothing
+
+etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
+-- If possible, split a coercion 
+--       g :: T s1 .. sn ~ T t1 .. tn
+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] 
+etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2)
+  = ASSERT( tc == tc2 ) Just cos2
+
+etaTyConAppCo_maybe tc co
+  | isDecomposableTyCon tc
+  , Pair ty1 ty2     <- coercionKind co
+  , Just (tc1, tys1) <- splitTyConApp_maybe ty1
+  , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+  , tc1 == tc2
+  , let n = length tys1
+  = ASSERT( tc == tc1 ) 
+    ASSERT( n == length tys2 )
+    Just (decomposeCo n co)  
+    -- NB: n might be <> tyConArity tc
+    -- e.g.   data family T a :: * -> *
+    --        g :: T a b ~ T c d
+
+  | otherwise
+  = Nothing
+\end{code}  
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index adb0470..9152076 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -13,7 +13,9 @@ module TyCon(
 	AlgTyConRhs(..), visibleDataCons, 
         TyConParent(..), isNoParent,
 	SynTyConRhs(..),
-        CoTyConDesc(..),
+
+	-- ** Coercion axiom constructors
+        CoAxiom(..), coAxiomName, coAxiomArity,
 
         -- ** Constructing TyCons
 	mkAlgTyCon,
@@ -25,7 +27,6 @@ module TyCon(
 	mkTupleTyCon,
 	mkSynTyCon,
         mkSuperKindTyCon,
-        mkCoercionTyCon,
         mkForeignTyCon,
         mkAnyTyCon,
 
@@ -35,21 +36,20 @@ module TyCon(
         isFunTyCon, 
         isPrimTyCon,
         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, 
-        isSynTyCon, isClosedSynTyCon, 
+        isSynTyCon, isClosedSynTyCon,
         isSuperKindTyCon, isDecomposableTyCon,
-        isCoercionTyCon, isCoercionTyCon_maybe,
         isForeignTyCon, isAnyTyCon, tyConHasKind,
 
 	isInjectiveTyCon,
 	isDataTyCon, isProductTyCon, isEnumerationTyCon, 
-	isNewTyCon, isAbstractTyCon, 
+        isNewTyCon, isAbstractTyCon,
         isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon,
         isUnLiftedTyCon,
 	isGadtSyntaxTyCon,
 	isTyConAssoc,
 	isRecursiveTyCon,
 	isHiBootTyCon,
-        isImplicitTyCon, tyConHasGenerics,
+        isImplicitTyCon, 
 
         -- ** Extracting information out of TyCons
 	tyConName,
@@ -63,16 +63,16 @@ module TyCon(
         tyConParent,
 	tyConClass_maybe,
 	tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
-	synTyConDefn, synTyConRhs, synTyConType, 
-	tyConExtName,		-- External name for foreign types
+        synTyConDefn, synTyConRhs, synTyConType,
+        tyConExtName,           -- External name for foreign types
 	algTyConRhs,
         newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, 
-        tupleTyConBoxity,
+        tupleTyConBoxity, tupleTyConArity,
 
         -- ** Manipulating TyCons
 	tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 	makeTyConAbstract,
-	newTyConCo_maybe,
+	newTyConCo, newTyConCo_maybe,
 
         -- * Primitive representations of Types
 	PrimRep(..),
@@ -113,7 +113,7 @@ Note [Type synonym families]
 
 * Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon
 
-* From the user's point of view (F Int) and Bool are simply 
+* From the user's point of view (F Int) and Bool are simply
   equivalent types.
 
 * A Haskell 98 type synonym is a degenerate form of a type synonym
@@ -152,6 +152,23 @@ Note [Type synonym families]
   TyCon.  In turn this means that type and data families can be
   treated uniformly.
 
+* Translation of type family decl:
+	type family F a :: *
+  translates to
+    a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
+
+* Translation of type instance decl:
+	type instance F [a] = Maybe a
+  translates to
+    A SynTyCon 'R:FList a', whose 
+       SynTyConRhs is (SynonymTyCon (Maybe a))
+       TyConParent is (FamInstTyCon F [a] co)
+         where co :: F [a] ~ R:FList a
+    Notice that we introduce a gratuitous vanilla type synonym
+       type R:FList a = Maybe a
+    solely so that type and data families can be treated more
+    uniformly, via a single FamInstTyCon descriptor        
+
 * In the future we might want to support
     * closed type families (esp when we have proper kinds)
     * injective type families (allow decomposition)
@@ -169,6 +186,8 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
 
 * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
 
+* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+
 * The user does not see any "equivalent types" as he did with type
   synonym families.  He just sees constructors with types
 	T1 :: T Int
@@ -266,9 +285,6 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
 --
 -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@
 --
--- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@ 
---    as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this
---
 -- This data type also encodes a number of primitive, built in type constructors such as those
 -- for function and tuple types.
 data TyCon
@@ -317,11 +333,7 @@ data TyCon
 
 	algTcRec :: RecFlag,	  -- ^ Tells us whether the data type is part 
                                   -- of a mutually-recursive group or not
-
-	hasGenerics :: Bool,	  -- ^ Whether generic (in the -XGenerics sense) 
-                                  -- to\/from functions are available in the exports 
-                                  -- of the data type's source module.
-
+	
 	algTcParent :: TyConParent	-- ^ Gives the class or family declaration 'TyCon' 
                                         -- for derived 'TyCon's representing class 
                                         -- or family instances, respectively. 
@@ -337,8 +349,7 @@ data TyCon
 	tyConArity  :: Arity,
 	tyConBoxed  :: Boxity,
 	tyConTyVars :: [TyVar],
-	dataCon     :: DataCon, -- ^ Corresponding tuple data constructor
-	hasGenerics :: Bool
+	dataCon     :: DataCon -- ^ Corresponding tuple data constructor
     }
 
   -- | Represents type synonyms
@@ -381,17 +392,6 @@ data TyCon
                                            --   holds the name of the imported thing
     }
 
-  -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@.
-  -- INVARIANT: Coercion TyCons are always fully applied
-  -- 		But note that a CoTyCon can be *over*-saturated in a type.
-  -- 		E.g.  (sym g1) Int  will be represented as (TyConApp sym [g1,Int])
-  | CoTyCon {	
-	tyConUnique :: Unique,
-        tyConName   :: Name,
-	tyConArity  :: Arity,
-	coTcDesc    :: CoTyConDesc
-    }
-
   -- | Any types.  Like tuples, this is a potentially-infinite family of TyCons
   --   one for each distinct Kind. They have no values at all.
   --   Because there are infinitely many of them (like tuples) they are 
@@ -401,7 +401,7 @@ data TyCon
   | AnyTyCon {
 	tyConUnique  :: Unique,
 	tyConName    :: Name,
-	tc_kind    :: Kind	-- Never = *; that is done via PrimTyCon
+	tc_kind      :: Kind	-- Never = *; that is done via PrimTyCon
 		     		-- See Note [Any types] in TysPrim
     }
 
@@ -475,18 +475,14 @@ data AlgTyConRhs
 			-- shorter than the declared arity of the 'TyCon'.
 			
 			-- See Note [Newtype eta]
-      
-        nt_co :: Maybe TyCon   -- ^ A 'TyCon' (which is always a 'CoTyCon') that can 
-                               -- have a 'Coercion' extracted from it to create 
-                               -- the @newtype@ from the representation 'Type'.
-                               --
-                               -- This field is optional for non-recursive @newtype@s only.
-                               
-			       -- See Note [Newtype coercions]
-			       -- Invariant: arity = #tvs in nt_etad_rhs;
-			       --	See Note [Newtype eta]
-			       -- Watch out!  If any newtypes become transparent
-			       -- again check Trac #1072.
+        nt_co :: CoAxiom     -- The axiom coercion that creates the @newtype@ from 
+                             -- the representation 'Type'.
+                                
+                             -- See Note [Newtype coercions]
+                             -- Invariant: arity = #tvs in nt_etad_rhs;
+                             --	See Note [Newtype eta]
+                             -- Watch out!  If any newtypes become transparent
+                             -- again check Trac #1072.
     }
 
 -- | Extract those 'DataCon's that we are able to learn about.  Note
@@ -546,7 +542,7 @@ data TyConParent
     			  -- and Note [Type synonym families]
 	TyCon   -- The family TyCon
 	[Type]	-- Argument types (mentions the tyConTyVars of this TyCon)
-	TyCon   -- The coercion constructor
+        CoAxiom   -- The coercion constructor
 
 	-- E.g.  data intance T [a] = ...
 	-- gives a representation tycon:
@@ -577,20 +573,6 @@ data SynTyConRhs
 
    -- | A type synonym family  e.g. @type family F x y :: * -> *@
    | SynFamilyTyCon
-
---------------------
-data CoTyConDesc
-  = CoSym   | CoTrans
-  | CoLeft  | CoRight
-  | CoCsel1 | CoCsel2 | CoCselR
-  | CoInst
-
-  | CoAxiom	-- C tvs : F lhs-tys ~ rhs-ty
-      { co_ax_tvs :: [TyVar]
-      , co_ax_lhs :: Type
-      , co_ax_rhs :: Type }
-
-  | CoUnsafe 
 \end{code}
 
 Note [Enumeration types]
@@ -689,6 +671,31 @@ so the coercion tycon CoT must have
 
 %************************************************************************
 %*									*
+                    Coercion axioms
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
+data CoAxiom
+  = CoAxiom                   -- type equality axiom.
+    { co_ax_unique :: Unique   -- unique identifier
+    , co_ax_name   :: Name     -- name for pretty-printing
+    , co_ax_tvs    :: [TyVar]  -- bound type variables 
+    , co_ax_lhs    :: Type     -- left-hand side of the equality
+    , co_ax_rhs    :: Type     -- right-hand side of the equality
+    }
+
+coAxiomArity :: CoAxiom -> Arity
+coAxiomArity ax = length (co_ax_tvs ax)
+
+coAxiomName :: CoAxiom -> Name
+coAxiomName = co_ax_name
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{PrimRep}
 %*									*
 %************************************************************************
@@ -776,10 +783,9 @@ mkAlgTyCon :: Name
            -> AlgTyConRhs       -- ^ Information about dat aconstructors
            -> TyConParent
            -> RecFlag           -- ^ Is the 'TyCon' recursive?
-           -> Bool              -- ^ Does it have generic functions? See 'hasGenerics'
            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?
            -> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
   = AlgTyCon {	
 	tyConName 	 = name,
 	tyConUnique	 = nameUnique name,
@@ -790,14 +796,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
 	algTcRhs         = rhs,
 	algTcParent	 = ASSERT( okParent name parent ) parent,
 	algTcRec	 = is_rec,
-	algTcGadtSyntax  = gadt_syn,
-	hasGenerics      = gen_info
+	algTcGadtSyntax  = gadt_syn
     }
 
 -- | Simpler specialization of 'mkAlgTyCon' for classes
 mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
 mkClassTyCon name kind tyvars rhs clas is_rec =
-  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
+  mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
 
 mkTupleTyCon :: Name 
              -> Kind    -- ^ Kind of the resulting 'TyCon'
@@ -805,9 +810,8 @@ mkTupleTyCon :: Name
              -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
              -> DataCon 
              -> Boxity  -- ^ Whether the tuple is boxed or unboxed
-             -> Bool    -- ^ Does it have generic functions? See 'hasGenerics'
              -> TyCon
-mkTupleTyCon name kind arity tyvars con boxed gen_info
+mkTupleTyCon name kind arity tyvars con boxed 
   = TupleTyCon {
 	tyConUnique = nameUnique name,
 	tyConName = name,
@@ -815,8 +819,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info
 	tyConArity = arity,
 	tyConBoxed = boxed,
 	tyConTyVars = tyvars,
-	dataCon = con,
-	hasGenerics = gen_info
+	dataCon = con
     }
 
 -- ^ Foreign-imported (.NET) type constructors are represented
@@ -880,17 +883,6 @@ mkSynTyCon name kind tyvars rhs parent
         synTcParent = parent
     }
 
--- | Create a coercion 'TyCon'
-mkCoercionTyCon :: Name -> Arity 
-                -> CoTyConDesc
-                -> TyCon
-mkCoercionTyCon name arity desc
-  = CoTyCon {
-        tyConName   = name,
-        tyConUnique = nameUnique name,
-        tyConArity  = arity,
-        coTcDesc    = desc }
-
 mkAnyTyCon :: Name -> Kind -> TyCon
 mkAnyTyCon name kind 
   = AnyTyCon {  tyConName = name,
@@ -968,11 +960,11 @@ isNewTyCon _                                   = False
 -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands
 -- into, and (possibly) a coercion from the representation type to the @newtype@.
 -- Returns @Nothing@ if this is not possible.
-unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon)
+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom)
 unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, 
-				 algTcRhs = NewTyCon { nt_co = mb_co, 
+				 algTcRhs = NewTyCon { nt_co = co, 
 						       nt_rhs = rhs }})
-			   = Just (tvs, rhs, mb_co)
+			   = Just (tvs, rhs, co)
 unwrapNewTyCon_maybe _     = Nothing
 
 isProductTyCon :: TyCon -> Bool
@@ -1004,9 +996,8 @@ isSynTyCon _		 = False
 
 isDecomposableTyCon :: TyCon -> Bool
 -- True iff we can decompose (T a b c) into ((T a b) c)
--- Specifically NOT true of synonyms (open and otherwise) and coercions
+-- Specifically NOT true of synonyms (open and otherwise)
 isDecomposableTyCon (SynTyCon {}) = False
-isDecomposableTyCon (CoTyCon {})  = False
 isDecomposableTyCon _other        = True
 
 -- | Is this an algebraic 'TyCon' declared with the GADT syntax?
@@ -1048,7 +1039,7 @@ isInjectiveTyCon tc = not (isSynTyCon tc)
 	-- Ultimately we may have injective associated types
         -- in which case this test will become more interesting
 	--
-	-- It'd be unusual to call isInjectiveTyCon on a regular H98
+        -- It'd be unusual to call isInjectiveTyCon on a regular H98
 	-- type synonym, because you should probably have expanded it first
 	-- But regardless, it's not injective!
 
@@ -1087,6 +1078,11 @@ isBoxedTupleTyCon _                                  = False
 tupleTyConBoxity :: TyCon -> Boxity
 tupleTyConBoxity tc = tyConBoxed tc
 
+-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
+-- Panics otherwise
+tupleTyConArity :: TyCon -> Arity
+tupleTyConArity tc = tyConArity tc
+
 -- | Is this a recursive 'TyCon'?
 isRecursiveTyCon :: TyCon -> Bool
 isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
@@ -1113,19 +1109,6 @@ isAnyTyCon :: TyCon -> Bool
 isAnyTyCon (AnyTyCon {}) = True
 isAnyTyCon _              = False
 
--- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of
--- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the
--- appropriate kind
-isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, CoTyConDesc)
-isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc}) 
-  = Just (ar, desc)
-isCoercionTyCon_maybe _ = Nothing
-
--- | Is this a 'TyCon' that represents a coercion?
-isCoercionTyCon :: TyCon -> Bool
-isCoercionTyCon (CoTyCon {}) = True
-isCoercionTyCon _            = False
-
 -- | Identifies implicit tycons that, in particular, do not go into interface
 -- files (because they are implicitly reconstructed when the interface is
 -- read).
@@ -1155,14 +1138,15 @@ isImplicitTyCon _other                               = True
 \begin{code}
 tcExpandTyCon_maybe, coreExpandTyCon_maybe 
 	:: TyCon 
-	-> [Type]			-- ^ Arguments to 'TyCon'
-	-> Maybe ([(TyVar,Type)], 	
+	-> [tyco]		  -- ^ Arguments to 'TyCon'
+	-> Maybe ([(TyVar,tyco)], 	
 		  Type,			
-		  [Type])		-- ^ Returns a 'TyVar' substitution, the body type
-                                        -- of the synonym (not yet substituted) and any arguments
-                                        -- remaining from the application
+		  [tyco])	  -- ^ Returns a 'TyVar' substitution, the body type
+                                  -- of the synonym (not yet substituted) and any arguments
+                                  -- remaining from the application
 
--- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
+-- ^ Used to create the view the /typechecker/ has on 'TyCon's. 
+-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
 tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, 
 			       synTcRhs = SynonymTyCon rhs }) tys
    = expand tvs rhs tys
@@ -1170,36 +1154,26 @@ tcExpandTyCon_maybe _ _ = Nothing
 
 ---------------
 
--- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
+-- ^ Used to create the view /Core/ has on 'TyCon's. We expand 
+-- not only closed synonyms like 'tcExpandTyCon_maybe',
 -- but also non-recursive @newtype@s
-coreExpandTyCon_maybe (AlgTyCon {
-         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
-   = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
-			-- match the etad_rhs of a *recursive* newtype
-	(tvs,rhs) -> expand tvs rhs tys
-
 coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
 
 
 ----------------
-expand	:: [TyVar] -> Type 			-- Template
-	-> [Type]				-- Args
-	-> Maybe ([(TyVar,Type)], Type, [Type])	-- Expansion
+expand	:: [TyVar] -> Type 		   -- Template
+	-> [a]				   -- Args
+	-> Maybe ([(TyVar,a)], Type, [a])  -- Expansion
 expand tvs rhs tys
   = case n_tvs `compare` length tys of
 	LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys)
 	EQ -> Just (tvs `zip` tys, rhs, [])
-	GT -> Nothing
+        GT -> Nothing
    where
      n_tvs = length tvs
 \end{code}
 
 \begin{code}
--- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics'
-tyConHasGenerics :: TyCon -> Bool
-tyConHasGenerics (AlgTyCon {hasGenerics = hg})   = hg
-tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics _                               = False        -- Synonyms
 
 tyConKind :: TyCon -> Kind
 tyConKind (FunTyCon   { tc_kind = k }) = k
@@ -1212,7 +1186,6 @@ tyConKind tc = pprPanic "tyConKind" (ppr tc)	-- SuperKindTyCon and CoTyCon
 
 tyConHasKind :: TyCon -> Bool
 tyConHasKind (SuperKindTyCon {}) = False
-tyConHasKind (CoTyCon {})        = False
 tyConHasKind _                   = True
 
 -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors
@@ -1265,9 +1238,14 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon)
 -- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something
 -- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon'
 -- is not a @newtype@, returns @Nothing@
-newTyConCo_maybe :: TyCon -> Maybe TyCon
-newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
-newTyConCo_maybe _						 = Nothing
+newTyConCo_maybe :: TyCon -> Maybe CoAxiom
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co
+newTyConCo_maybe _					         = Nothing
+
+newTyConCo :: TyCon -> CoAxiom
+newTyConCo tc = case newTyConCo_maybe tc of
+ 	         Just co -> co
+                 Nothing -> pprPanic "newTyConCo" (ppr tc)
 
 -- | Find the primitive representation of a 'TyCon'
 tyConPrimRep :: TyCon -> PrimRep
@@ -1337,6 +1315,7 @@ tyConParent (AlgTyCon {algTcParent = parent}) = parent
 tyConParent (SynTyCon {synTcParent = parent}) = parent
 tyConParent _                                 = NoParentTyCon
 
+----------------------------------------------------------------------------
 -- | Is this 'TyCon' that for a family instance, be that for a synonym or an
 -- algebraic family instance?
 isFamInstTyCon :: TyCon -> Bool
@@ -1344,7 +1323,7 @@ isFamInstTyCon tc = case tyConParent tc of
                       FamInstTyCon {} -> True
                       _               -> False
 
-tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon)
+tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom)
 tyConFamInstSig_maybe tc
   = case tyConParent tc of
       FamInstTyCon f ts co_tc -> Just (f, ts, co_tc)
@@ -1361,7 +1340,7 @@ tyConFamInst_maybe tc
 -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents 
 -- a coercion identifying the representation type with the type instance family.
 -- Otherwise, return @Nothing@
-tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
+tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom
 tyConFamilyCoercion_maybe tc
   = case tyConParent tc of
       FamInstTyCon _ _ co -> Just co
@@ -1395,18 +1374,6 @@ instance Ord TyCon where
 instance Uniquable TyCon where
     getUnique tc = tyConUnique tc
 
-instance Outputable CoTyConDesc where
-    ppr CoSym    = ptext (sLit "SYM")
-    ppr CoTrans  = ptext (sLit "TRANS")
-    ppr CoLeft   = ptext (sLit "LEFT")
-    ppr CoRight  = ptext (sLit "RIGHT")
-    ppr CoCsel1  = ptext (sLit "CSEL1")
-    ppr CoCsel2  = ptext (sLit "CSEL2")
-    ppr CoCselR  = ptext (sLit "CSELR")
-    ppr CoInst   = ptext (sLit "INST")
-    ppr CoUnsafe = ptext (sLit "UNSAFE")
-    ppr (CoAxiom {}) = ptext (sLit "AXIOM")
-
 instance Outputable TyCon where
     ppr tc  = ppr (getName tc) 
 
@@ -1421,4 +1388,34 @@ instance Data.Data TyCon where
     toConstr _   = abstractConstr "TyCon"
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "TyCon"
+
+-------------------
+instance Eq CoAxiom where
+    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
+    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
+  
+instance Ord CoAxiom where
+    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
+    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
+    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
+    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
+    compare a b = getUnique a `compare` getUnique b  
+
+instance Uniquable CoAxiom where
+    getUnique = co_ax_unique
+
+instance Outputable CoAxiom where
+    ppr = ppr . getName
+
+instance NamedThing CoAxiom where
+    getName = co_ax_name
+
+instance Data.Typeable CoAxiom where
+    typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") []
+
+instance Data.Data CoAxiom where
+    -- don't traverse?
+    toConstr _   = abstractConstr "CoAxiom"
+    gunfold _ _  = error "gunfold"
+    dataTypeOf _ = mkNoRepType "CoAxiom"
 \end{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 5f348ef..995d7a9 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -20,7 +20,8 @@ module Type (
 	-- $type_classification
 	
         -- $representation_types
-	TyThing(..), Type, PredType(..), ThetaType,
+        TyThing(..), Type, Pred(..), PredType, ThetaType,
+        Var, TyVar, isTyVar, 
 
         -- ** Constructing and deconstructing types
         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
@@ -45,14 +46,20 @@ module Type (
 	-- (Type families)
         tyFamInsts, predFamInsts,
 
-        -- (Source types)
-        mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred,
+        -- Pred types
+        mkPredTy, mkPredTys, mkFamilyTyConApp,
+	mkDictTy, isDictLikeTy, isClassPred,
+        isEqPred, allPred, mkEqPred, 
+	mkClassPred, getClassPredTys, getClassPredTys_maybe,
+	isTyVarClassPred, 
+	mkIPPred, isIPPred,
 
 	-- ** Common type constructors
         funTyCon,
 
         -- ** Predicates on types
-        isTyVarTy, isFunTy, isDictTy,
+        isTyVarTy, isFunTy, isPredTy,
+	isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe, 
 
 	-- (Lifting and boxity)
 	isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
@@ -65,8 +72,7 @@ module Type (
         -- ** Common Kinds and SuperKinds
         liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind,
-
-        tySuperKind, coSuperKind, 
+        tySuperKind, 
 
         -- ** Common Kind type constructors
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
@@ -74,19 +80,18 @@ module Type (
 
 	-- * Type free variables
 	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-	expandTypeSynonyms, 
+	exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms, 
 	typeSize,
 
 	-- * Type comparison
-	coreEqType, coreEqType2,
-        tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
-	tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+        eqType, eqTypeX, eqTypes, cmpType, cmpTypes, 
+	eqPred, eqPredX, cmpPred, eqKind,
 
 	-- * Forcing evaluation of types
-	seqType, seqTypes,
+        seqType, seqTypes, seqPred,
 
         -- * Other views onto Types
-        coreView, tcView, kindView,
+        coreView, tcView, 
 
         repType, 
 
@@ -103,18 +108,22 @@ module Type (
 	emptyTvSubstEnv, emptyTvSubst,
 	
 	mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
-	getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, 
+        getTvSubstEnv, setTvSubstEnv,
+        zapTvSubstEnv, getTvInScope,
         extendTvInScope, extendTvInScopeList,
- 	extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
+ 	extendTvSubst, extendTvSubstList,
+        isInScope, composeTvSubst, zipTyEnv,
         isEmptyTvSubst, unionTvSubst,
 
 	-- ** Performing substitution on types
 	substTy, substTys, substTyWith, substTysWith, substTheta, 
-	substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
+        substPred, substTyVar, substTyVars, substTyVarBndr,
+        deShadowTy, lookupTyVar, 
 
 	-- * Pretty-printing
 	pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
-	pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+	pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, 
+        pprKind, pprParendKind,
 	
 	pprSourceTyCon
     ) where
@@ -133,8 +142,11 @@ import VarSet
 
 import Class
 import TyCon
+import TysPrim
 
 -- others
+import BasicTypes	( IPName )
+import Name		( Name )
 import StaticFlags
 import Util
 import Outputable
@@ -219,31 +231,9 @@ coreView :: Type -> Maybe Type
 -- its underlying representation type. 
 -- Returns Nothing if there is nothing to look through.
 --
--- In the case of @newtype@s, it returns one of:
---
--- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated)
--- 
--- 2) The newtype representation (otherwise), meaning the
---    type written in the RHS of the newtype declaration,
---    which may itself be a newtype
---
--- For example, with:
---
--- > newtype R = MkR S
--- > newtype S = MkS T
--- > newtype T = MkT (T -> T)
---
--- 'expandNewTcApp' on:
---
---  * @R@ gives @Just S@
---  * @S@ gives @Just T@
---  * @T@ gives @Nothing@ (no expansion)
-
 -- By being non-recursive and inlined, this case analysis gets efficiently
 -- joined onto the case analysis that the caller is already doing
-coreView (PredTy p)
-  | isEqPred p             = Nothing
-  | otherwise    	   = Just (predTypeRep p)
+coreView (PredTy p)        = Just (predTypeRep p)
 coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys 
 			   = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
 				-- Its important to use mkAppTys, rather than (foldl AppTy),
@@ -252,7 +242,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc
 coreView _                 = Nothing
 
 
-
 -----------------------------------------------
 {-# INLINE tcView #-}
 tcView :: Type -> Maybe Type
@@ -283,14 +272,6 @@ expandTypeSynonyms ty
     go_pred (ClassP c ts)  = ClassP c (map go ts)
     go_pred (IParam ip t)  = IParam ip (go t)
     go_pred (EqPred t1 t2) = EqPred (go t1) (go t2)
-
------------------------------------------------
-{-# INLINE kindView #-}
-kindView :: Kind -> Maybe Kind
--- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
-
--- For the moment, we don't even handle synonyms in kinds
-kindView _            = Nothing
 \end{code}
 
 
@@ -305,12 +286,6 @@ kindView _            = Nothing
 				TyVarTy
 				~~~~~~~
 \begin{code}
-mkTyVarTy  :: TyVar   -> Type
-mkTyVarTy  = TyVarTy
-
-mkTyVarTys :: [TyVar] -> [Type]
-mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
-
 -- | Attempts to obtain the type variable underlying a 'Type', and panics with the
 -- given message if this is not a type variable type. See also 'getTyVar_maybe'
 getTyVar :: String -> Type -> TyVar
@@ -384,10 +359,9 @@ repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
 repSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 repSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 repSplitAppTy_maybe (TyConApp tc tys) 
-  | isDecomposableTyCon tc || length tys > tyConArity tc 
-  = case snocView tys of       -- never create unsaturated type family apps
-      Just (tys', ty') -> Just (TyConApp tc tys', ty')
-      Nothing	       -> Nothing
+  | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc 
+  , Just (tys', ty') <- snocView tys
+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!
 repSplitAppTy_maybe _other = Nothing
 -------------
 splitAppTy :: Type -> (Type, Type)
@@ -427,8 +401,7 @@ splitAppTys ty = split ty ty []
 \begin{code}
 mkFunTy :: Type -> Type -> Type
 -- ^ Creates a function type from the given argument and result type
-mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
-mkFunTy arg                      res = FunTy    arg               res
+mkFunTy arg res = FunTy arg res
 
 mkFunTys :: [Type] -> Type -> Type
 mkFunTys tys ty = foldr mkFunTy ty tys
@@ -496,20 +469,6 @@ funArgTy ty                = pprPanic "funArgTy" (ppr ty)
 				~~~~~~~~
 
 \begin{code}
--- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
--- Applies its arguments to the constructor from left to right
-mkTyConApp :: TyCon -> [Type] -> Type
-mkTyConApp tycon tys
-  | isFunTyCon tycon, [ty1,ty2] <- tys
-  = FunTy ty1 ty2
-
-  | otherwise
-  = TyConApp tycon tys
-
--- | Create the plain type constructor type which has been applied to no type arguments at all.
-mkTyConTy :: TyCon -> Type
-mkTyConTy tycon = mkTyConApp tycon []
-
 -- splitTyConApp "looks through" synonyms, because they don't
 -- mean a distinct type, but all other type-constructor applications
 -- including functions are returned as Just ..
@@ -612,13 +571,16 @@ repType ty
   = go [] ty
   where
     go :: [TyCon] -> Type -> Type
-    go rec_nts ty | Just ty' <- coreView ty 	-- Expand synonyms
-	= go rec_nts ty'	
-
-    go rec_nts (ForAllTy _ ty)			-- Look through foralls
+    go rec_nts (ForAllTy _ ty)		-- Look through foralls
 	= go rec_nts ty
 
-    go rec_nts (TyConApp tc tys)		-- Expand newtypes
+    go rec_nts (PredTy p)		-- Expand predicates
+        = go rec_nts (predTypeRep p)
+
+    go rec_nts (TyConApp tc tys)	-- Expand newtypes and synonyms
+      | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys 
+      = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
+
       | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
       = go rec_nts' ty'
 
@@ -756,13 +718,32 @@ applyTysD doc orig_fun_ty arg_tys
 
 %************************************************************************
 %*									*
-\subsection{Source types}
+                         Pred
 %*									*
 %************************************************************************
 
-Source types are always lifted.
+Polymorphic functions over Pred
 
-The key function is predTypeRep which gives the representation of a source type:
+\begin{code}
+allPred :: (a -> Bool) -> Pred a -> Bool
+allPred p (ClassP _ ts)  = all p ts
+allPred p (IParam _ t)   = p t
+allPred p (EqPred t1 t2) = p t1 && p t2
+
+isClassPred :: Pred a -> Bool
+isClassPred (ClassP {}) = True
+isClassPred _            = False
+
+isEqPred :: Pred a -> Bool
+isEqPred (EqPred {}) = True
+isEqPred _           = False
+
+isIPPred :: Pred a -> Bool
+isIPPred (IParam {}) = True
+isIPPred _           = False
+\end{code}
+
+Make PredTypes
 
 \begin{code}
 mkPredTy :: PredType -> Type
@@ -771,91 +752,115 @@ mkPredTy pred = PredTy pred
 mkPredTys :: ThetaType -> [Type]
 mkPredTys preds = map PredTy preds
 
-isEqPred :: PredType -> Bool
-isEqPred (EqPred _ _) = True
-isEqPred _            = False
-
 predTypeRep :: PredType -> Type
 -- ^ Convert a 'PredType' to its representation type. However, it unwraps 
 -- only the outermost level; for example, the result might be a newtype application
 predTypeRep (IParam _ ty)     = ty
 predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-	-- Result might be a newtype application, but the consumer will
-	-- look through that too if necessary
-predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
-
-mkFamilyTyConApp :: TyCon -> [Type] -> Type
--- ^ Given a family instance TyCon and its arg types, return the
--- corresponding family type.  E.g:
---
--- > data family T a
--- > data instance T (Maybe b) = MkT b
---
--- Where the instance tycon is :RTL, so:
---
--- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)
-mkFamilyTyConApp tc tys
-  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
-  , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
-  = mkTyConApp fam_tc (substTys fam_subst fam_tys)
-  | otherwise
-  = mkTyConApp tc tys
+predTypeRep (EqPred ty1 ty2)  = mkTyConApp eqPredPrimTyCon [ty1,ty2]
 
--- | Pretty prints a 'TyCon', using the family instance in case of a
--- representation tycon.  For example:
---
--- > data T [a] = ...
---
--- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
-pprSourceTyCon :: TyCon -> SDoc
-pprSourceTyCon tycon 
-  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
-  = ppr $ fam_tc `TyConApp` tys	       -- can't be FunTyCon
-  | otherwise
-  = ppr tycon
+splitPredTy_maybe :: Type -> Maybe PredType
+-- Returns Just for predicates only
+splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty'
+splitPredTy_maybe (PredTy p)    = Just p
+splitPredTy_maybe _             = Nothing
 
-isDictTy :: Type -> Bool
-isDictTy ty = case splitTyConApp_maybe ty of
-                Just (tc, _) -> isClassTyCon tc
-		Nothing      -> False
+isPredTy :: Type -> Bool
+isPredTy ty = isJust (splitPredTy_maybe ty)
 \end{code}
 
+--------------------- Equality types ---------------------------------
+\begin{code}
+isReflPredTy :: Type -> Bool
+isReflPredTy ty = case splitPredTy_maybe ty of
+                    Just (EqPred ty1 ty2) -> ty1 `eqType` ty2
+                    _                     -> False
+
+splitEqPredTy_maybe :: Type -> Maybe (Type,Type)
+splitEqPredTy_maybe ty = case splitPredTy_maybe ty of
+                            Just (EqPred ty1 ty2) -> Just (ty1,ty2)
+                            _                     -> Nothing
+
+isEqPredTy :: Type -> Bool
+isEqPredTy ty = case splitPredTy_maybe ty of
+                  Just (EqPred {}) -> True
+		  _                -> False
+
+-- | Creates a type equality predicate
+mkEqPred :: (a, a) -> Pred a
+mkEqPred (ty1, ty2) = EqPred ty1 ty2
+\end{code}
 
-%************************************************************************
-%*									*
-	     The free variables of a type
-%*									*
-%************************************************************************
-
+--------------------- Dictionary types ---------------------------------
 \begin{code}
-tyVarsOfType :: Type -> TyVarSet
--- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
-tyVarsOfType (TyVarTy tv)     = unitVarSet tv
-tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
-tyVarsOfType (PredTy sty)     = tyVarsOfPred sty
-tyVarsOfType (FunTy arg res)  = tyVarsOfType arg `unionVarSet` tyVarsOfType res
-tyVarsOfType (AppTy fun arg)  = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder 
-	     	       	      -- can mention type variables!
-  | isTyVar tv		      = inner_tvs `delVarSet` tv
-  | otherwise  {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) )
-                                inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv)
-  where
-    inner_tvs = tyVarsOfType ty
+mkClassPred :: Class -> [Type] -> PredType
+mkClassPred clas tys = ClassP clas tys
 
-tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+isDictTy :: Type -> Bool
+isDictTy ty = case splitPredTy_maybe ty of
+                Just p  -> isClassPred p
+		Nothing -> False
+
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys
+isTyVarClassPred _              = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _                 = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys _ = panic "getClassPredTys"
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (ClassP clas tys)
+
+isDictLikeTy :: Type -> Bool
+-- Note [Dictionary-like types]
+isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
+isDictLikeTy (PredTy p) = isClassPred p
+isDictLikeTy (TyConApp tc tys) 
+  | isTupleTyCon tc     = all isDictLikeTy tys
+isDictLikeTy _          = False
+\end{code}
 
-tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty)    = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys)   = tyVarsOfTypes tys
-tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+Note [Dictionary-like types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Being "dictionary-like" means either a dictionary type or a tuple thereof.
+In GHC 6.10 we build implication constraints which construct such tuples,
+and if we land up with a binding
+    t :: (C [a], Eq [a])
+    t = blah
+then we want to treat t as cheap under "-fdicts-cheap" for example.
+(Implication constraints are normally inlined, but sadly not if the
+occurrence is itself inside an INLINE function!  Until we revise the 
+handling of implication constraints, that is.)  This turned out to
+be important in getting good arities in DPH code.  Example:
+
+    class C a
+    class D a where { foo :: a -> a }
+    instance C a => D (Maybe a) where { foo x = x }
+
+    bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
+    {-# INLINE bar #-}
+    bar x y = (foo (Just x), foo (Just y))
+
+Then 'bar' should jolly well have arity 4 (two dicts, two args), but
+we ended up with something like
+   bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
+                                in \x,y. <blah>)
+
+This is all a bit ad-hoc; eg it relies on knowing that implication
+constraints build tuples.
+
+--------------------- Implicit parameters ---------------------------------
 
-tyVarsOfTheta :: ThetaType -> TyVarSet
-tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+\begin{code}
+mkIPPred :: IPName Name -> Type -> PredType
+mkIPPred ip ty = IParam ip ty
 \end{code}
 
-
 %************************************************************************
 %*									*
                    Size									
@@ -867,14 +872,9 @@ typeSize :: Type -> Int
 typeSize (TyVarTy _)     = 1
 typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
-typeSize (PredTy p)      = predSize p
+typeSize (PredTy p)      = predSize typeSize p
 typeSize (ForAllTy _ t)  = 1 + typeSize t
 typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
-
-predSize :: PredType -> Int
-predSize (IParam _ t)   = 1 + typeSize t
-predSize (ClassP _ ts)  = 1 + sum (map typeSize ts)
-predSize (EqPred t1 t2) = typeSize t1 + typeSize t2
 \end{code}
 
 
@@ -904,8 +904,37 @@ predFamInsts :: PredType -> [(TyCon, [Type])]
 predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
 predFamInsts (IParam _ ty)     = tyFamInsts ty
 predFamInsts (EqPred ty1 ty2)  = tyFamInsts ty1 ++ tyFamInsts ty2
-\end{code}
 
+mkFamilyTyConApp :: TyCon -> [Type] -> Type
+-- ^ Given a family instance TyCon and its arg types, return the
+-- corresponding family type.  E.g:
+--
+-- > data family T a
+-- > data instance T (Maybe b) = MkT b
+--
+-- Where the instance tycon is :RTL, so:
+--
+-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)
+mkFamilyTyConApp tc tys
+  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
+  , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
+  = mkTyConApp fam_tc (substTys fam_subst fam_tys)
+  | otherwise
+  = mkTyConApp tc tys
+
+-- | Pretty prints a 'TyCon', using the family instance in case of a
+-- representation tycon.  For example:
+--
+-- > data T [a] = ...
+--
+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
+pprSourceTyCon :: TyCon -> SDoc
+pprSourceTyCon tycon 
+  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+  = ppr $ fam_tc `TyConApp` tys	       -- can't be FunTyCon
+  | otherwise
+  = ppr tycon
+\end{code}
 
 %************************************************************************
 %*									*
@@ -924,6 +953,7 @@ isUnLiftedType :: Type -> Bool
 
 isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
 isUnLiftedType (ForAllTy _ ty)   = isUnLiftedType ty
+isUnLiftedType (PredTy p)        = isEqPred p
 isUnLiftedType (TyConApp tc _)   = isUnLiftedTyCon tc
 isUnLiftedType _                 = False
 
@@ -949,9 +979,9 @@ isAlgType ty
 isClosedAlgType :: Type -> Bool
 isClosedAlgType ty
   = case splitTyConApp_maybe ty of
-      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
-			    isAlgTyCon tc && not (isFamilyTyCon tc)
-      _other	         -> False
+      Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
 \end{code}
 
 \begin{code}
@@ -977,7 +1007,8 @@ isStrictType _                 = False
 --  poking the dictionary component, which is wrong.)
 isStrictPred :: PredType -> Bool
 isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred _               = False
+isStrictPred (EqPred {})     = True
+isStrictPred (IParam {})     = False
 \end{code}
 
 \begin{code}
@@ -994,6 +1025,64 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of
 
 %************************************************************************
 %*									*
+          The "exact" free variables of a type
+%*									*
+%************************************************************************
+
+Note [Silly type synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+	type T a = Int
+What are the free tyvars of (T x)?  Empty, of course!  
+Here's the example that Ralf Laemmel showed me:
+	foo :: (forall a. C u a -> C u a) -> u
+	mappend :: Monoid u => u -> u -> u
+
+	bar :: Monoid u => u
+	bar = foo (\t -> t `mappend` t)
+We have to generalise at the arg to f, and we don't
+want to capture the constraint (Monad (C u a)) because
+it appears to mention a.  Pretty silly, but it was useful to him.
+
+exactTyVarsOfType is used by the type checker to figure out exactly
+which type variables are mentioned in a type.  It's also used in the
+smart-app checking code --- see TcExpr.tcIdApp
+
+On the other hand, consider a *top-level* definition
+	f = (\x -> x) :: T a -> T a
+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
+if we have an application like (f "x") we get a confusing error message 
+involving Any.  So the conclusion is this: when generalising
+  - at top level use tyVarsOfType
+  - in nested bindings use exactTyVarsOfType
+See Trac #1813 for example.
+
+\begin{code}
+exactTyVarsOfType :: Type -> TyVarSet
+-- Find the free type variables (of any kind)
+-- but *expand* type synonyms.  See Note [Silly type synonym] above.
+exactTyVarsOfType ty
+  = go ty
+  where
+    go ty | Just ty' <- tcView ty = go ty'	-- This is the key line
+    go (TyVarTy tv)         = unitVarSet tv
+    go (TyConApp _ tys)     = exactTyVarsOfTypes tys
+    go (PredTy ty)	    = go_pred ty
+    go (FunTy arg res)	    = go arg `unionVarSet` go res
+    go (AppTy fun arg)	    = go fun `unionVarSet` go arg
+    go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
+
+    go_pred (IParam _ ty)    = go ty
+    go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
+    go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
+
+exactTyVarsOfTypes :: [Type] -> TyVarSet
+exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Sequencing on types}
 %*									*
 %************************************************************************
@@ -1003,7 +1092,7 @@ seqType :: Type -> ()
 seqType (TyVarTy tv) 	  = tv `seq` ()
 seqType (AppTy t1 t2) 	  = seqType t1 `seq` seqType t2
 seqType (FunTy t1 t2) 	  = seqType t1 `seq` seqType t2
-seqType (PredTy p) 	  = seqPred p
+seqType (PredTy p)        = seqPred seqType p
 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
 
@@ -1011,115 +1100,40 @@ seqTypes :: [Type] -> ()
 seqTypes []       = ()
 seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
 
-seqPred :: PredType -> ()
-seqPred (ClassP c tys)   = c `seq` seqTypes tys
-seqPred (IParam n ty)    = n `seq` seqType ty
-seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2
+seqPred :: (a -> ()) -> Pred a -> ()
+seqPred seqt (ClassP c tys)   = c `seq` foldr (seq . seqt) () tys
+seqPred seqt (IParam n ty)    = n `seq` seqt ty
+seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2
 \end{code}
 
 
 %************************************************************************
 %*									*
-		Equality for Core types 
+		Comparision for types 
 	(We don't use instances so that we know where it happens)
 %*									*
 %************************************************************************
 
-Note that eqType works right even for partial applications of newtypes.
-See Note [Newtype eta] in TyCon.lhs
-
 \begin{code}
--- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
-coreEqType :: Type -> Type -> Bool
-coreEqType t1 t2 = coreEqType2 rn_env t1 t2
-  where
-    rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
-
-coreEqType2 :: RnEnv2 -> Type -> Type -> Bool
-coreEqType2 rn_env t1 t2
-  = eq rn_env t1 t2
-  where
-    eq env (TyVarTy tv1)       (TyVarTy tv2)     = rnOccL env tv1 == rnOccR env tv2
-    eq env (ForAllTy tv1 t1)   (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2
-    eq env (AppTy s1 t1)       (AppTy s2 t2)     = eq env s1 s2 && eq env t1 t2
-    eq env (FunTy s1 t1)       (FunTy s2 t2)     = eq env s1 s2 && eq env t1 t2
-    eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2) 
-	| tc1 == tc2, all2 (eq env) tys1 tys2 = True
-			-- The lengths should be equal because
-			-- the two types have the same kind
-	-- NB: if the type constructors differ that does not 
-	--     necessarily mean that the types aren't equal
-	--     (synonyms, newtypes)
-	-- Even if the type constructors are the same, but the arguments
-	-- differ, the two types could be the same (e.g. if the arg is just
-	-- ignored in the RHS).  In both these cases we fall through to an 
-	-- attempt to expand one side or the other.
-
-	-- Now deal with newtypes, synonyms, pred-tys
-    eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 
-		 | Just t2' <- coreView t2 = eq env t1 t2' 
-
-	-- Fall through case; not equal!
-    eq _ _ _ = False
-\end{code}
-
+eqKind :: Kind -> Kind -> Bool
+eqKind = eqType
 
-%************************************************************************
-%*									*
-		Comparision for source types 
-	(We don't use instances so that we know where it happens)
-%*									*
-%************************************************************************
-
-\begin{code}
-tcEqType :: Type -> Type -> Bool
+eqType :: Type -> Type -> Bool
 -- ^ Type equality on source types. Does not look through @newtypes@ or 
 -- 'PredType's, but it does look through type synonyms.
-tcEqType t1 t2 = isEqual $ cmpType t1 t2
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-
-tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or 
--- 'PredType's, but it does look through type synonyms.
-tcCmpType t1 t2 = cmpType t1 t2
+eqType t1 t2 = isEqual $ cmpType t1 t2
 
-tcCmpTypes :: [Type] -> [Type] -> Ordering
-tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
+eqTypeX :: RnEnv2 -> Type -> Type -> Bool
+eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
 
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
+eqTypes :: [Type] -> [Type] -> Bool
+eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
 
-tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
-tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
+eqPred :: PredType -> PredType -> Bool
+eqPred p1 p2 = isEqual $ cmpPred p1 p2
 
-tcCmpPred :: PredType -> PredType -> Ordering
-tcCmpPred p1 p2 = cmpPred p1 p2
-
-tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool
-tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-\end{code}
-
-\begin{code}
--- | Checks whether the second argument is a subterm of the first.  (We don't care
--- about binders, as we are only interested in syntactic subterms.)
-tcPartOfType :: Type -> Type -> Bool
-tcPartOfType t1              t2 
-  | tcEqType t1 t2              = True
-tcPartOfType t1              t2 
-  | Just t2' <- tcView t2       = tcPartOfType t1 t2'
-tcPartOfType _  (TyVarTy _)     = False
-tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
-tcPartOfType t1 (AppTy s2 t2)   = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (FunTy s2 t2)   = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (PredTy p2)     = tcPartOfPred t1 p2
-tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
-
-tcPartOfPred :: Type -> PredType -> Bool
-tcPartOfPred t1 (IParam _ t2)  = tcPartOfType t1 t2
-tcPartOfPred t1 (ClassP _ ts)  = any (tcPartOfType t1) ts
-tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+eqPredX :: RnEnv2 -> PredType -> PredType -> Bool
+eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
 \end{code}
 
 Now here comes the real worker
@@ -1141,8 +1155,13 @@ cmpPred p1 p2 = cmpPredX rn_env p1 p2
     rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2))
 
 cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering	-- Main workhorse
-cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2
-		   | Just t2' <- tcView t2 = cmpTypeX env t1 t2'
+cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2
+		   | Just t2' <- coreView t2 = cmpTypeX env t1 t2'
+-- We expand predicate types, because in Core-land we have
+-- lots of definitions like
+--      fOrdBool :: Ord Bool
+--      fOrdBool = D:Ord .. .. ..
+-- So the RHS has a data type
 
 cmpTypeX env (TyVarTy tv1)       (TyVarTy tv2)       = rnOccL env tv1 `compare` rnOccR env tv2
 cmpTypeX env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
@@ -1199,8 +1218,8 @@ PredTypes are used as a FM key in TcSimplify,
 so we take the easy path and make them an instance of Ord
 
 \begin{code}
-instance Eq  PredType where { (==)    = tcEqPred }
-instance Ord PredType where { compare = tcCmpPred }
+instance Eq  PredType where { (==)    = eqPred }
+instance Ord PredType where { compare = cmpPred }
 \end{code}
 
 
@@ -1211,81 +1230,6 @@ instance Ord PredType where { compare = tcCmpPred }
 %************************************************************************
 
 \begin{code}
--- | Type substitution
---
--- #tvsubst_invariant#
--- The following invariants must hold of a 'TvSubst':
--- 
--- 1. The in-scope set is needed /only/ to
--- guide the generation of fresh uniques
---
--- 2. In particular, the /kind/ of the type variables in 
--- the in-scope set is not relevant
---
--- 3. The substition is only applied ONCE! This is because
--- in general such application will not reached a fixed point.
-data TvSubst 		
-  = TvSubst InScopeSet 	-- The in-scope type variables
-	    TvSubstEnv	-- The substitution itself
-	-- See Note [Apply Once]
-	-- and Note [Extending the TvSubstEnv]
-
-{- ----------------------------------------------------------
-
-Note [Apply Once]
-~~~~~~~~~~~~~~~~~
-We use TvSubsts to instantiate things, and we might instantiate
-	forall a b. ty
-\with the types
-	[a, b], or [b, a].
-So the substition might go [a->b, b->a].  A similar situation arises in Core
-when we find a beta redex like
-	(/\ a /\ b -> e) b a
-Then we also end up with a substition that permutes type variables. Other
-variations happen to; for example [a -> (a, b)].  
-
-	***************************************************
-	*** So a TvSubst must be applied precisely once ***
-	***************************************************
-
-A TvSubst is not idempotent, but, unlike the non-idempotent substitution
-we use during unifications, it must not be repeatedly applied.
-
-Note [Extending the TvSubst]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #tvsubst_invariant# for the invariants that must hold.
-
-This invariant allows a short-cut when the TvSubstEnv is empty:
-if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
-then (substTy subst ty) does nothing.
-
-For example, consider:
-	(/\a. /\b:(a~Int). ...b..) Int
-We substitute Int for 'a'.  The Unique of 'b' does not change, but
-nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
-
-This invariant has several crucial consequences:
-
-* In substTyVarBndr, we need extend the TvSubstEnv 
-	- if the unique has changed
-	- or if the kind has changed
-
-* In substTyVar, we do not need to consult the in-scope set;
-  the TvSubstEnv is enough
-
-* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
-  
-
--------------------------------------------------------------- -}
-
--- | A substitition of 'Type's for 'TyVar's
-type TvSubstEnv = TyVarEnv Type
-	-- A TvSubstEnv is used both inside a TvSubst (with the apply-once
-	-- invariant discussed in Note [Apply Once]), and also independently
-	-- in the middle of matching, and unification (see Types.Unify)
-	-- So you have to look at the context to know if it's idempotent or
-	-- apply-once or whatever
-
 emptyTvSubstEnv :: TvSubstEnv
 emptyTvSubstEnv = emptyVarEnv
 
@@ -1303,11 +1247,11 @@ composeTvSubst in_scope env1 env2
     subst1 = TvSubst in_scope env1
 
 emptyTvSubst :: TvSubst
-emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
+emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv
 
 isEmptyTvSubst :: TvSubst -> Bool
 	 -- See Note [Extending the TvSubstEnv]
-isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv
 
 mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
 mkTvSubst = TvSubst
@@ -1321,34 +1265,34 @@ getTvInScope (TvSubst in_scope _) = in_scope
 isInScope :: Var -> TvSubst -> Bool
 isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
 
-notElemTvSubst :: TyVar -> TvSubst -> Bool
-notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
+notElemTvSubst :: TyCoVar -> TvSubst -> Bool
+notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv)
 
 setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
-setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
+setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv
 
 zapTvSubstEnv :: TvSubst -> TvSubst
 zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv
 
 extendTvInScope :: TvSubst -> Var -> TvSubst
-extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env
+extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv
 
 extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
-extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv
 
 extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
-extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
+extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty)
 
 extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
-extendTvSubstList (TvSubst in_scope env) tvs tys 
-  = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
+extendTvSubstList (TvSubst in_scope tenv) tvs tys 
+  = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys))
 
 unionTvSubst :: TvSubst -> TvSubst -> TvSubst
 -- Works when the ranges are disjoint
-unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
-  = ASSERT( not (env1 `intersectsVarEnv` env2) )
+unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2)
+  = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) )
     TvSubst (in_scope1 `unionInScope` in_scope2)
-            (env1      `plusVarEnv`   env2)
+            (tenv1     `plusVarEnv`   tenv2)
 
 -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
 -- the types given; but it's just a thunk so with a bit of luck
@@ -1370,7 +1314,7 @@ unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
 -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
 -- environment, hence "open"
 mkOpenTvSubst :: TvSubstEnv -> TvSubst
-mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv
 
 -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
 -- environment, hence "open"
@@ -1396,7 +1340,7 @@ zipTopTvSubst tyvars tys
 zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
 zipTyEnv tyvars tys
   | debugIsOn && (length tyvars /= length tys)
-  = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
+  = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv
   | otherwise
   = zip_ty_env tyvars tys emptyVarEnv
 
@@ -1421,10 +1365,10 @@ zip_ty_env tvs      tys      env   = pprTrace "Var/Type length mismatch: " (ppr
 -- zip_ty_env _ _ env = env
 
 instance Outputable TvSubst where
-  ppr (TvSubst ins env) 
+  ppr (TvSubst ins tenv)
     = brackets $ sep[ ptext (sLit "TvSubst"),
 		      nest 2 (ptext (sLit "In scope:") <+> ppr ins), 
-		      nest 2 (ptext (sLit "Env:") <+> ppr env) ]
+		      nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ]
 \end{code}
 
 %************************************************************************
@@ -1499,29 +1443,34 @@ subst_ty subst ty
                                  ForAllTy tv' $! (subst_ty subst' ty)
 
 substTyVar :: TvSubst -> TyVar  -> Type
-substTyVar subst@(TvSubst _ _) tv
-  = case lookupTyVar subst tv of {
-	Nothing -> TyVarTy tv;
-       	Just ty -> ty	-- See Note [Apply Once]
-    } 
+substTyVar (TvSubst _ tenv) tv
+  | Just ty  <- lookupVarEnv tenv tv      = ty  -- See Note [Apply Once]
+  | otherwise = ASSERT( isTyVar tv ) TyVarTy tv
+  -- We do not require that the tyvar is in scope
+  -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau)
+  -- and it's a nuisance to bring all the free vars of tau into
+  -- scope --- and then force that thunk at every tyvar
+  -- Instead we have an ASSERT in substTyVarBndr to check for capture
 
 substTyVars :: TvSubst -> [TyVar] -> [Type]
 substTyVars subst tvs = map (substTyVar subst) tvs
 
 lookupTyVar :: TvSubst -> TyVar  -> Maybe Type
 	-- See Note [Extending the TvSubst]
-lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv
+lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv
 
-substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)	
-substTyVarBndr subst@(TvSubst in_scope env) old_var
-  = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
+substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
+substTyVarBndr subst@(TvSubst in_scope tenv) old_var
+  = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) 
+    (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
   where
-    is_co_var = isCoVar old_var
+    new_env | no_change = delVarEnv tenv old_var
+	    | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
 
-    new_env | no_change = delVarEnv env old_var
-	    | otherwise = extendVarEnv env old_var (TyVarTy new_var)
+    _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv))
+    -- Check that we are not capturing something in the substitution
 
-    no_change = new_var == old_var && not is_co_var
+    no_change = new_var == old_var
 	-- no_change means that the new_var is identical in
 	-- all respects to the old_var (same unique, same kind)
 	-- See Note [Extending the TvSubst]
@@ -1532,14 +1481,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var
 	--	(\x.e) with id_subst = [x |-> e']
 	-- Here we must simply zap the substitution for x
 
-    new_var = uniqAway in_scope subst_old_var
+    new_var = uniqAway in_scope old_var
 	-- The uniqAway part makes sure the new variable is not already in scope
-
-    subst_old_var -- subst_old_var is old_var with the substitution applied to its kind
-		  -- It's only worth doing the substitution for coercions,
-		  -- becuase only they can have free type variables
-	| is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var))
-	| otherwise = old_var
 \end{code}
 
 ----------------------------------------------------
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index a7cfd5a..db41403 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -7,44 +7,35 @@
 \begin{code}
 -- We expose the relevant stuff from this module via the Type module
 {-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
 module TypeRep (
 	TyThing(..), 
 	Type(..),
-	PredType(..),	 		-- to friends
+        Pred(..),                       -- to friends
 	
- 	Kind, ThetaType,		-- Synonyms
+        Kind, SuperKind,
+        PredType, ThetaType,      -- Synonyms
 
-	funTyCon, funTyConName,
+        -- Functions over types
+        mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
+        isLiftedTypeKind, isCoercionKind, 
 
-	-- Pretty-printing
+        -- Pretty-printing
 	pprType, pprParendType, pprTypeApp,
 	pprTyThing, pprTyThingCategory, 
-	pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-
-	-- Kinds
-	liftedTypeKind, unliftedTypeKind, openTypeKind,
-        argTypeKind, ubxTupleKind, ecKind,
-	isLiftedTypeKindCon, isLiftedTypeKind,
-	mkArrowKind, mkArrowKinds, isCoercionKind,
-  	coVarPred,
-
-        -- Kind constructors...
-        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-        argTypeKindTyCon, ubxTupleKindTyCon,
-
-        -- And their names
-        unliftedTypeKindTyConName, openTypeKindTyConName,
-        ubxTupleKindTyConName, argTypeKindTyConName,
-        liftedTypeKindTyConName,
-
-        -- Super Kinds
-	tySuperKind, coSuperKind,
-        isTySuperKind, isCoSuperKind,
-	tySuperKindTyCon, coSuperKindTyCon,
-        
-	pprKind, pprParendKind
+	pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
+        pprKind, pprParendKind,
+	Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
+        pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow,
+
+        -- Free variables
+        tyVarsOfType, tyVarsOfTypes,
+        tyVarsOfPred, tyVarsOfTheta,
+	varsOfPred, varsOfTheta,
+	predSize,
+
+        -- Substitutions
+        TvSubst(..), TvSubstEnv
     ) where
 
 #include "HsVersions.h"
@@ -53,6 +44,8 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName )
 
 -- friends:
 import Var
+import VarEnv
+import VarSet
 import Name
 import BasicTypes
 import TyCon
@@ -62,9 +55,12 @@ import Class
 import PrelNames
 import Outputable
 import FastString
+import Pair
 
 -- libraries
-import Data.Data hiding ( TyCon )
+import qualified Data.Data        as Data hiding ( TyCon )
+import qualified Data.Foldable    as Data
+import qualified Data.Traversable as Data
 \end{code}
 
 	----------------------
@@ -120,13 +116,14 @@ to cut all loops.  The other members of the loop may be marked 'non-recursive'.
 \begin{code}
 -- | The key representation of types within the compiler
 data Type
-  = TyVarTy TyVar	-- ^ Vanilla type variable
+  = TyVarTy TyVar	-- ^ Vanilla type variable (*never* a coercion variable)
 
   | AppTy
 	Type
 	Type		-- ^ Type application to something other than a 'TyCon'. Parameters:
 	                --
-	                --  1) Function: must /not/ be a 'TyConApp', must be another 'AppTy', or 'TyVarTy'
+                        --  1) Function: must /not/ be a 'TyConApp',
+                        --     must be another 'AppTy', or 'TyVarTy'
 	                --
 	                --  2) Argument type
 
@@ -135,31 +132,35 @@ data Type
 	[Type]		-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
 	                -- Invariant: saturated appliations of 'FunTyCon' must
 	                -- use 'FunTy' and saturated synonyms must use their own
-	                -- constructors. However, /unsaturated/ 'FunTyCon's do appear as 'TyConApp's.
+                        -- constructors. However, /unsaturated/ 'FunTyCon's
+                        -- do appear as 'TyConApp's.
 	                -- Parameters:
 	                --
 	                -- 1) Type constructor being applied to.
 	                --
-	                -- 2) Type arguments. Might not have enough type arguments here to saturate the constructor.
-	                -- Even type synonyms are not necessarily saturated; for example unsaturated type synonyms
-	                -- can appear as the right hand side of a type synonym.
+                        -- 2) Type arguments. Might not have enough type arguments
+                        --    here to saturate the constructor.
+                        --    Even type synonyms are not necessarily saturated;
+                        --    for example unsaturated type synonyms
+	                --    can appear as the right hand side of a type synonym.
 
   | FunTy
-	Type
+	Type		
 	Type		-- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@
+			-- See Note [Equality-constrained types]
 
   | ForAllTy
-	TyVar
+	TyCoVar         -- Type variable
 	Type	        -- ^ A polymorphic type
 
   | PredTy
 	PredType	-- ^ The type of evidence for a type predictate.
                         -- Note that a @PredTy (EqPred _ _)@ can appear only as the kind
-	                -- of a coercion variable; never as the argument or result
-	                -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
+                        -- of a coercion variable; never as the argument or result of a
+                        -- 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
 	                
 	                -- See Note [PredTy], and Note [Equality predicates]
-  deriving (Data, Typeable)
+  deriving (Data.Data, Data.Typeable)
 
 -- | The key type representing kinds in the compiler.
 -- Invariant: a kind is always in one of these forms:
@@ -177,6 +178,15 @@ type Kind = Type
 type SuperKind = Type
 \end{code}
 
+Note [Equality-constrained types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type   forall ab. (a ~ [b]) => blah
+is encoded like this:
+
+   ForAllTy (a:*) $ ForAllTy (b:*) $
+   FunTy (PredTy (EqPred a [b]) $
+   blah
+
 -------------------------------------
  		Note [PredTy]
 
@@ -197,11 +207,13 @@ type SuperKind = Type
 -- > h :: (r\l) => {r} => {l::Int | r}
 --
 -- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"
-data PredType 
-  = ClassP Class [Type]		-- ^ Class predicate e.g. @Eq a@
-  | IParam (IPName Name) Type	-- ^ Implicit parameter e.g. @?x :: Int@
-  | EqPred Type Type		-- ^ Equality predicate e.g @ty1 ~ ty2@
-  deriving (Data, Typeable)
+type PredType = Pred Type
+
+data Pred a   -- Typically 'a' is instantiated with Type or Coercion
+  = ClassP Class [a]            -- ^ Class predicate e.g. @Eq a@
+  | IParam (IPName Name) a      -- ^ Implicit parameter e.g. @?x :: Int@
+  | EqPred a a                  -- ^ Equality predicate e.g @ty1 ~ ty2@
+  deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor)
 
 -- | A collection of 'PredType's
 type ThetaType = [PredType]
@@ -240,6 +252,89 @@ name (wildCoVarName), since it's not mentioned.
 
 %************************************************************************
 %*									*
+            Simple constructors
+%*									*
+%************************************************************************
+
+These functions are here so that they can be used by TysPrim,
+which in turn is imported by Type
+
+\begin{code}
+mkTyVarTy  :: TyVar   -> Type
+mkTyVarTy  = TyVarTy
+
+mkTyVarTys :: [TyVar] -> [Type]
+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
+
+-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
+-- Applies its arguments to the constructor from left to right
+mkTyConApp :: TyCon -> [Type] -> Type
+mkTyConApp tycon tys
+  | isFunTyCon tycon, [ty1,ty2] <- tys
+  = FunTy ty1 ty2
+
+  | otherwise
+  = TyConApp tycon tys
+
+-- | Create the plain type constructor type which has been applied to no type arguments at all.
+mkTyConTy :: TyCon -> Type
+mkTyConTy tycon = mkTyConApp tycon []
+
+isLiftedTypeKind :: Kind -> Bool
+-- This function is here because it's used in the pretty printer
+isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey
+isLiftedTypeKind _                = False
+
+isCoercionKind :: Kind -> Bool
+-- All coercions are of form (ty1 ~ ty2)
+-- This function is here rather than in Coercion, because it
+-- is used in a knot-tied way to enforce invariants in Var
+isCoercionKind (PredTy (EqPred {})) = True
+isCoercionKind _                    = False
+\end{code}
+
+
+%************************************************************************
+%*									*
+			Free variables of types and coercions
+%*									*
+%************************************************************************
+
+\begin{code}
+tyVarsOfPred :: PredType -> TyCoVarSet
+tyVarsOfPred = varsOfPred tyVarsOfType
+
+tyVarsOfTheta :: ThetaType -> TyCoVarSet
+tyVarsOfTheta = varsOfTheta tyVarsOfType
+
+tyVarsOfType :: Type -> VarSet
+-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
+tyVarsOfType (TyVarTy v)         = unitVarSet v
+tyVarsOfType (TyConApp _ tys)    = tyVarsOfTypes tys
+tyVarsOfType (PredTy sty)        = varsOfPred tyVarsOfType sty
+tyVarsOfType (FunTy arg res)     = tyVarsOfType arg `unionVarSet` tyVarsOfType res
+tyVarsOfType (AppTy fun arg)     = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
+tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
+
+tyVarsOfTypes :: [Type] -> TyVarSet
+tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
+
+varsOfPred :: (a -> VarSet) -> Pred a -> VarSet
+varsOfPred f (IParam _ ty)    = f ty
+varsOfPred f (ClassP _ tys)   = foldr (unionVarSet . f) emptyVarSet tys
+varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2
+
+varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet
+varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet
+
+predSize :: (a -> Int) -> Pred a -> Int
+predSize size (IParam _ t)   = 1 + size t
+predSize size (ClassP _ ts)  = 1 + sum (map size ts)
+predSize size (EqPred t1 t2) = size t1 + size t2
+\end{code}
+
+%************************************************************************
+%*									*
 			TyThing
 %*									*
 %************************************************************************
@@ -253,6 +348,7 @@ funTyCon and all the types in TysPrim.
 data TyThing = AnId     Id
 	     | ADataCon DataCon
 	     | ATyCon   TyCon
+             | ACoAxiom CoAxiom
 	     | AClass   Class
 
 instance Outputable TyThing where 
@@ -263,6 +359,7 @@ pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
 
 pprTyThingCategory :: TyThing -> SDoc
 pprTyThingCategory (ATyCon _) 	= ptext (sLit "Type constructor")
+pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom")
 pprTyThingCategory (AClass _)   = ptext (sLit "Class")
 pprTyThingCategory (AnId   _)   = ptext (sLit "Identifier")
 pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
@@ -270,6 +367,7 @@ pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
 instance NamedThing TyThing where	-- Can't put this with the type
   getName (AnId id)     = getName id	-- decl, because the DataCon instance
   getName (ATyCon tc)   = getName tc	-- isn't visible there
+  getName (ACoAxiom cc) = getName cc
   getName (AClass cl)   = getName cl
   getName (ADataCon dc) = dataConName dc
 \end{code}
@@ -277,134 +375,92 @@ instance NamedThing TyThing where	-- Can't put this with the type
 
 %************************************************************************
 %*									*
-		Wired-in type constructors
+			Substitutions
+      Data type defined here to avoid unnecessary mutual recursion
 %*									*
 %************************************************************************
 
-We define a few wired-in type constructors here to avoid module knots
-
 \begin{code}
---------------------------
--- First the TyCons...
-
--- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
-funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
-      openTypeKindTyCon, unliftedTypeKindTyCon,
-      ubxTupleKindTyCon, argTypeKindTyCon
-   :: TyCon
-funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
-      openTypeKindTyConName, unliftedTypeKindTyConName,
-      ubxTupleKindTyConName, argTypeKindTyConName
-   :: Name
-
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
-	-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-	-- But if we do that we get kind errors when saying
-	--	instance Control.Arrow (->)
-	-- becuase the expected kind is (*->*->*).  The trouble is that the
-	-- expected/actual stuff in the unifier does not go contra-variant, whereas
-	-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
-	-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
-
-
-tySuperKindTyCon     = mkSuperKindTyCon tySuperKindTyConName
-coSuperKindTyCon     = mkSuperKindTyCon coSuperKindTyConName
-
-liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
-openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
-ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName     tySuperKind
-argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName      tySuperKind
-
---------------------------
--- ... and now their names
-
-tySuperKindTyConName      = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
-coSuperKindTyConName      = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon
-liftedTypeKindTyConName   = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
-openTypeKindTyConName     = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
-unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
-ubxTupleKindTyConName     = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
-argTypeKindTyConName      = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
-funTyConName              = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
-
-mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
-mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) 
-					      key 
-					      (ATyCon tycon)
-					      BuiltInSyntax
-	-- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
-	-- because they are never in scope in the source
-
-------------------
--- We also need Kinds and SuperKinds, locally and in TyCon
-
-kindTyConType :: TyCon -> Type
-kindTyConType kind = TyConApp kind []
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, ecKind :: Kind
-
-liftedTypeKind   = kindTyConType liftedTypeKindTyCon
-unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
-openTypeKind     = kindTyConType openTypeKindTyCon
-argTypeKind      = kindTyConType argTypeKindTyCon
-ubxTupleKind	 = kindTyConType ubxTupleKindTyCon
-ecKind           = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
--- NOTE: if you change ecKind, you must also change the explicit kind signatures
--- on hetmet_{brak,esc,csp} in GHC.Hetmet.CodeTypes
+-- | Type substitution
+--
+-- #tvsubst_invariant#
+-- The following invariants must hold of a 'TvSubst':
+-- 
+-- 1. The in-scope set is needed /only/ to
+-- guide the generation of fresh uniques
+--
+-- 2. In particular, the /kind/ of the type variables in 
+-- the in-scope set is not relevant
+--
+-- 3. The substition is only applied ONCE! This is because
+-- in general such application will not reached a fixed point.
+data TvSubst 		
+  = TvSubst InScopeSet 	-- The in-scope type variables
+	    TvSubstEnv	-- Substitution of types
+	-- See Note [Apply Once]
+	-- and Note [Extending the TvSubstEnv]
+
+-- | A substitition of 'Type's for 'TyVar's
+type TvSubstEnv = TyVarEnv Type
+	-- A TvSubstEnv is used both inside a TvSubst (with the apply-once
+	-- invariant discussed in Note [Apply Once]), and also independently
+	-- in the middle of matching, and unification (see Types.Unify)
+	-- So you have to look at the context to know if it's idempotent or
+	-- apply-once or whatever
+\end{code}
 
--- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = FunTy k1 k2
+Note [Apply Once]
+~~~~~~~~~~~~~~~~~
+We use TvSubsts to instantiate things, and we might instantiate
+	forall a b. ty
+\with the types
+	[a, b], or [b, a].
+So the substition might go [a->b, b->a].  A similar situation arises in Core
+when we find a beta redex like
+	(/\ a /\ b -> e) b a
+Then we also end up with a substition that permutes type variables. Other
+variations happen to; for example [a -> (a, b)].  
 
--- | Iterated application of 'mkArrowKind'
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+	***************************************************
+	*** So a TvSubst must be applied precisely once ***
+	***************************************************
 
-tySuperKind, coSuperKind :: SuperKind
-tySuperKind = kindTyConType tySuperKindTyCon 
-coSuperKind = kindTyConType coSuperKindTyCon 
+A TvSubst is not idempotent, but, unlike the non-idempotent substitution
+we use during unifications, it must not be repeatedly applied.
 
-isTySuperKind :: SuperKind -> Bool
-isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind _                = False
+Note [Extending the TvSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #tvsubst_invariant# for the invariants that must hold.
 
-isCoSuperKind :: SuperKind -> Bool
-isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
-isCoSuperKind _                = False
+This invariant allows a short-cut when the TvSubstEnv is empty:
+if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
+then (substTy subst ty) does nothing.
 
--------------------
--- Lastly we need a few functions on Kinds
+For example, consider:
+	(/\a. /\b:(a~Int). ...b..) Int
+We substitute Int for 'a'.  The Unique of 'b' does not change, but
+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
 
-isLiftedTypeKindCon :: TyCon -> Bool
-isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
+This invariant has several crucial consequences:
 
-isLiftedTypeKind :: Kind -> Bool
-isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
-isLiftedTypeKind _                = False
+* In substTyVarBndr, we need extend the TvSubstEnv 
+	- if the unique has changed
+	- or if the kind has changed
 
-isCoercionKind :: Kind -> Bool
--- All coercions are of form (ty1 ~ ty2)
--- This function is here rather than in Coercion, 
--- because it's used in a knot-tied way to enforce invariants in Var
-isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind _                    = False
+* In substTyVar, we do not need to consult the in-scope set;
+  the TvSubstEnv is enough
 
-coVarPred :: CoVar -> PredType
-coVarPred tv
-  = ASSERT( isCoVar tv )
-    case tyVarKind tv of
-	PredTy eq -> eq
-	other	  -> pprPanic "coVarPred" (ppr tv $$ ppr other)
+* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
 \end{code}
 
 
 
 %************************************************************************
 %*									*
-\subsection{The external interface}
-%*									*
+                   Pretty-printing types
+
+       Defined very early because of debug printing in assertions
+%*                                                                      *
 %************************************************************************
 
 @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
@@ -425,43 +481,58 @@ maybeParen ctxt_prec inner_prec pretty
 
 ------------------
 pprType, pprParendType :: Type -> SDoc
-pprType       ty = ppr_type TopPrec   ty
+pprType       ty = ppr_type TopPrec ty
 pprParendType ty = ppr_type TyConPrec ty
 
-pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
--- The first arg is the tycon, or sometimes class
--- Print infix if the tycon/class looks like an operator
-pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind       = pprType
+pprParendKind = pprParendType
 
 ------------------
-pprPred :: PredType -> SDoc
-pprPred (ClassP cls tys) = pprClassPred cls tys
-pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
-pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
-
-pprEqPred :: (Type,Type) -> SDoc
-pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
-                          , nest 2 (ptext (sLit "~"))
-                          , ppr_type FunPrec ty2]
+pprPredTy :: PredType -> SDoc
+pprPredTy = pprPred ppr_type
+
+pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc
+pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys
+pprPred pp (IParam ip ty)   = ppr ip <> dcolon <> pp TopPrec ty
+pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2)
+
+------------
+pprEqPred :: Pair Type -> SDoc
+pprEqPred = ppr_eq_pred ppr_type
+
+ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc
+ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1
+                                    , nest 2 (ptext (sLit "~"))
+                                    , pp FunPrec ty2]
 			       -- Precedence looks like (->) so that we get
 			       --    Maybe a ~ Bool
 			       --    (a->a) ~ Bool
 			       -- Note parens on the latter!
 
+------------
 pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
+pprClassPred = ppr_class_pred ppr_type
+
+ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc
+ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys
 
+------------
 pprTheta :: ThetaType -> SDoc
 -- pprTheta [pred] = pprPred pred	 -- I'm in two minds about this
-pprTheta theta  = parens (sep (punctuate comma (map pprPred theta)))
+pprTheta theta  = parens (sep (punctuate comma (map pprPredTy theta)))
+
+pprThetaArrowTy :: ThetaType -> SDoc
+pprThetaArrowTy = pprThetaArrow ppr_type
 
-pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow []     = empty
-pprThetaArrow [pred] 
-  | noParenPred pred = pprPred pred <+> darrow
-pprThetaArrow preds  = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
+pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc
+pprThetaArrow _ []      = empty
+pprThetaArrow pp [pred]
+      | noParenPred pred = pprPred pp pred <+> darrow
+pprThetaArrow pp preds   = parens (sep (punctuate comma (map (pprPred pp) preds)))
+                            <+> darrow
 
-noParenPred :: PredType -> Bool
+noParenPred :: Pred a -> Bool
 -- A predicate that can appear without parens before a "=>"
 --       C a => a -> a
 --       a~b => a -> b
@@ -474,8 +545,9 @@ noParenPred (IParam {}) = False
 instance Outputable Type where
     ppr ty = pprType ty
 
-instance Outputable PredType where
-    ppr = pprPred
+instance Outputable (Pred Type) where
+    ppr = pprPredTy   -- Not for arbitrary (Pred a), because the
+    	  	      -- (Outputable a) doesn't give precedence
 
 instance Outputable name => OutputableBndr (IPName name) where
     pprBndr _ n = ppr n	-- Simple for now
@@ -483,96 +555,43 @@ instance Outputable name => OutputableBndr (IPName name) where
 ------------------
 	-- OK, here's the main printer
 
-pprKind, pprParendKind :: Kind -> SDoc
-pprKind = pprType
-pprParendKind = pprParendType
-
 ppr_type :: Prec -> Type -> SDoc
 ppr_type _ (TyVarTy tv)	      = ppr_tvar tv
 ppr_type p (PredTy pred)      = maybeParen p TyConPrec $
-                                ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
-ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys
+                                ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred)
+ppr_type p (TyConApp tc tys)  = pprTcApp p ppr_type tc tys
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
 			   pprType t1 <+> ppr_type TyConPrec t2
 
-ppr_type p ty@(ForAllTy _ _)       = ppr_forall_type p ty
+ppr_type p ty@(ForAllTy {})        = ppr_forall_type p ty
 ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
 
 ppr_type p (FunTy ty1 ty2)
-  = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
-    maybeParen p FunPrec $
-    sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+  = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
   where
-    ppr_fun_tail (FunTy ty1 ty2) 
-      | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
-    ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+    -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+    ppr_fun_tail (FunTy ty1 ty2)
+      | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
+    ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
+
     is_pred (PredTy {}) = True
     is_pred _           = False
 
 ppr_forall_type :: Prec -> Type -> SDoc
 ppr_forall_type p ty
   = maybeParen p FunPrec $
-    sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+    sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
   where
     (tvs,  rho) = split1 [] ty
     (ctxt, tau) = split2 [] rho
 
-    -- We need to be extra careful here as equality constraints will occur as
-    -- type variables with an equality kind.  So, while collecting quantified
-    -- variables, we separate the coercion variables out and turn them into
-    -- equality predicates.
-    split1 tvs (ForAllTy tv ty) 
-      | not (isCoVar tv)     = split1 (tv:tvs) ty
-    split1 tvs ty	     = (reverse tvs, ty)
+    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+    split1 tvs ty	        = (reverse tvs, ty)
  
     split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
-    split2 ps (ForAllTy tv ty) 
-	| isCoVar tv		    = split2 (coVarPred tv : ps) ty
     split2 ps ty		    = (reverse ps, ty)
 
-ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app _ tc []
-  = ppr_tc tc
-ppr_tc_app _ tc [ty]
-  | tc `hasKey` listTyConKey = brackets (pprType ty)
-  | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
-  | tc `hasKey` liftedTypeKindTyConKey   = ptext (sLit "*")
-  | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
-  | tc `hasKey` openTypeKindTyConKey     = ptext (sLit "(?)")
-  | tc `hasKey` ubxTupleKindTyConKey     = ptext (sLit "(#)")
-  | tc `hasKey` argTypeKindTyConKey      = ptext (sLit "??")
-
-ppr_tc_app p tc tys
-  | [ecvar,ty] <- tys, tc `hasKey` hetMetCodeTypeTyConKey
-  = ptext (sLit "<[")  <> pprType ty <> ptext (sLit "]>@") <> ppr ecvar
-  | isTupleTyCon tc && tyConArity tc == length tys
-  = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
-  | otherwise
-  = ppr_type_app p (getName tc) tys
-
-ppr_type_app :: Prec -> Name -> [Type] -> SDoc
--- Used for classes as well as types; that's why it's separate from ppr_tc_app
-ppr_type_app p tc tys
-  | is_sym_occ		-- Print infix if possible
-  , [ty1,ty2] <- tys	-- We know nothing of precedence though
-  = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, 
-			       pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
-  | otherwise
-  = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
-    	       	 	       2 (sep (map pprParendType tys)))
-  where
-    is_sym_occ = isSymOcc (getOccName tc)
-
-ppr_tc :: TyCon -> SDoc	-- No brackets for SymOcc
-ppr_tc tc 
-  = pp_nt_debug <> ppr tc
-  where
-   pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
-				             then ptext (sLit "<recnt>")
-					     else ptext (sLit "<nt>"))
-	       | otherwise     = empty
-
 ppr_tvar :: TyVar -> SDoc
 ppr_tvar tv  -- Note [Infix type variables]
   | isSymOcc (getOccName tv)  = parens (ppr tv)
@@ -584,8 +603,9 @@ pprForAll []  = empty
 pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot
 
 pprTvBndr :: TyVar -> SDoc
-pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv
-	     | otherwise	     = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
+pprTvBndr tv 
+  | isLiftedTypeKind kind = ppr_tvar tv
+  | otherwise	          = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
 	     where
 	       kind = tyVarKind tv
 \end{code}
@@ -608,6 +628,59 @@ remember to parenthesise the operator, thus
 
 See Trac #2766.
 
+\begin{code}
+pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+pprTcApp _ _ tc []      -- No brackets for SymOcc
+  = pp_nt_debug <> ppr tc
+  where
+   pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
+				             then ptext (sLit "<recnt>")
+					     else ptext (sLit "<nt>"))
+	       | otherwise     = empty
 
+pprTcApp _ pp tc [ty]
+  | tc `hasKey` listTyConKey = brackets (pp TopPrec ty)
+  | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]")
+  | tc `hasKey` liftedTypeKindTyConKey   = ptext (sLit "*")
+  | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
+  | tc `hasKey` openTypeKindTyConKey     = ptext (sLit "(?)")
+  | tc `hasKey` ubxTupleKindTyConKey     = ptext (sLit "(#)")
+  | tc `hasKey` argTypeKindTyConKey      = ptext (sLit "??")
 
+pprTcApp p pp tc tys
+  | isTupleTyCon tc && tyConArity tc == length tys
+  = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+  | otherwise
+  = pprTypeNameApp p pp (getName tc) tys
+
+----------------
+pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
+-- The first arg is the tycon, or sometimes class
+-- Print infix if the tycon/class looks like an operator
+pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys
+
+pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
+-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
+pprTypeNameApp p pp tc tys
+  | is_sym_occ           -- Print infix if possible
+  , [ty1,ty2] <- tys  -- We know nothing of precedence though
+  = maybeParen p FunPrec $
+    sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2]
+  | otherwise
+  = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys)
+  where
+    is_sym_occ = isSymOcc (getOccName tc)
+
+----------------
+pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
+pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
+                               hang pp_fun 2 (sep pp_tys)
+
+----------------
+pprArrowChain :: Prec -> [SDoc] -> SDoc
+-- pprArrowChain p [a,b,c]  generates   a -> b -> c
+pprArrowChain _ []         = empty
+pprArrowChain p (arg:args) = maybeParen p FunPrec $
+                             sep [arg, sep (map (arrow <+>) args)]
+\end{code}
 
diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot
index d519f62..fe8fd59 100644
--- a/compiler/types/TypeRep.lhs-boot
+++ b/compiler/types/TypeRep.lhs-boot
@@ -2,9 +2,10 @@
 module TypeRep where
 
 data Type
-data PredType
+data Pred a
 data TyThing
 
+type PredType = Pred Type
 type Kind = Type
 
 isCoercionKind :: Kind -> Bool
diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 2acf71e..9c448ce 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -8,9 +8,11 @@ module Unify (
 	--	the "tc" prefix indicates that matching always
 	--	respects newtypes (rather than looking through them)
 	tcMatchTy, tcMatchTys, tcMatchTyX, 
-	ruleMatchTyX, tcMatchPreds, MatchEnv(..),
-	
-	dataConCannotMatch,
+	ruleMatchTyX, tcMatchPreds, 
+
+	MatchEnv(..), matchList, 
+
+	typesCantMatch,
 
         -- Side-effect free unification
         tcUnifyTys, BindFlag(..),
@@ -23,16 +25,17 @@ module Unify (
 import Var
 import VarEnv
 import VarSet
+import Kind
 import Type
-import Coercion
 import TyCon
-import DataCon
 import TypeRep
 import Outputable
 import ErrUtils
 import Util
 import Maybes
 import FastString
+
+import Control.Monad (guard)
 \end{code}
 
 
@@ -67,9 +70,11 @@ Matching is much tricker than you might think.
 
 \begin{code}
 data MatchEnv
-  = ME	{ me_tmpls :: VarSet	-- Template tyvars
+  = ME	{ me_tmpls :: VarSet	-- Template variables
  	, me_env   :: RnEnv2	-- Renaming envt for nested foralls
-	}			--   In-scope set includes template tyvars
+	}			--   In-scope set includes template variables
+    -- Nota Bene: MatchEnv isn't specific to Types.  It is used
+    --            for matching terms and coercions as well as types
 
 tcMatchTy :: TyVarSet		-- Template tyvars
 	  -> Type		-- Template
@@ -121,7 +126,7 @@ tcMatchPreds
 	-> [PredType] -> [PredType]
    	-> Maybe TvSubstEnv
 tcMatchPreds tmpls ps1 ps2
-  = match_list (match_pred menv) emptyTvSubstEnv ps1 ps2
+  = matchList (match_pred menv) emptyTvSubstEnv ps1 ps2
   where
     menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars }
     in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2)
@@ -155,9 +160,8 @@ match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2
 
 match menv subst (TyVarTy tv1) ty2
   | Just ty1' <- lookupVarEnv subst tv1'	-- tv1' is already bound
-  = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
+  = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2
 	-- ty1 has no locally-bound variables, hence nukeRnEnvL
-	-- Note tcEqType...we are doing source-type matching here
     then Just subst
     else Nothing	-- ty2 doesn't match
 
@@ -201,14 +205,8 @@ match _ _ _ _
 match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv
 -- Match the kind of the template tyvar with the kind of Type
 -- Note [Matching kinds]
-match_kind menv subst tv ty
-  | isCoVar tv = do { let (ty1,ty2) = coVarKind tv
-			  (ty3,ty4) = coercionKind ty
-		    ; subst1 <- match menv subst ty1 ty3
-		    ; match menv subst1 ty2 ty4 }
-  | otherwise  = if typeKind ty `isSubKind` tyVarKind tv
-		 then Just subst
-		 else Nothing
+match_kind _ subst tv ty
+  = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst
 
 -- Note [Matching kinds]
 -- ~~~~~~~~~~~~~~~~~~~~~
@@ -226,15 +224,15 @@ match_kind menv subst tv ty
 
 --------------
 match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv
-match_tys menv subst tys1 tys2 = match_list (match menv) subst tys1 tys2
+match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2
 
 --------------
-match_list :: (TvSubstEnv -> a -> a -> Maybe TvSubstEnv)
-	   -> TvSubstEnv -> [a] -> [a] -> Maybe TvSubstEnv
-match_list _  subst []         []         = Just subst
-match_list fn subst (ty1:tys1) (ty2:tys2) = do	{ subst' <- fn subst ty1 ty2
-						; match_list fn subst' tys1 tys2 }
-match_list _  _     _          _          = Nothing
+matchList :: (env -> a -> b -> Maybe env)
+	   -> env -> [a] -> [b] -> Maybe env
+matchList _  subst []     []     = Just subst
+matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b
+				      ; matchList fn subst' as bs }
+matchList _  _     _      _      = Nothing
 
 --------------
 match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv
@@ -318,26 +316,9 @@ anything, type functions (incl newtypes) match anything, and only
 distinct data types fail to match.  We can elaborate later.
 
 \begin{code}
-dataConCannotMatch :: [Type] -> DataCon -> Bool
--- Returns True iff the data con *definitely cannot* match a 
---		    scrutinee of type (T tys)
---		    where T is the type constructor for the data con
---
-dataConCannotMatch tys con
-  | null eq_spec      = False	-- Common
-  | all isTyVarTy tys = False	-- Also common
-  | otherwise
-  = cant_match_s (map (substTyVar subst . fst) eq_spec)
-	         (map snd eq_spec)
+typesCantMatch :: [(Type,Type)] -> Bool
+typesCantMatch prs = any (\(s,t) -> cant_match s t) prs
   where
-    dc_tvs  = dataConUnivTyVars con
-    eq_spec = dataConEqSpec con
-    subst   = zipTopTvSubst dc_tvs tys
-
-    cant_match_s :: [Type] -> [Type] -> Bool
-    cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 )
-			     or (zipWith cant_match tys1 tys2)
-
     cant_match :: Type -> Type -> Bool
     cant_match t1 t2
 	| Just t1' <- coreView t1 = cant_match t1' t2
@@ -348,7 +329,7 @@ dataConCannotMatch tys con
 
     cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
 	| isDataTyCon tc1 && isDataTyCon tc2
-	= tc1 /= tc2 || cant_match_s tys1 tys2
+	= tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2)
 
     cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
     cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc
@@ -370,7 +351,6 @@ dataConCannotMatch tys con
 \end{code}
 
 
-
 %************************************************************************
 %*									*
              Unification
@@ -415,7 +395,7 @@ niFixTvSubst env = f env
         | otherwise    = subst
         where
           range_tvs    = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e
-          subst        = mkTvSubst (mkInScopeSet range_tvs) e
+          subst        = mkTvSubst (mkInScopeSet range_tvs) e 
           not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs
           in_domain tv = tv `elemVarEnv` e
 
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index c4a685b..fc4d919 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -15,7 +15,7 @@ module Outputable (
 	Outputable(..), OutputableBndr(..),
 
         -- * Pretty printing combinators
-	SDoc,
+	SDoc, runSDoc, initSDocContext,
 	docToSDoc,
 	interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
 	empty, nest,
@@ -33,6 +33,9 @@ module Outputable (
 	hang, punctuate, ppWhen, ppUnless,
 	speakNth, speakNTimes, speakN, speakNOf, plural,
 
+        coloured, PprColour, colType, colCoerc, colDataCon,
+        colBinder, bold, keyword,
+
         -- * Converting 'SDoc' into strings and outputing it
 	printSDoc, printErrs, printOutput, hPrintDump, printDump,
 	printForC, printForAsm, printForUser, printForUserPartWay,
@@ -41,6 +44,7 @@ module Outputable (
         showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
         showPpr,
 	showSDocUnqual, showsPrecSDoc,
+        renderWithStyle,
 
 	pprInfixVar, pprPrefixVar,
 	pprHsChar, pprHsString, pprHsInfix, pprHsVar,
@@ -218,38 +222,56 @@ code (either C or assembly), or generating interface files.
 %************************************************************************
 
 \begin{code}
-type SDoc = PprStyle -> Doc
+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+
+data SDocContext = SDC
+  { sdocStyle      :: !PprStyle
+  , sdocLastColour :: !PprColour
+    -- ^ The most recently used colour.  This allows nesting colours.
+  }
+
+initSDocContext :: PprStyle -> SDocContext
+initSDocContext sty = SDC
+  { sdocStyle = sty
+  , sdocLastColour = colReset
+  }
 
 withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
 
 withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
 
 pprDeeper :: SDoc -> SDoc
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty        	    = d other_sty
+pprDeeper d = SDoc $ \ctx -> case ctx of
+  SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
+  SDC{sdocStyle=PprUser q (PartWay n)} ->
+    runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+  _ -> runSDoc d ctx
 
 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 -- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds (PprUser q (PartWay n))
-  | n==0      = Pretty.text "..."
-  | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
-  where
-    go _ [] = []
-    go i (d:ds) | i >= n    = [text "...."]
-		| otherwise = d : go (i+1) ds
-
-pprDeeperList f ds other_sty
-  = f ds other_sty
+pprDeeperList f ds = SDoc work
+ where
+  work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
+   | n==0      = Pretty.text "..."
+   | otherwise =
+      runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
+   where
+     go _ [] = []
+     go i (d:ds) | i >= n    = [text "...."]
+                 | otherwise = d : go (i+1) ds
+  work other_ctx = runSDoc (f ds) other_ctx
 
 pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth  doc (PprUser q _) = doc (PprUser q depth)
-pprSetDepth _depth doc other_sty     = doc other_sty
+pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
+  SDC{sdocStyle=PprUser q _} ->
+    runSDoc doc ctx{sdocStyle = PprUser q depth}
+  _ ->
+    runSDoc doc ctx
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
+getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
 \end{code}
 
 \begin{code}
@@ -282,22 +304,24 @@ userStyle (PprUser _ _) = True
 userStyle _other        = False
 
 ifPprDebug :: SDoc -> SDoc	  -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _  	  = Pretty.empty
+ifPprDebug d = SDoc $ \ctx -> case ctx of
+  SDC{sdocStyle=PprDebug} -> runSDoc d ctx
+  _                       -> Pretty.empty
 \end{code}
 
 \begin{code}
 -- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
 printSDoc d sty = do
-  Pretty.printDoc PageMode stdout (d sty)
+  Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
   hFlush stdout
 
 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
-		   hFlush stderr
+printErrs :: SDoc -> PprStyle -> IO ()
+printErrs doc sty = do
+  Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
+  hFlush stderr
 
 printOutput :: Doc -> IO ()
 printOutput doc = Pretty.printDoc PageMode stdout doc
@@ -307,25 +331,32 @@ printDump doc = hPrintDump stdout doc
 
 hPrintDump :: Handle -> SDoc -> IO ()
 hPrintDump h doc = do
-   Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+   Pretty.printDoc PageMode h
+     (runSDoc better_doc (initSDocContext defaultDumpStyle))
    hFlush h
  where
    better_doc = doc $$ blankLine
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+  = Pretty.printDoc PageMode handle
+      (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 printForUserPartWay handle d unqual doc
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+  = Pretty.printDoc PageMode handle
+      (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
 
 -- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc =
+  Pretty.printDoc LeftMode handle
+    (runSDoc doc (initSDocContext (PprCode CStyle)))
 
 printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc =
+  Pretty.printDoc LeftMode handle
+    (runSDoc doc (initSDocContext (PprCode AsmStyle)))
 
 pprCode :: CodeStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
@@ -337,32 +368,44 @@ mkCodeStyle = PprCode
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
 showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d =
+  Pretty.showDocWith PageMode
+    (runSDoc d (initSDocContext defaultUserStyle))
+
+renderWithStyle :: SDoc -> PprStyle -> String
+renderWithStyle sdoc sty =
+  Pretty.render (runSDoc sdoc (initSDocContext sty))
 
 -- This shows an SDoc, but on one line only. It's cheaper than a full
 -- showSDoc, designed for when we're getting results like "Foo.bar"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d =
+  Pretty.showDocWith PageMode
+    (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc =
+  show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 showSDocUnqual :: SDoc -> String
 -- Only used in the gruesome isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d =
+  show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocDump :: SDoc -> String
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d =
+  Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
 
 showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d =
+  Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
 
 showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
 
 showPpr :: Outputable a => a -> String
 showPpr = showSDoc . ppr
@@ -370,7 +413,7 @@ showPpr = showSDoc . ppr
 
 \begin{code}
 docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
+docToSDoc d = SDoc (\_ -> d)
 
 empty    :: SDoc
 char     :: Char       -> SDoc
@@ -383,58 +426,58 @@ float    :: Float      -> SDoc
 double   :: Double     -> SDoc
 rational :: Rational   -> SDoc
 
-empty _sty      = Pretty.empty
-char c _sty     = Pretty.char c
-text s _sty     = Pretty.text s
-ftext s _sty    = Pretty.ftext s
-ptext s _sty    = Pretty.ptext s
-int n _sty      = Pretty.int n
-integer n _sty  = Pretty.integer n
-float n _sty    = Pretty.float n
-double n _sty   = Pretty.double n
-rational n _sty = Pretty.rational n
+empty       = docToSDoc $ Pretty.empty
+char c      = docToSDoc $ Pretty.char c
+text s      = docToSDoc $ Pretty.text s
+ftext s     = docToSDoc $ Pretty.ftext s
+ptext s     = docToSDoc $ Pretty.ptext s
+int n       = docToSDoc $ Pretty.int n
+integer n   = docToSDoc $ Pretty.integer n
+float n     = docToSDoc $ Pretty.float n
+double n    = docToSDoc $ Pretty.double n
+rational n  = docToSDoc $ Pretty.rational n
 
 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 
-parens d sty       = Pretty.parens (d sty)
-braces d sty       = Pretty.braces (d sty)
-brackets d sty     = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d    = char '<' <> d <> char '>'
+parens d       = SDoc $ Pretty.parens . runSDoc d
+braces d       = SDoc $ Pretty.braces . runSDoc d
+brackets d     = SDoc $ Pretty.brackets . runSDoc d
+doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+angleBrackets d = char '<' <> d <> char '>'
 
 cparen :: Bool -> SDoc -> SDoc
 
-cparen b d sty       = Pretty.cparen b (d sty)
+cparen b d     = SDoc $ Pretty.cparen b . runSDoc d
 
 -- quotes encloses something in single quotes...
 -- but it omits them if the thing ends in a single quote
 -- so that we don't get `foo''.  Instead we just have foo'.
-quotes d sty = case show pp_d of
-		 ('\'' : _) -> pp_d
-		 _other	    -> Pretty.quotes pp_d
-	     where
-	       pp_d = d sty
+quotes d = SDoc $ \sty -> 
+           let pp_d = runSDoc d sty in
+           case show pp_d of
+             ('\'' : _) -> pp_d
+             _other     -> Pretty.quotes pp_d
 
 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 
-blankLine _sty = Pretty.ptext (sLit "")
-dcolon _sty    = Pretty.ptext (sLit "::")
-arrow  _sty    = Pretty.ptext (sLit "->")
-darrow _sty    = Pretty.ptext (sLit "=>")
-semi _sty      = Pretty.semi
-comma _sty     = Pretty.comma
-colon _sty     = Pretty.colon
-equals _sty    = Pretty.equals
-space _sty     = Pretty.space
-underscore     = char '_'
-dot	       = char '.'
-lparen _sty    = Pretty.lparen
-rparen _sty    = Pretty.rparen
-lbrack _sty    = Pretty.lbrack
-rbrack _sty    = Pretty.rbrack
-lbrace _sty    = Pretty.lbrace
-rbrace _sty    = Pretty.rbrace
+blankLine  = docToSDoc $ Pretty.ptext (sLit "")
+dcolon     = docToSDoc $ Pretty.ptext (sLit "::")
+arrow      = docToSDoc $ Pretty.ptext (sLit "->")
+darrow     = docToSDoc $ Pretty.ptext (sLit "=>")
+semi       = docToSDoc $ Pretty.semi
+comma      = docToSDoc $ Pretty.comma
+colon      = docToSDoc $ Pretty.colon
+equals     = docToSDoc $ Pretty.equals
+space      = docToSDoc $ Pretty.space
+underscore = char '_'
+dot        = char '.'
+lparen     = docToSDoc $ Pretty.lparen
+rparen     = docToSDoc $ Pretty.rparen
+lbrack     = docToSDoc $ Pretty.lbrack
+rbrack     = docToSDoc $ Pretty.rbrack
+lbrace     = docToSDoc $ Pretty.lbrace
+rbrace     = docToSDoc $ Pretty.rbrace
 
 nest :: Int -> SDoc -> SDoc
 -- ^ Indent 'SDoc' some specified amount
@@ -448,11 +491,11 @@ nest :: Int -> SDoc -> SDoc
 ($+$) :: SDoc -> SDoc -> SDoc
 -- ^ Join two 'SDoc' together vertically
 
-nest n d sty    = Pretty.nest n (d sty)
-(<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+nest n d    = SDoc $ Pretty.nest n . runSDoc d
+(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)
+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
+($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)
+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
 
 hcat :: [SDoc] -> SDoc
 -- ^ Concatenate 'SDoc' horizontally
@@ -471,19 +514,19 @@ fcat :: [SDoc] -> SDoc
 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 
 
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty  = Pretty.sep  [d sty | d <- ds]
-cat ds sty  = Pretty.cat  [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
+hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]
+cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]
+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
 
 hang :: SDoc  -- ^ The header
       -> Int  -- ^ Amount to indent the hung body
       -> SDoc -- ^ The hung body, indented and placed below the header
       -> SDoc
-hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
+hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
 
 punctuate :: SDoc   -- ^ The punctuation
           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
@@ -500,6 +543,46 @@ ppWhen False _   = empty
 
 ppUnless True  _   = empty
 ppUnless False doc = doc
+
+-- | A colour\/style for use with 'coloured'.
+newtype PprColour = PprColour String
+
+-- Colours
+
+colType :: PprColour
+colType = PprColour "\27[34m"
+
+colBold :: PprColour
+colBold = PprColour "\27[;1m"
+
+colCoerc :: PprColour
+colCoerc = PprColour "\27[34m"
+
+colDataCon :: PprColour
+colDataCon = PprColour "\27[31m"
+
+colBinder :: PprColour
+colBinder = PprColour "\27[32m"
+
+colReset :: PprColour
+colReset = PprColour "\27[0m"
+
+-- | Apply the given colour\/style for the argument.
+--
+-- Only takes effect if colours are enabled.
+coloured :: PprColour -> SDoc -> SDoc
+-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+coloured col@(PprColour c) sdoc =
+  SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+    let ctx' = ctx{ sdocLastColour = col } in
+    Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+
+bold :: SDoc -> SDoc
+bold = coloured colBold
+
+keyword :: SDoc -> SDoc
+keyword = bold
+
 \end{code}
 
 
@@ -806,21 +889,23 @@ pprDefiniteTrace str doc x = pprAndThen trace str doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
-			     where
-			       doc = text heading <+> pretty_msg
+pprPanicFastInt heading pretty_msg =
+    panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
+  where
+    doc = text heading <+> pretty_msg
 
 
 pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
-    where
+pprAndThen cont heading pretty_msg =
+  cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
      doc = sep [text heading, nest 4 pretty_msg]
 
 assertPprPanic :: String -> Int -> SDoc -> a
 -- ^ Panic with an assertation failure, recording the given file and line number.
 -- Should typically be accessed with the ASSERT family of macros
 assertPprPanic file line msg
-  = panic (show (doc PprDebug))
+  = panic (show (runSDoc doc (initSDocContext PprDebug)))
   where
     doc = sep [hsep[text "ASSERT failed! file", 
 		 	   text file, 
@@ -833,7 +918,7 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = trace (show (doc defaultDumpStyle)) x
+  = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
   where
     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 	       msg]
diff --git a/compiler/utils/Pair.lhs b/compiler/utils/Pair.lhs
new file mode 100644
index 0000000..9e847d6
--- /dev/null
+++ b/compiler/utils/Pair.lhs
@@ -0,0 +1,47 @@
+
+A simple homogeneous pair type with useful Functor, Applicative, and
+Traversable instances.
+
+\begin{code}
+module Pair ( Pair(..), unPair, toPair, swap ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import Data.Monoid
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+data Pair a = Pair { pFst :: a, pSnd :: a }
+-- Note that Pair is a *unary* type constructor
+-- whereas (,) is binary
+
+-- The important thing about Pair is that it has a *homogenous*
+-- Functor instance, so you can easily apply the same function
+-- to both components
+instance Functor Pair where
+  fmap f (Pair x y) = Pair (f x) (f y)
+
+instance Applicative Pair where
+  pure x = Pair x x
+  (Pair f g) <*> (Pair x y) = Pair (f x) (g y)
+
+instance Foldable Pair where
+  foldMap f (Pair x y) = f x `mappend` f y
+
+instance Traversable Pair where
+  traverse f (Pair x y) = Pair <$> f x <*> f y
+
+instance Outputable a => Outputable (Pair a) where
+  ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
+
+unPair :: Pair a -> (a,a)
+unPair (Pair x y) = (x,y)
+
+toPair :: (a,a) -> Pair a
+toPair (x,y) = Pair x y
+
+swap :: Pair a -> Pair a
+swap (Pair x y) = Pair y x
+\end{code}
\ No newline at end of file
diff --git a/compiler/nativeGen/Platform.hs b/compiler/utils/Platform.hs
similarity index 95%
rename from compiler/nativeGen/Platform.hs
rename to compiler/utils/Platform.hs
index 20cb5f5..7b2502d 100644
--- a/compiler/nativeGen/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -31,8 +31,7 @@ data Platform
 --	about what instruction set extensions an architecture might support.
 --
 data Arch
-	= ArchAlpha
-	| ArchX86
+	= ArchX86
 	| ArchX86_64
 	| ArchPPC
 	| ArchPPC_64
@@ -70,9 +69,7 @@ defaultTargetPlatform
 
 -- | Move the evil TARGET_ARCH #ifdefs into Haskell land.
 defaultTargetArch :: Arch
-#if   alpha_TARGET_ARCH
-defaultTargetArch	= ArchAlpha
-#elif i386_TARGET_ARCH
+#if i386_TARGET_ARCH
 defaultTargetArch	= ArchX86
 #elif x86_64_TARGET_ARCH
 defaultTargetArch	= ArchX86_64
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index a518c0b..f0ca69c 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -163,7 +163,7 @@ module Pretty (
 
         empty, isEmpty, nest,
 
-        char, text, ftext, ptext,
+        char, text, ftext, ptext, zeroWidthText,
         int, integer, float, double, rational,
         parens, brackets, braces, quotes, doubleQuotes,
         semi, comma, colon, space, equals,
@@ -224,6 +224,10 @@ The primitive @Doc@ values
 \begin{code}
 empty                     :: Doc
 isEmpty                   :: Doc    -> Bool
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags
+zeroWidthText :: String   -> Doc
+
 text                      :: String -> Doc
 char                      :: Char -> Doc
 
@@ -560,6 +564,7 @@ ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
 ptext :: LitString -> Doc
 ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
   where s = {-castPtr-} s_
+zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
 
 #if defined(__GLASGOW_HASKELL__)
 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index ca6766a..4994e3f 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -19,7 +19,6 @@ import PprCore
 import CoreSyn
 import CoreMonad            ( CoreM, getHscEnv )
 import Type
-import Var
 import Id
 import OccName
 import DynFlags
@@ -190,7 +189,7 @@ vectTopBinder var inline expr
       ; case vectDecl of
           Nothing                 -> return ()
           Just (vdty, _) 
-            | coreEqType vty vdty -> return ()
+            | eqType vty vdty -> return ()
             | otherwise           -> 
               cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $
                 (text "Expected type" <+> ppr vty)
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
index 69ae84f..8456d34 100644
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Base.hs
@@ -13,7 +13,7 @@ module Vectorise.Builtins.Base (
 	indexBuiltin,
 	
 	-- * Projections
-	selTy,
+        selTy,
 	selReplicate,
 	selPick,
 	selTags,
@@ -33,7 +33,6 @@ import TysWiredIn
 import Type
 import TyCon
 import DataCon
-import Var
 import Outputable
 import Data.Array
 
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index 94de62a..5a6cf88 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -24,7 +24,6 @@ import CoreSyn
 import Type
 import Name
 import Module
-import Var
 import Id
 import FastString
 import Outputable
@@ -41,26 +40,62 @@ initBuiltins
 initBuiltins pkg
  = do mapM_ load dph_Orphans
 
-      -- From dph-common:Data.Array.Parallel.Lifted.PArray
-      parrayTyCon	<- externalTyCon	dph_PArray	(fsLit "PArray")
-      let [parrayDataCon] = tyConDataCons parrayTyCon
+      -- From dph-common:Data.Array.Parallel.PArray.PData
+      --     PData is a type family that maps an element type onto the type
+      --     we use to hold an array of those elements.
+      pdataTyCon	<- externalTyCon	dph_PArray_PData  (fsLit "PData")
 
-      pdataTyCon	<- externalTyCon	dph_PArray	(fsLit "PData")
-      paClass           <- externalClass        dph_PArray      (fsLit "PA")
+      --     PR is a type class that holds the primitive operators we can 
+      --     apply to array data. Its functions take arrays in terms of PData types.
+      prClass           <- externalClass        dph_PArray_PData  (fsLit "PR")
+      let prTyCon     = classTyCon prClass
+          [prDataCon] = tyConDataCons prTyCon
+
+
+      -- From dph-common:Data.Array.Parallel.PArray.PRepr
+      preprTyCon	<- externalTyCon 	dph_PArray_PRepr  (fsLit "PRepr")
+      paClass           <- externalClass        dph_PArray_PRepr  (fsLit "PA")
       let paTyCon     = classTyCon paClass
           [paDataCon] = tyConDataCons paTyCon
           paPRSel     = classSCSelId paClass 0
 
-      preprTyCon	<- externalTyCon 	dph_PArray	(fsLit "PRepr")
-      prClass           <- externalClass        dph_PArray      (fsLit "PR")
-      let prTyCon     = classTyCon prClass
-          [prDataCon] = tyConDataCons prTyCon
+      replicatePDVar    <- externalVar          dph_PArray_PRepr  (fsLit "replicatePD")
+      emptyPDVar        <- externalVar          dph_PArray_PRepr  (fsLit "emptyPD")
+      packByTagPDVar    <- externalVar          dph_PArray_PRepr  (fsLit "packByTagPD")
+      combines 		<- mapM (externalVar dph_PArray_PRepr)
+                       		[mkFastString ("combine" ++ show i ++ "PD")
+                          		| i <- [2..mAX_DPH_COMBINE]]
+
+      let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+
 
-      closureTyCon	<- externalTyCon dph_Closure		(fsLit ":->")
+      -- From dph-common:Data.Array.Parallel.PArray.Scalar
+      --     Scalar is the class of scalar values. 
+      --     The dictionary contains functions to coerce U.Arrays of scalars
+      --     to and from the PData representation.
+      scalarClass 	<- externalClass        dph_PArray_Scalar (fsLit "Scalar")
+
+
+      -- From dph-common:Data.Array.Parallel.Lifted.PArray
+      --   A PArray (Parallel Array) holds the array length and some array elements
+      --   represented by the PData type family.
+      parrayTyCon	<- externalTyCon	dph_PArray_Base	  (fsLit "PArray")
+      let [parrayDataCon] = tyConDataCons parrayTyCon
+
+      -- From dph-common:Data.Array.Parallel.PArray.Types
+      voidTyCon		<- externalTyCon        dph_PArray_Types  (fsLit "Void")
+      voidVar           <- externalVar          dph_PArray_Types  (fsLit "void")
+      fromVoidVar       <- externalVar          dph_PArray_Types  (fsLit "fromVoid")
+      wrapTyCon		<- externalTyCon        dph_PArray_Types  (fsLit "Wrap")
+      sum_tcs		<- mapM (externalTyCon  dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
+
+      -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
+      pvoidVar          <- externalVar dph_PArray_PDataInstances  (fsLit "pvoid")
+      punitVar          <- externalVar dph_PArray_PDataInstances  (fsLit "punit")
+
+
+      closureTyCon	<- externalTyCon dph_Closure		 (fsLit ":->")
 
-      -- From dph-common:Data.Array.Parallel.Lifted.Repr
-      voidTyCon		<- externalTyCon	dph_Repr	(fsLit "Void")
-      wrapTyCon		<- externalTyCon	dph_Repr	(fsLit "Wrap")
 
       -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
       sel_tys		<- mapM (externalType dph_Unboxed)
@@ -78,8 +113,6 @@ initBuiltins pkg
       sel_els		<- mapM mk_elements
 				[(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
 
-      sum_tcs		<- mapM (externalTyCon dph_Repr)
-				(numbered "Sum" 2 mAX_DPH_SUM)
 
       let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
           selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
@@ -89,26 +122,14 @@ initBuiltins pkg
           sumTyCons     = listArray (2, mAX_DPH_SUM) sum_tcs
 
 
-      voidVar          <- externalVar dph_Repr		(fsLit "void")
-      pvoidVar         <- externalVar dph_Repr		(fsLit "pvoid")
-      fromVoidVar      <- externalVar dph_Repr		(fsLit "fromVoid")
-      punitVar         <- externalVar dph_Repr		(fsLit "punit")
+
       closureVar       <- externalVar dph_Closure	(fsLit "closure")
       applyVar         <- externalVar dph_Closure	(fsLit "$:")
       liftedClosureVar <- externalVar dph_Closure	(fsLit "liftedClosure")
       liftedApplyVar   <- externalVar dph_Closure	(fsLit "liftedApply")
-      replicatePDVar   <- externalVar dph_PArray	(fsLit "replicatePD")
-      emptyPDVar       <- externalVar dph_PArray	(fsLit "emptyPD")
-      packByTagPDVar   <- externalVar dph_PArray	(fsLit "packByTagPD")
-
-      combines 		<- mapM (externalVar dph_PArray)
-                       		[mkFastString ("combine" ++ show i ++ "PD")
-                          		| i <- [2..mAX_DPH_COMBINE]]
-      let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
 
-      scalarClass 	<- externalClass dph_PArray	(fsLit "Scalar")
       scalar_map	<- externalVar	dph_Scalar	(fsLit "scalar_map")
-      scalar_zip2	<- externalVar	dph_Scalar	(fsLit "scalar_zipWith")
+      scalar_zip2   <- externalVar	dph_Scalar	(fsLit "scalar_zipWith")
       scalar_zips	<- mapM (externalVar dph_Scalar)
                           	(numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
 
@@ -163,13 +184,20 @@ initBuiltins pkg
                , liftingContext   = liftingContext
                }
   where
-    mods@(Modules {
-               dph_PArray         = dph_PArray
-             , dph_Repr           = dph_Repr
-             , dph_Closure        = dph_Closure
-             , dph_Scalar         = dph_Scalar
-             , dph_Unboxed        = dph_Unboxed
-             })
+    -- Extract out all the modules we'll use.
+    -- These are the modules from the DPH base library that contain
+    --  the primitive array types and functions that vectorised code uses.
+    mods@(Modules 
+                { dph_PArray_Base               = dph_PArray_Base
+                , dph_PArray_Scalar             = dph_PArray_Scalar
+                , dph_PArray_PRepr              = dph_PArray_PRepr
+                , dph_PArray_PData              = dph_PArray_PData
+                , dph_PArray_PDataInstances     = dph_PArray_PDataInstances
+                , dph_PArray_Types              = dph_PArray_Types
+                , dph_Closure                   = dph_Closure
+                , dph_Scalar                    = dph_Scalar
+                , dph_Unboxed                   = dph_Unboxed
+                })
       = dph_Modules pkg
 
     load get_mod = dsLoadModule doc mod
@@ -249,13 +277,13 @@ initBuiltinDataCons _
 -- | Get the names of all buildin instance functions for the PA class.
 initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 initBuiltinPAs (Builtins { dphModules = mods }) insts
-  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
+  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
 
 
 -- | Get the names of all builtin instance functions for the PR class.
 initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
 initBuiltinPRs (Builtins { dphModules = mods }) insts
-  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
+  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
 
 
 -- | Get the names of all DPH instance functions for this class.
diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs
index d5b10cb..6ea3595 100644
--- a/compiler/vectorise/Vectorise/Builtins/Modules.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Modules.hs
@@ -10,45 +10,61 @@ import FastString
 	
 -- | Ids of the modules that contain our DPH builtins.
 data Modules 
-	= Modules 
-	{ dph_PArray		:: Module
-        , dph_Repr		:: Module
-        , dph_Closure		:: Module
-        , dph_Unboxed		:: Module
-        , dph_Instances		:: Module
-        , dph_Combinators	:: Module
-        , dph_Scalar		:: Module
-        , dph_Prelude_PArr	:: Module
-        , dph_Prelude_Int	:: Module
-        , dph_Prelude_Word8	:: Module
-        , dph_Prelude_Double	:: Module
-        , dph_Prelude_Bool	:: Module
-        , dph_Prelude_Tuple	:: Module
-	}
+  = Modules 
+  { dph_PArray_Base             :: Module
+  , dph_PArray_Scalar           :: Module
+  , dph_PArray_ScalarInstances  :: Module
+  , dph_PArray_PRepr            :: Module
+  , dph_PArray_PReprInstances   :: Module
+  , dph_PArray_PData            :: Module
+  , dph_PArray_PDataInstances   :: Module
+  , dph_PArray_Types            :: Module
+	
+  , dph_Closure	                :: Module
+  , dph_Unboxed	                :: Module
+  , dph_Combinators             :: Module
+  , dph_Scalar	                :: Module
+
+  , dph_Prelude_Int             :: Module
+  , dph_Prelude_Word8           :: Module
+  , dph_Prelude_Double          :: Module
+  , dph_Prelude_Bool            :: Module
+  , dph_Prelude_Tuple           :: Module
+  }
 
 
 -- | The locations of builtins in the current DPH library.
 dph_Modules :: PackageId -> Modules
 dph_Modules pkg 
-	= Modules 
-	{ dph_PArray         = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
-	, dph_Repr           = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
-	, dph_Closure        = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
-	, dph_Unboxed        = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
-	, dph_Instances      = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
-	, dph_Combinators    = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
-	, dph_Scalar         = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
+  = Modules 
+  { dph_PArray_Base             = mk (fsLit "Data.Array.Parallel.PArray.Base")
+  , dph_PArray_Scalar           = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
+  , dph_PArray_ScalarInstances  = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
+  , dph_PArray_PRepr            = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
+  , dph_PArray_PReprInstances   = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
+  , dph_PArray_PData            = mk (fsLit "Data.Array.Parallel.PArray.PData")
+  , dph_PArray_PDataInstances   = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
+  , dph_PArray_Types            = mk (fsLit "Data.Array.Parallel.PArray.Types")
+	
+  , dph_Closure                 = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
+  , dph_Unboxed                 = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
+  , dph_Combinators             = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
+  , dph_Scalar                  = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
 
-	, dph_Prelude_PArr   = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
-	, dph_Prelude_Int    = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
-	, dph_Prelude_Word8  = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
-	, dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
-	, dph_Prelude_Bool   = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
-	, dph_Prelude_Tuple  = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
-	}
-	where	mk = mkModule pkg . mkModuleNameFS
+  , dph_Prelude_Int             = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
+  , dph_Prelude_Word8           = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
+  , dph_Prelude_Double          = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
+  , dph_Prelude_Bool            = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
+  , dph_Prelude_Tuple           = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
+  }
+  where	mk = mkModule pkg . mkModuleNameFS
 
 
--- | Project out ids of modules that contain orphan instances that we need to load.
 dph_Orphans :: [Modules -> Module]
-dph_Orphans = [dph_Repr, dph_Instances]
+dph_Orphans
+ = [ dph_PArray_Scalar
+   , dph_PArray_ScalarInstances
+   , dph_PArray_PReprInstances
+   , dph_PArray_PDataInstances
+   , dph_Scalar
+   ]
diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
index b0f305d..51b3d14 100644
--- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs
@@ -25,36 +25,18 @@ preludeVars :: Modules
 	-> [( Module, FastString	--   Maps the original variable to the one in the DPH 
 	    , Module, FastString)]      --   packages that it should be rewritten to.
 preludeVars (Modules { dph_Combinators    = _dph_Combinators
-                     , dph_PArray         = _dph_PArray
                      , dph_Prelude_Int    = dph_Prelude_Int
                      , dph_Prelude_Word8  = dph_Prelude_Word8
                      , dph_Prelude_Double = dph_Prelude_Double
                      , dph_Prelude_Bool   = dph_Prelude_Bool 
-                     , dph_Prelude_PArr   = _dph_Prelude_PArr
                      })
 
-    -- Functions that work on whole PArrays, defined in GHC.PArr
-  = [ {- mk gHC_PARR' (fsLit "mapP")       dph_Combinators (fsLit "mapPA")
-    , mk gHC_PARR' (fsLit "zipWithP")   dph_Combinators (fsLit "zipWithPA")
-    , mk gHC_PARR' (fsLit "zipP")       dph_Combinators (fsLit "zipPA")
-    , mk gHC_PARR' (fsLit "unzipP")     dph_Combinators (fsLit "unzipPA")
-    , mk gHC_PARR' (fsLit "filterP")    dph_Combinators (fsLit "filterPA")
-    , mk gHC_PARR' (fsLit "lengthP")    dph_Combinators (fsLit "lengthPA")
-    , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
-    , mk gHC_PARR' (fsLit "!:")         dph_Combinators (fsLit "indexPA")
-    , mk gHC_PARR' (fsLit "sliceP")     dph_Combinators (fsLit "slicePA")
-    , mk gHC_PARR' (fsLit "crossMapP")  dph_Combinators (fsLit "crossMapPA")
-    , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
-    , mk gHC_PARR' (fsLit "concatP")    dph_Combinators (fsLit "concatPA")
-    , mk gHC_PARR' (fsLit "+:+")        dph_Combinators (fsLit "appPA")
-    , mk gHC_PARR' (fsLit "emptyP")     dph_PArray      (fsLit "emptyPA")
-
+  = [ 
     -- Map scalar functions to versions using closures. 
-    , -} mk' dph_Prelude_Int "div"         "divV"
+      mk' dph_Prelude_Int "div"         "divV"
     , mk' dph_Prelude_Int "mod"         "modV"
     , mk' dph_Prelude_Int "sqrt"        "sqrtV"
     , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
-    -- , mk' dph_Prelude_Int "upToP" "upToPA"
     ]
     ++ vars_Ord dph_Prelude_Int
     ++ vars_Num dph_Prelude_Int
@@ -80,17 +62,7 @@ preludeVars (Modules { dph_Combinators    = _dph_Combinators
     , mk gHC_CLASSES (fsLit "not")         dph_Prelude_Bool (fsLit "notV")
     , mk gHC_CLASSES (fsLit "&&")          dph_Prelude_Bool (fsLit "andV")
     , mk gHC_CLASSES (fsLit "||")          dph_Prelude_Bool (fsLit "orV")
-
-{-
-    -- FIXME: temporary
-    , mk dph_Prelude_PArr (fsLit "fromPArrayP")       dph_Prelude_PArr (fsLit "fromPArrayPA")
-    , mk dph_Prelude_PArr (fsLit "toPArrayP")         dph_Prelude_PArr (fsLit "toPArrayPA")
-    , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
-    , mk dph_Prelude_PArr (fsLit "combineP")          dph_Combinators  (fsLit "combine2PA")
-    , mk dph_Prelude_PArr (fsLit "updateP")           dph_Combinators  (fsLit "updatePA")
-    , mk dph_Prelude_PArr (fsLit "bpermuteP")         dph_Combinators  (fsLit "bpermutePA")
-    , mk dph_Prelude_PArr (fsLit "indexedP")          dph_Combinators  (fsLit "indexedPA")
--}    ]
+    ]
   where
     mk  = (,,,)
     mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index dbdf6e1..4676e18 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -234,7 +234,8 @@ vectScalarFun forceScalar recFns expr
         scalars' = scalars `extendVarSet` var
     is_scalar scalars  (Cast e _coe)   = is_scalar scalars e
     is_scalar scalars  (Note _ e   )   = is_scalar scalars e
-    is_scalar _scalars (Type _)        = True
+    is_scalar _scalars (Type {})       = True
+    is_scalar _scalars (Coercion {})   = True
 
     -- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
     is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var)
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 8484410..4910464 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -27,7 +27,6 @@ import FamInstEnv
 import OccName
 import Id
 import MkId
-import Var
 import NameEnv
 
 import Unique
diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs
index 332344b..b7bd95e 100644
--- a/compiler/vectorise/Vectorise/Type/PData.hs
+++ b/compiler/vectorise/Vectorise/Type/PData.hs
@@ -31,7 +31,6 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
                            []          -- no stupid theta
                            rhs
                            rec_flag    -- FIXME: is this ok?
-                           False       -- FIXME: no generics
                            False       -- not GADT syntax
                            NoParentTyCon
                            (Just $ mk_fam_inst pdata vect_tc)
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
index 1556626..c30bfed 100644
--- a/compiler/vectorise/Vectorise/Type/PRepr.hs
+++ b/compiler/vectorise/Vectorise/Type/PRepr.hs
@@ -15,6 +15,7 @@ import CoreUtils
 import MkCore		 ( mkWildCase )
 import TyCon
 import Type
+import Kind
 import BuildTyCl
 import OccName
 import Coercion
@@ -180,9 +181,9 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc r
 
       pdata_co <- mkBuiltinCo pdataTyCon
       let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
-          co           = mkAppCoercion pdata_co
-                       . mkSymCoercion
-                       $ mkTyConApp repr_co ty_args
+          co           = mkAppCo pdata_co
+                       . mkSymCo
+                       $ mkAxInstCo repr_co ty_args
 
           scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)
 
@@ -262,8 +263,8 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc r
 
       pdata_co <- mkBuiltinCo pdataTyCon
       let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
-          co           = mkAppCoercion pdata_co
-                       $ mkTyConApp repr_co var_tys
+          co           = mkAppCo pdata_co
+                       $ mkAxInstCo repr_co var_tys
 
           scrut  = mkCoerce co (Var arg)
 
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 0fa8482..cbfea45 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -82,7 +82,6 @@ vectTyConDecl tycon
                             []                  -- no stupid theta.
                             rhs'                -- new constructor defs.
                             rec_flag            -- FIXME: is this ok?
-                            False               -- FIXME: no generics
                             False               -- not GADT syntax
                             NoParentTyCon
                             Nothing             -- not a family instance
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
index 8cc2bec..a6d9b2a 100644
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ b/compiler/vectorise/Vectorise/Type/Type.hs
@@ -10,7 +10,6 @@ import Vectorise.Builtins
 import TypeRep
 import Type
 import TyCon
-import Var
 import Outputable
 import Control.Monad
 import Data.List
diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs
index 1a099e3..c7020ea 100644
--- a/compiler/vectorise/Vectorise/Utils.hs
+++ b/compiler/vectorise/Vectorise/Utils.hs
@@ -33,7 +33,6 @@ import Vectorise.Builtins
 import CoreSyn
 import CoreUtils
 import Type
-import Var
 import Control.Monad
 
 
@@ -47,7 +46,7 @@ collectAnnTypeArgs expr = go expr []
 collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
 collectAnnTypeBinders expr = go [] expr
   where
-    go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e
+    go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
     go bs e                           = (reverse bs, e)
 
 collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index 0ffaa60..d41be1e 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -133,7 +133,7 @@ mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
 mkBuiltinCo get_tc
   = do
       tc <- builtin get_tc
-      return $ mkTyConApp tc []
+      return $ mkTyConAppCo tc []
 
 
 mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
index 152c51d..d784984 100644
--- a/compiler/vectorise/Vectorise/Utils/Closure.hs
+++ b/compiler/vectorise/Vectorise/Utils/Closure.hs
@@ -17,7 +17,6 @@ import Vectorise.Utils.Hoisting
 
 import CoreSyn
 import Type
-import Var
 import MkCore
 import CoreUtils
 import TyCon
diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
index 12b1b6f..d0785e5 100644
--- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs
+++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
@@ -20,7 +20,6 @@ import CoreSyn
 import CoreUtils
 import CoreUnfold
 import Type
-import Var
 import Id
 import BasicTypes( Arity )
 import FastString
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 329cb63..9c7af44 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -31,7 +31,6 @@ import Control.Monad
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
   where
-    go ty k | Just k' <- kindView k = go ty k'
     go ty (FunTy k1 k2)
       = do
           tv   <- newTyVar (fsLit "a") k1
@@ -136,9 +135,9 @@ prDictOfPReprInstTyCon ty prepr_tc prepr_args
       dict <- prDictOfReprType' rhs
       pr_co <- mkBuiltinCo prTyCon
       let Just arg_co = tyConFamilyCoercion_maybe prepr_tc
-      let co = mkAppCoercion pr_co
-             $ mkSymCoercion
-             $ mkTyConApp arg_co prepr_args
+      let co = mkAppCo pr_co
+             $ mkSymCo
+             $ mkAxInstCo arg_co prepr_args
       return $ mkCoerce co dict
 
   | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs
index 8856afd..a27afea 100644
--- a/compiler/vectorise/Vectorise/Utils/Poly.hs
+++ b/compiler/vectorise/Vectorise/Utils/Poly.hs
@@ -11,7 +11,6 @@ import Vectorise.Monad
 import Vectorise.Utils.PADict
 import CoreSyn
 import Type
-import Var
 import FastString
 import Control.Monad
 
diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs
index f32cf78..9c81d30 100644
--- a/compiler/vectorise/Vectorise/Var.hs
+++ b/compiler/vectorise/Vectorise/Var.hs
@@ -17,7 +17,6 @@ import Vectorise.Vect
 import Vectorise.Type.Type
 import CoreSyn
 import Type
-import Var
 import VarEnv
 import Literal
 import Id
diff --git a/configure.ac b/configure.ac
index 9278126..2de4d8a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -134,6 +134,9 @@ if test "$WithGhc" != ""; then
   AC_SUBST(ghc_ge_613)dnl
 
   BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)'])
+  BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command],['$(AR)'])
+  BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags],['$(AR_OPTS)'])
+  BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file],['$(ArSupportsAtFile)'])
 fi
 
 dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on
@@ -239,7 +242,6 @@ case $host in
      ;;
 esac
 
-# Sync this with cTargetArch in compiler/ghc.mk
 checkArch() {
     case $1 in
     alpha|arm|hppa|hppa1_1|i386|ia64|m68k|mips|mipseb|mipsel|powerpc|powerpc64|rs6000|s390|sparc|sparc64|vax|x86_64)
@@ -305,12 +307,15 @@ checkOS "$TargetOS"
 
 # Verify that the installed (bootstrap) GHC is capable of generating
 # code for the requested build platform.
-if test "$BuildPlatform" != "$bootstrap_target"
+if test "$BootingFromHc" = "NO"
 then
-    echo "This GHC (${WithGhc}) does not generate code for the build platform"
-    echo "   GHC target platform    : $bootstrap_target"
-    echo "   Desired build platform : $BuildPlatform"
-    exit 1
+    if test "$BuildPlatform" != "$bootstrap_target"
+    then
+        echo "This GHC (${WithGhc}) does not generate code for the build platform"
+        echo "   GHC target platform    : $bootstrap_target"
+        echo "   Desired build platform : $BuildPlatform"
+        exit 1
+    fi
 fi
 
 echo "GHC build  : $BuildPlatform"
@@ -625,8 +630,6 @@ FP_CHECK_DOCBOOK_DTD
 FP_DOCBOOK_XSL
 FP_PROG_DBLATEX
 
-FP_PROG_HSTAGS
-
 dnl ** check for ghc-pkg command
 FP_PROG_GHC_PKG
 
diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml
index 6fc1413..9c48f7d 100644
--- a/docs/users_guide/debugging.xml
+++ b/docs/users_guide/debugging.xml
@@ -24,8 +24,9 @@
         a short form&hellip;).  You can get all of these at once
         (<emphasis>lots</emphasis> of output) by using
         <option>-v5</option>, or most of them with
-        <option>-v4</option>.  Some of the most useful ones
-        are:</para>
+        <option>-v4</option>.  You can prevent them from clogging up
+        your standard output by passing <option>-ddump-to-file</option>.
+        Some of the most useful ones are:</para>
 
 	  <variablelist>
 	    <varlistentry>
@@ -476,6 +477,88 @@
           style.</para>
 	</listitem>
       </varlistentry>
+    </variablelist>
+  </sect2>
+
+  <sect2 id="formatting dumps">
+    <title>Formatting dumps</title>
+
+    <indexterm><primary>formatting dumps</primary></indexterm>
+
+     <variablelist>
+      <varlistentry>
+	<term>
+          <option>-dppr-user-length</option>
+          <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+        </term>
+	<listitem>
+	  <para>In error messages, expressions are printed to a
+	  certain &ldquo;depth&rdquo;, with subexpressions beyond the
+	  depth replaced by ellipses.  This flag sets the
+	  depth.  Its default value is 5.</para>
+	</listitem>
+      </varlistentry>
+
+      <varlistentry>
+	<term>
+          <option>-dppr-colsNNN</option>
+          <indexterm><primary><option>-dppr-colsNNN</option></primary></indexterm>
+        </term>
+	<listitem>
+	  <para>Set the width of debugging output. Use this if your code is wrapping too much.
+		For example: <option>-dppr-cols200</option>.</para>
+	</listitem>
+      </varlistentry>
+
+      <varlistentry>
+	<term>
+          <option>-dppr-case-as-let</option>
+          <indexterm><primary><option>-dppr-case-as-let</option></primary></indexterm>
+        </term>
+	<listitem>
+	  <para>Print single alternative case expressions as though they were strict 
+		let expressions. This is helpful when your code does a lot of unboxing.</para>
+	</listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term>
+          <option>-dno-debug-output</option>
+          <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+        </term>
+        <listitem>
+          <para>Suppress any unsolicited debugging output.  When GHC
+            has been built with the <literal>DEBUG</literal> option it
+            occasionally emits debug output of interest to developers.
+            The extra output can confuse the testing framework and
+            cause bogus test failures, so this flag is provided to
+            turn it off.</para>
+        </listitem>
+      </varlistentry>
+     </variablelist>
+
+  </sect2>
+
+  <sect2 id="supression">
+    <title>Suppressing unwanted information</title>
+
+    <indexterm><primary>suppression</primary></indexterm>
+
+    Core dumps contain a large amount of information. Depending on what you are doing, not all of it will be useful.
+    Use these flags to suppress the parts that you are not interested in.
+
+    <variablelist>
+      <varlistentry>
+	<term>
+          <option>-dsuppress-all</option>
+          <indexterm><primary><option>-dsuppress-all</option></primary></indexterm>
+        </term>
+	<listitem>
+	  <para>Suppress everything that can be suppressed, except for unique ids as this often 
+		makes the printout ambiguous. If you just want to see the overall structure of
+		the code, then start here.</para>
+	</listitem>
+      </varlistentry>
 
       <varlistentry>
 	<term>
@@ -483,7 +566,7 @@
           <indexterm><primary><option>-dsuppress-uniques</option></primary></indexterm>
         </term>
 	<listitem>
-	  <para>Suppress the printing of uniques in debugging output. This may make 
+	  <para>Suppress the printing of uniques. This may make 
 	  the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but
 	  it makes the output of two compiler runs have many fewer gratuitous differences,
 	    so you can realistically apply <command>diff</command>.  Once <command>diff</command>
@@ -493,12 +576,13 @@
 
       <varlistentry>
 	<term>
-          <option>-dsuppress-coercions</option>
-          <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+          <option>-dsuppress-idinfo</option>
+          <indexterm><primary><option>-dsuppress-idinfo</option></primary></indexterm>
         </term>
 	<listitem>
-          <para>Suppress the printing of coercions in Core dumps to make them
-shorter.</para>
+	  <para>Suppress extended information about identifiers where they are bound. This includes
+		strictness information and inliner templates. Using this flag can cut the size 
+		of the core dump in half, due to the lack of inliner templates</para>
 	</listitem>
       </varlistentry>
 
@@ -508,36 +592,39 @@ shorter.</para>
           <indexterm><primary><option>-dsuppress-module-prefixes</option></primary></indexterm>
         </term>
 	<listitem>
-          <para>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</para>
+          <para>Suppress the printing of module qualification prefixes.
+	        This is the <constant>Data.List</constant> in <constant>Data.List.length</constant>.</para>
 	</listitem>
       </varlistentry>
 
       <varlistentry>
 	<term>
-          <option>-dppr-user-length</option>
-          <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+          <option>-dsuppress-type-signatures</option>
+          <indexterm><primary><option>-dsuppress-type-signatures</option></primary></indexterm>
         </term>
 	<listitem>
-	  <para>In error messages, expressions are printed to a
-	  certain &ldquo;depth&rdquo;, with subexpressions beyond the
-	  depth replaced by ellipses.  This flag sets the
-	  depth.  Its default value is 5.</para>
+          <para>Suppress the printing of type signatures.</para>
 	</listitem>
       </varlistentry>
 
       <varlistentry>
-        <term>
-          <option>-dno-debug-output</option>
-          <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+	<term>
+          <option>-dsuppress-type-applications</option>
+          <indexterm><primary><option>-dsuppress-type-applications</option></primary></indexterm>
         </term>
-        <listitem>
-          <para>Suppress any unsolicited debugging output.  When GHC
-            has been built with the <literal>DEBUG</literal> option it
-            occasionally emits debug output of interest to developers.
-            The extra output can confuse the testing framework and
-            cause bogus test failures, so this flag is provided to
-            turn it off.</para>
-        </listitem>
+	<listitem>
+          <para>Suppress the printing of type applications.</para>
+	</listitem>
+      </varlistentry>
+
+      <varlistentry>
+	<term>
+          <option>-dsuppress-coercions</option>
+          <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+        </term>
+	<listitem>
+          <para>Suppress the printing of type coercions.</para>
+	</listitem>
       </varlistentry>
     </variablelist>
   </sect2>
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 26ab9eb..bfc28d8 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -35,13 +35,7 @@
 	      <entry>mode</entry>
 	      <entry>-</entry>
 	    </row>
-	    <row>
-	      <entry><option>-n</option></entry>
-	      <entry>do a dry run</entry>
-	      <entry>dynamic</entry>
-	      <entry>-</entry>
-	    </row>
-	    <row>
+            <row>
 	      <entry><option>-v</option></entry>
 	      <entry>verbose mode (equivalent to <option>-v3</option>)</entry>
 	      <entry>dynamic</entry>
@@ -682,7 +676,9 @@
 	    </row>
 	    <row>
 	      <entry><option>-XGenerics</option></entry>
-	      <entry>Enable <link linkend="generic-classes">generic classes</link></entry>
+	      <entry>Deprecated, does nothing. No longer enables <link linkend="generic-classes">generic classes</link>.
+               See also GHC's support for
+               <link linkend="generic-programming">generic programming</link>.</entry>
 	      <entry>dynamic</entry>
 	      <entry><option>-XNoGenerics</option></entry>
 	    </row>
@@ -898,6 +894,12 @@
 	      <entry>dynamic</entry>
 	      <entry><option>-XNoTransformListComp</option></entry>
 	    </row>
+        <row>
+	      <entry><option>-XMonadComprehensions</option></entry>
+	      <entry>Enable <link linkend="monad-comprehensions">monad comprehensions</link>.</entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNoMonadComprehensions</option></entry>
+	    </row>
 	    <row>
 	      <entry><option>-XUnliftedFFITypes</option></entry>
 	      <entry>Enable unlifted FFI types.</entry>
@@ -971,6 +973,12 @@
 	      <entry><option>-XNoDeriveDataTypeable</option></entry>
 	    </row>
 	    <row>
+	      <entry><option>-XDeriveGeneric</option></entry>
+	      <entry>Enable <link linkend="deriving-typeable">deriving for the Generic class</link>.</entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNoDeriveGeneric</option></entry>
+	    </row>
+	    <row>
 	      <entry><option>-XGeneralizedNewtypeDeriving</option></entry>
 	      <entry>Enable <link linkend="newtype-deriving">newtype deriving</link>.</entry>
 	      <entry>dynamic</entry>
@@ -1002,6 +1010,12 @@
 	      <entry><option>-XNoConstrainedClassMethods</option></entry>
 	    </row>
 	    <row>
+	      <entry><option>-XDefaultSignatures</option></entry>
+	      <entry>Enable <link linkend="class-default-signatures">default signatures</link>.</entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNoDefaultSignatures</option></entry>
+	    </row>
+	    <row>
 	      <entry><option>-XMultiParamTypeClasses</option></entry>
 	      <entry>Enable <link linkend="multi-param-type-classes">multi parameter type classes</link>.</entry>
 	      <entry>dynamic</entry>
@@ -2227,6 +2241,12 @@ phase <replaceable>n</replaceable></entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
+	      <entry><option>-ddump-to-file</option></entry>
+	      <entry>Dump to files instead of stdout</entry>
+	      <entry>dynamic</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
 	      <entry><option>-ddump-asm</option></entry>
 	      <entry>Dump assembly</entry>
 	      <entry>dynamic</entry>
@@ -2468,32 +2488,68 @@ phase <replaceable>n</replaceable></entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
+	      <entry><option>-dppr-noprags</option></entry>
+	      <entry>Don't output pragma info in dumps</entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
+	      <entry><option>-dppr-user-length</option></entry>
+	      <entry>Set the depth for printing expressions in error msgs</entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
+	      <entry><option>-dppr-colsNNN</option></entry>
+	      <entry>Set the width of debugging output. For example <option>-dppr-cols200</option></entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
+	      <entry><option>-dppr-case-as-let</option></entry>
+	      <entry>Print single alternative case expressions as strict lets.</entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
+	      <entry><option>-dsuppress-all</option></entry>
+	      <entry>In core dumps, suppress everything that is suppressable.</entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
 	      <entry><option>-dsuppress-uniques</option></entry>
-	      <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>.</entry>
+	      <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>)</entry>
 	      <entry>static</entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
-	      <entry><option>-dsuppress-coercions</option></entry>
-	      <entry>Suppress the printing of coercions in Core dumps to make them shorter.</entry>
+	      <entry><option>-dsuppress-idinfo</option></entry>
+	      <entry>Suppress extended information about identifiers where they are bound</entry>
 	      <entry>static</entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
 	      <entry><option>-dsuppress-module-prefixes</option></entry>
-	      <entry>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</entry>
+	      <entry>Suppress the printing of module qualification prefixes</entry>
 	      <entry>static</entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
-	      <entry><option>-dppr-noprags</option></entry>
-	      <entry>Don't output pragma info in dumps</entry>
+	      <entry><option>-dsuppress-type-signatures</option></entry>
+	      <entry>Suppress type signatures</entry>
 	      <entry>static</entry>
 	      <entry>-</entry>
 	    </row>
 	    <row>
-	      <entry><option>-dppr-user-length</option></entry>
-	      <entry>Set the depth for printing expressions in error msgs</entry>
+	      <entry><option>-dsuppress-type-applications</option></entry>
+	      <entry>Suppress type applications</entry>
+	      <entry>static</entry>
+	      <entry>-</entry>
+	    </row>
+	    <row>
+	      <entry><option>-dsuppress-coercions</option></entry>
+	      <entry>Suppress the printing of coercions in Core dumps to make them shorter</entry>
 	      <entry>static</entry>
 	      <entry>-</entry>
 	    </row>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 9ea3332..0f37953 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1201,6 +1201,234 @@ output = [ x
 </para>
   </sect2>
 
+   <!-- ===================== MONAD COMPREHENSIONS ===================== -->
+
+<sect2 id="monad-comprehensions">
+    <title>Monad comprehensions</title>
+    <indexterm><primary>monad comprehensions</primary></indexterm>
+
+    <para>
+        Monad comprehesions generalise the list comprehension notation,
+        including parallel comprehensions 
+        (<xref linkend="parallel-list-comprehensions"/>) and 
+        transform comprenensions (<xref linkend="generalised-list-comprehensions"/>) 
+        to work for any monad.
+    </para>
+
+    <para>Monad comprehensions support:</para>
+
+    <itemizedlist>
+        <listitem>
+            <para>
+                Bindings:
+            </para>
+
+<programlisting>
+[ x + y | x &lt;- Just 1, y &lt;- Just 2 ]
+</programlisting>
+
+            <para>
+                Bindings are translated with the <literal>(&gt;&gt;=)</literal> and
+                <literal>return</literal> functions to the usual do-notation:
+            </para>
+
+<programlisting>
+do x &lt;- Just 1
+   y &lt;- Just 2
+   return (x+y)
+</programlisting>
+
+        </listitem>
+        <listitem>
+            <para>
+                Guards:
+            </para>
+
+<programlisting>
+[ x | x &lt;- [1..10], x &lt;= 5 ]
+</programlisting>
+
+            <para>
+                Guards are translated with the <literal>guard</literal> function,
+                which requires a <literal>MonadPlus</literal> instance:
+            </para>
+
+<programlisting>
+do x &lt;- [1..10]
+   guard (x &lt;= 5)
+   return x
+</programlisting>
+
+        </listitem>
+        <listitem>
+            <para>
+                Transform statements (as with <literal>-XTransformListComp</literal>):
+            </para>
+
+<programlisting>
+[ x+y | x &lt;- [1..10], y &lt;- [1..x], then take 2 ]
+</programlisting>
+
+            <para>
+                This translates to:
+            </para>
+
+<programlisting>
+do (x,y) &lt;- take 2 (do x &lt;- [1..10]
+                       y &lt;- [1..x]
+                       return (x,y))
+   return (x+y)
+</programlisting>
+
+        </listitem>
+        <listitem>
+            <para>
+                Group statements (as with <literal>-XTransformListComp</literal>):
+            </para>
+
+<programlisting>
+[ x | x &lt;- [1,1,2,2,3], then group by x ]
+[ x | x &lt;- [1,1,2,2,3], then group by x using GHC.Exts.groupWith ]
+[ x | x &lt;- [1,1,2,2,3], then group using myGroup ]
+</programlisting>
+
+            <para>
+                The basic <literal>then group by e</literal> statement is
+                translated using the <literal>mgroupWith</literal> function, which
+                requires a <literal>MonadGroup</literal> instance, defined in
+                <ulink url="&libraryBaseLocation;/Control-Monad-Group.html"><literal>Control.Monad.Group</literal></ulink>:
+            </para>
+
+<programlisting>
+do x &lt;- mgroupWith (do x &lt;- [1,1,2,2,3]
+                       return x)
+   return x
+</programlisting>
+
+            <para>
+                Note that the type of <literal>x</literal> is changed by the
+                grouping statement.
+            </para>
+
+            <para>
+                The grouping function can also be defined with the
+                <literal>using</literal> keyword.
+            </para>
+
+        </listitem>
+        <listitem>
+            <para>
+                Parallel statements (as with <literal>-XParallelListComp</literal>):
+            </para>
+
+<programlisting>
+[ (x+y) | x &lt;- [1..10]
+        | y &lt;- [11..20]
+        ]
+</programlisting>
+
+            <para>
+                Parallel statements are translated using the
+                <literal>mzip</literal> function, which requires a
+                <literal>MonadZip</literal> instance defined in
+                <ulink url="&libraryBaseLocation;/Control-Monad-Zip.html"><literal>Control.Monad.Zip</literal></ulink>:
+            </para>
+
+<programlisting>
+do (x,y) &lt;- mzip (do x &lt;- [1..10]
+                     return x)
+                 (do y &lt;- [11..20]
+                     return y)
+   return (x+y)
+</programlisting>
+
+        </listitem>
+    </itemizedlist>
+
+    <para>
+        All these features are enabled by default if the
+        <literal>MonadComprehensions</literal> extension is enabled. The types
+        and more detailed examples on how to use comprehensions are explained
+        in the previous chapters <xref
+            linkend="generalised-list-comprehensions"/> and <xref
+            linkend="parallel-list-comprehensions"/>. In general you just have
+        to replace the type <literal>[a]</literal> with the type
+        <literal>Monad m => m a</literal> for monad comprehensions.
+    </para>
+
+    <para>
+        Note: Even though most of these examples are using the list monad,
+        monad comprehensions work for any monad.
+        The <literal>base</literal> package offers all necessary instances for
+        lists, which make <literal>MonadComprehensions</literal> backward
+        compatible to built-in, transform and parallel list comprehensions.
+    </para>
+<para> More formally, the desugaring is as follows.  We write <literal>D[ e | Q]</literal>
+to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>: 
+<programlisting>
+Expressions: e
+Declarations: d
+Lists of qualifiers: Q,R,S  
+
+-- Basic forms
+D[ e | ]               = return e
+D[ e | p &lt;- e, Q ]     = e &gt;&gt;= \p -&gt; D[ e | Q ]
+D[ e | e, Q ]          = guard e &gt;&gt; \p -&gt; D[ e | Q ]
+D[ e | let d, Q ]      = let d in D[ e | Q ]
+
+-- Parallel comprehensions (iterate for multiple parallel branches)
+D[ e | (Q | R), S ]    = mzip D[ Qv | Q ] D[ Rv | R ] &gt;&gt;= \(Qv,Rv) -&gt; D[ e | S ]
+
+-- Transform comprehensions
+D[ e | Q then f, R ]                  = f D[ Qv | Q ] &gt;&gt;= \Qv -&gt; D[ e | R ]
+
+D[ e | Q then f by b, R ]             = f b D[ Qv | Q ] &gt;&gt;= \Qv -&gt; D[ e | R ]
+
+D[ e | Q then group using f, R ]      = f D[ Qv | Q ] &gt;&gt;= \ys -&gt; 
+                                        case (fmap selQv1 ys, ..., fmap selQvn ys) of
+                                 	     Qv -&gt; D[ e | R ]
+
+D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] &gt;&gt;= \ys -&gt; 
+                                        case (fmap selQv1 ys, ..., fmap selQvn ys) of
+                                           Qv -&gt; D[ e | R ]
+
+where  Qv is the tuple of variables bound by Q (and used subsequently)
+       selQvi is a selector mapping Qv to the ith component of Qv
+
+Operator     Standard binding       Expected type
+--------------------------------------------------------------------
+return       GHC.Base               t1 -&gt; m t2
+(&gt;&gt;=)        GHC.Base               m1 t1 -&gt; (t2 -&gt; m2 t3) -&gt; m3 t3
+(&gt;&gt;)         GHC.Base               m1 t1 -&gt; m2 t2         -&gt; m3 t3
+guard        Control.Monad          t1 -&gt; m t2
+fmap         GHC.Base               forall a b. (a-&gt;b) -&gt; n a -&gt; n b
+mgroupWith   Control.Monad.Group    forall a. (a -&gt; t) -&gt; m1 a -&gt; m2 (n a)
+mzip         Control.Monad.Zip      forall a b. m a -&gt; m b -&gt; m (a,b)
+</programlisting>                                          
+The comprehension should typecheck when its desugaring would typecheck. 
+</para>
+<para>
+Monad comprehensions support rebindable syntax (<xref linkend="rebindable-syntax"/>).  
+Without rebindable
+syntax, the operators from the "standard binding" module are used; with
+rebindable syntax, the operators are looked up in the current lexical scope.
+For example, parallel comprehensions will be typechecked and desugared
+using whatever "<literal>mzip</literal>" is in scope.
+</para>
+<para>
+The rebindable operators must have the "Expected type" given in the 
+table above.  These types are surprisingly general.  For example, you can
+use a bind operator with the type
+<programlisting>
+(>>=) :: T x y a -> (a -> T y z b) -> T x z b
+</programlisting>
+In the case of transform comprehensions, notice that the groups are
+parameterised over some arbitrary type <literal>n</literal> (provided it
+has an <literal>fmap</literal>, as well as
+the comprehension being over an arbitrary monad.
+</para>
+</sect2>
+
    <!-- ===================== REBINDABLE SYNTAX ===================  -->
 
 <sect2 id="rebindable-syntax">
@@ -2984,6 +3212,12 @@ then writing the data type instance by hand.
 </para>
 </listitem>
 
+<listitem><para> With <option>-XDeriveGeneric</option>, you can derive
+instances of  the class <literal>Generic</literal>, defined in
+<literal>GHC.Generics</literal>. You can use these to define generic functions,
+as described in <xref linkend="generic-programming"/>.
+</para></listitem>
+
 <listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of 
 the class <literal>Functor</literal>,
 defined in <literal>GHC.Base</literal>.
@@ -3305,6 +3539,47 @@ GHC lifts this restriction (flag <option>-XConstrainedClassMethods</option>).
 
 
 </sect3>
+
+
+<sect3 id="class-default-signatures">
+<title>Default signatures</title>
+
+<para>
+Haskell 98 allows you to define a default implementation when declaring a class:
+<programlisting>
+  class Enum a where
+    enum :: [a]
+    enum = []
+</programlisting>
+The type of the <literal>enum</literal> method is <literal>[a]</literal>, and
+this is also the type of the default method. You can lift this restriction
+and give another type to the default method using the flag
+<option>-XDefaultSignatures</option>. For instance, if you have written a
+generic implementation of enumeration in a class <literal>GEnum</literal> 
+with method <literal>genum</literal> in terms of <literal>GHC.Generics</literal>,
+you can specify a default method that uses that generic implementation:
+<programlisting>
+  class Enum a where
+    enum :: [a]
+    default enum :: (Generic a, GEnum (Rep a)) => [a]
+    enum = map to genum
+</programlisting>
+We reuse the keyword <literal>default</literal> to signal that a signature
+applies to the default method only; when defining instances of the
+<literal>Enum</literal> class, the original type <literal>[a]</literal> of
+<literal>enum</literal> still applies. When giving an empty instance, however,
+the default implementation <literal>map to0 genum</literal> is filled-in,
+and type-checked with the type
+<literal>(Generic a, GEnum (Rep a)) => [a]</literal>.
+</para>
+
+<para>
+We use default signatures to simplify generic programming in GHC 
+(<xref linkend="generic-programming"/>).
+</para>
+
+
+</sect3>
 </sect2>
 
 <sect2 id="functional-dependencies">
@@ -8899,7 +9174,7 @@ allows control over inlining on a per-call-site basis.
 restrains the strictness analyser.
 </para></listitem>
 <listitem><para>
-<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>lazy</literal></ulink> 
+<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink> 
 allows you to fool the type checker.
 </para></listitem>
 </itemizedlist>
@@ -8911,257 +9186,185 @@ allows you to fool the type checker.
 <title>Generic classes</title>
 
 <para>
-The ideas behind this extension are described in detail in "Derivable type classes",
-Ralf Hinze and Simon Peyton Jones, Haskell Workshop, Montreal Sept 2000, pp94-105.
-An example will give the idea:
+GHC used to have an implementation of generic classes as defined in the paper
+"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop,
+Montreal Sept 2000, pp94-105. These have been removed and replaced by the more
+general <link linkend="generic-programming">support for generic programming</link>.
 </para>
 
-<programlisting>
-  import Data.Generics
-
-  class Bin a where
-    toBin   :: a -> [Int]
-    fromBin :: [Int] -> (a, [Int])
-  
-    toBin {| Unit |}    Unit	  = []
-    toBin {| a :+: b |} (Inl x)   = 0 : toBin x
-    toBin {| a :+: b |} (Inr y)   = 1 : toBin y
-    toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
-  
-    fromBin {| Unit |}    bs      = (Unit, bs)
-    fromBin {| a :+: b |} (0:bs)  = (Inl x, bs')    where (x,bs') = fromBin bs
-    fromBin {| a :+: b |} (1:bs)  = (Inr y, bs')    where (y,bs') = fromBin bs
-    fromBin {| a :*: b |} bs	  = (x :*: y, bs'') where (x,bs' ) = fromBin bs
-							  (y,bs'') = fromBin bs'
-</programlisting>
-<para>
-This class declaration explains how <literal>toBin</literal> and <literal>fromBin</literal>
-work for arbitrary data types.  They do so by giving cases for unit, product, and sum,
-which are defined thus in the library module <literal>Data.Generics</literal>:
-</para>
-<programlisting>
-  data Unit    = Unit
-  data a :+: b = Inl a | Inr b
-  data a :*: b = a :*: b
-</programlisting>
-<para>
-Now you can make a data type into an instance of Bin like this:
-<programlisting>
-  instance (Bin a, Bin b) => Bin (a,b)
-  instance Bin a => Bin [a]
-</programlisting>
-That is, just leave off the "where" clause.  Of course, you can put in the
-where clause and over-ride whichever methods you please.
-</para>
+</sect1>
 
-    <sect2>
-      <title> Using generics </title>
-      <para>To use generics you need to</para>
-      <itemizedlist>
-	<listitem>
-	  <para>
-            Use the flags <option>-XGenerics</option> (to enable the
-            extra syntax and generate extra per-data-type code),
-            and <option>-package syb</option> (to make the
-            <literal>Data.Generics</literal> module available.
-          </para>
-	</listitem>
-	<listitem>
-	  <para>Import the module <literal>Data.Generics</literal> from the
-          <literal>syb</literal> package.  This import brings into
-          scope the data types <literal>Unit</literal>,
-          <literal>:*:</literal>, and <literal>:+:</literal>.  (You
-          don't need this import if you don't mention these types
-          explicitly; for example, if you are simply giving instance
-          declarations.)</para>
-	</listitem>
-      </itemizedlist>
-    </sect2>
 
-<sect2> <title> Changes wrt the paper </title>
-<para>
-Note that the type constructors <literal>:+:</literal> and <literal>:*:</literal> 
-can be written infix (indeed, you can now use
-any operator starting in a colon as an infix type constructor).  Also note that
-the type constructors are not exactly as in the paper (Unit instead of 1, etc).
-Finally, note that the syntax of the type patterns in the class declaration
-uses "<literal>{|</literal>" and "<literal>|}</literal>" brackets; curly braces
-alone would ambiguous when they appear on right hand sides (an extension we 
-anticipate wanting).
-</para>
-</sect2>
+<sect1 id="generic-programming">
+<title>Generic programming</title>
 
-<sect2> <title>Terminology and restrictions</title>
 <para>
-Terminology.  A "generic default method" in a class declaration
-is one that is defined using type patterns as above.
-A "polymorphic default method" is a default method defined as in Haskell 98.
-A "generic class declaration" is a class declaration with at least one
-generic default method.
+Using a combination of <option>-XDeriveGeneric</option>
+(<xref linkend="deriving-typeable"/>) and
+<option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>),
+you can easily do datatype-generic
+programming using the <literal>GHC.Generics</literal> framework. This section
+gives a very brief overview of how to do it. For more detail please refer to the
+<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink>
+or the original paper:
 </para>
 
-<para>
-Restrictions:
 <itemizedlist>
 <listitem>
 <para>
-Alas, we do not yet implement the stuff about constructor names and 
-field labels.
+José Pedro Magalhães, Atze Dijkstra, Johan Jeuring, and Andres Löh.
+<ulink url="http://dreixel.net/research/pdf/gdmh.pdf">
+  A generic deriving mechanism for Haskell</ulink>.
+<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle>
+(Haskell'2010), pp. 37-48, ACM, 2010.
 </para>
 </listitem>
+</itemizedlist>
 
-<listitem>
-<para>
-A generic class can have only one parameter; you can't have a generic
-multi-parameter class.
-</para>
-</listitem>
+<emphasis>Note</emphasis>: the current support for generic programming in GHC
+is preliminary. In particular, we only allow deriving instances for the
+<literal>Generic</literal> class. Support for deriving
+<literal>Generic1</literal> (and thus enabling generic functions of kind
+<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a
+later stage.
 
-<listitem>
-<para>
-A default method must be defined entirely using type patterns, or entirely
-without.  So this is illegal:
-<programlisting>
-  class Foo a where
-    op :: a -> (a, Bool)
-    op {| Unit |} Unit = (Unit, True)
-    op x               = (x,    False)
-</programlisting>
-However it is perfectly OK for some methods of a generic class to have 
-generic default methods and others to have polymorphic default methods.
-</para>
-</listitem>
 
-<listitem>
-<para>
-The type variable(s) in the type pattern for a generic method declaration
-scope over the right hand side.  So this is legal (note the use of the type variable ``p'' in a type signature on the right hand side:
-<programlisting>
-  class Foo a where
-    op :: a -> Bool
-    op {| p :*: q |} (x :*: y) = op (x :: p)
-    ...
-</programlisting>
-</para>
-</listitem>
+<sect2>
+<title>Deriving representations</title>
 
-<listitem>
 <para>
-The type patterns in a generic default method must take one of the forms:
-<programlisting>
-       a :+: b
-       a :*: b
-       Unit
-</programlisting>
-where "a" and "b" are type variables.  Furthermore, all the type patterns for
-a single type constructor (<literal>:*:</literal>, say) must be identical; they
-must use the same type variables.  So this is illegal:
+The first thing we need is generic representations. The
+<literal>GHC.Generics</literal> module defines a couple of primitive types
+that can be used to represent most Haskell datatypes:
+
 <programlisting>
-  class Foo a where
-    op :: a -> Bool
-    op {| a :+: b |} (Inl x) = True
-    op {| p :+: q |} (Inr y) = False
+-- | Unit: used for constructors without arguments
+data U1 p = U1
+ 
+-- | Constants, additional parameters and recursion of kind *
+newtype K1 i c p = K1 { unK1 :: c }
+ 
+-- | Meta-information (constructor names, etc.)
+newtype M1 i c f p = M1 { unM1 :: f p }
+ 
+-- | Sums: encode choice between constructors
+infixr 5 :+:
+data (:+:) f g p = L1 (f p) | R1 (g p)
+ 
+-- | Products: encode multiple arguments to constructors
+infixr 6 :*:
+data (:*:) f g p = f p :*: g p
+</programlisting>
+
+For example, a user-defined datatype of trees <literal>data UserTree a = Node a
+(UserTree a) (UserTree a) | Leaf</literal> gets the following representation:
+
+<programlisting>
+instance Generic (UserTree a) where
+  -- Representation type
+  type Rep (UserTree a) = 
+    M1 D D1UserTree (
+          M1 C C1_0UserTree (
+                M1 S NoSelector (K1 P a)
+            :*: M1 S NoSelector (K1 R (UserTree a))
+            :*: M1 S NoSelector (K1 R (UserTree a)))
+      :+: M1 C C1_1UserTree U1)
+
+  -- Conversion functions
+  from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))
+  from Leaf         = M1 (R1 (M1 U1))
+  to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r
+  to (M1 (R1 (M1 U1)))                                      = Leaf
+
+-- Meta-information
+data D1UserTree
+data C1_0UserTree
+data C1_1UserTree
+
+instance Datatype D1UserTree where
+  datatypeName _ = "UserTree"
+  moduleName _   = "Main"
+  
+instance Constructor C1_0UserTree where
+  conName _ = "Node"
+  
+instance Constructor C1_1UserTree where
+  conName _ = "Leaf"
 </programlisting>
-The type patterns must be identical, even in equations for different methods of the class.
-So this too is illegal:
-<programlisting>
-  class Foo a where
-    op1 :: a -> Bool
-    op1 {| a :*: b |} (x :*: y) = True
 
-    op2 :: a -> Bool
-    op2 {| p :*: q |} (x :*: y) = False
-</programlisting>
-(The reason for this restriction is that we gather all the equations for a particular type constructor
-into a single generic instance declaration.)
+This representation is generated automatically if a
+<literal>deriving Generic</literal> clause is attached to the datatype.
+<link linkend="stand-alone-deriving">Standalone deriving</link> can also be
+used.
 </para>
-</listitem>
+</sect2>
 
-<listitem>
-<para>
-A generic method declaration must give a case for each of the three type constructors.
-</para>
-</listitem>
+<sect2>
+<title>Writing generic functions</title>
 
-<listitem>
 <para>
-The type for a generic method can be built only from:
-  <itemizedlist>
-  <listitem> <para> Function arrows </para> </listitem>
-  <listitem> <para> Type variables </para> </listitem>
-  <listitem> <para> Tuples </para> </listitem>
-  <listitem> <para> Arbitrary types not involving type variables </para> </listitem>
-  </itemizedlist>
-Here are some example type signatures for generic methods:
+A generic function is defined by creating a class and giving instances for
+each of the representation types of <literal>GHC.Generics</literal>. As an
+example we show generic serialization:
 <programlisting>
-    op1 :: a -> Bool
-    op2 :: Bool -> (a,Bool)
-    op3 :: [Int] -> a -> a
-    op4 :: [a] -> Bool
-</programlisting>
-Here, op1, op2, op3 are OK, but op4 is rejected, because it has a type variable
-inside a list.  
-</para>
-<para>
-This restriction is an implementation restriction: we just haven't got around to
-implementing the necessary bidirectional maps over arbitrary type constructors.
-It would be relatively easy to add specific type constructors, such as Maybe and list,
-to the ones that are allowed.</para>
-</listitem>
+data Bin = O | I
 
-<listitem>
-<para>
-In an instance declaration for a generic class, the idea is that the compiler
-will fill in the methods for you, based on the generic templates.  However it can only
-do so if
-  <itemizedlist>
-  <listitem>
-  <para>
-  The instance type is simple (a type constructor applied to type variables, as in Haskell 98).
-  </para>
-  </listitem>
-  <listitem>
-  <para>
-  No constructor of the instance type has unboxed fields.
-  </para>
-  </listitem>
-  </itemizedlist>
-(Of course, these things can only arise if you are already using GHC extensions.)
-However, you can still give an instance declarations for types which break these rules,
-provided you give explicit code to override any generic default methods.
-</para>
-</listitem>
+class GSerialize f where
+  gput :: f a -> [Bin]
 
-</itemizedlist>
-</para>
+instance GSerialize U1 where
+  gput U1 = []
 
-<para>
-The option <option>-ddump-deriv</option> dumps incomprehensible stuff giving details of 
-what the compiler does with generic declarations.
-</para>
+instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
+  gput (a :*: b) = gput a ++ gput b
+
+instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where
+  gput (L1 x) = O : gput x
+  gput (R1 x) = I : gput x
+
+instance (GSerialize a) => GSerialize (M1 i c a) where
+  gput (M1 x) = gput x
 
+instance (Serialize a) => GSerialize (K1 i c a) where
+  gput (K1 x) = put x
+</programlisting>
+
+Typically this class will not be exported, as it only makes sense to have
+instances for the representation types.
+</para>
 </sect2>
 
-<sect2> <title> Another example </title>
+<sect2>
+<title>Generic defaults</title>
+
 <para>
-Just to finish with, here's another example I rather like:
+The only thing left to do now is to define a "front-end" class, which is
+exposed to the user:
 <programlisting>
-  class Tag a where
-    nCons :: a -> Int
-    nCons {| Unit |}    _ = 1
-    nCons {| a :*: b |} _ = 1
-    nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
+class Serialize a where
+  put :: a -> [Bin]
   
-    tag :: a -> Int
-    tag {| Unit |}    _       = 1
-    tag {| a :*: b |} _       = 1   
-    tag {| a :+: b |} (Inl x) = tag x
-    tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
+  default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
+  put = gput . from
 </programlisting>
+Here we use a <link linkend="class-default-signatures">default signature</link>
+to specify that the user does not have to provide an implementation for
+<literal>put</literal>, as long as there is a <literal>Generic</literal>
+instance for the type to instantiate. For the <literal>UserTree</literal> type,
+for instance, the user can just write:
+
+<programlisting>
+instance (Serialize a) => Serialize (UserTree a)
+</programlisting>
+
+The default method for <literal>put</literal> is then used, corresponding to the
+generic implementation of serialization.
 </para>
 </sect2>
+
 </sect1>
 
+
 <sect1 id="monomorphism">
 <title>Control over monomorphism</title>
 
diff --git a/docs/users_guide/shared_libs.xml b/docs/users_guide/shared_libs.xml
index 89b656a..29dcb37 100644
--- a/docs/users_guide/shared_libs.xml
+++ b/docs/users_guide/shared_libs.xml
@@ -24,12 +24,10 @@
   </para>
 
   <para>
-    In GHC version 6.12 building shared libraries is supported for Linux on
-    x86 and x86-64 architectures and there is partial support on Windows (see
-    <xref linkend="win32-dlls"/>). The crucial difference in support on
-    Windows is that it is not currently possible to build each Haskell
-    package as a separate DLL, it is only possible to link an entire Haskell
-    program as one massive DLL.
+    In GHC version 6.12 building shared libraries is supported for Linux (on
+    x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+    (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+    Solaris (x86) and Mac OS X (x86 and PowerPC).
   </para>
 
   <para>
@@ -59,7 +57,7 @@ ghc --make -dynamic Main.hs
       that it can be linked against shared library versions of Haskell
       packages (such as base). The second is when linking, to link against
       the shared versions of the packages' libraries rather than the static
-      versions. Obviously this requires that the packages were build with
+      versions. Obviously this requires that the packages were built with
       shared libraries. On supported platforms GHC comes with shared
       libraries for all the core packages, but if you install extra packages
       (e.g. with Cabal) then they would also have to be built with shared
@@ -87,10 +85,7 @@ ghc --make -dynamic Main.hs
       In particular Haskell shared libraries <emphasis>must</emphasis> be
       made into packages. You cannot freely assign which modules go in which
       shared libraries. The Haskell shared libraries must match the package
-      boundaries. Most of the conventions GHC expects when using packages are
-      described in <xref linkend="building-packages"/>.
-    </para>
-    <para>
+      boundaries. The reason for this is that
       GHC handles references to symbols <emphasis>within</emphasis> the same
       shared library (or main executable binary) differently from references
       to symbols <emphasis>between</emphasis> different shared libraries. GHC
@@ -153,8 +148,6 @@ ghc -dynamic -shared Foo.o -o libfoo.so
       <literal>-dynamic</literal> in the link step. That means to
       statically link the rts all the base libraries into your new shared
       library. This would make a very big, but standalone shared library.
-      Indeed this is exactly what we must currently do on Windows where
-      -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
       On most platforms however that would require all the static libraries
       to have been built with <literal>-fPIC</literal> so that the code is
       suitable to include into a shared library and we do not do that at the
@@ -176,6 +169,8 @@ ghc -dynamic -shared Foo.o -o libfoo.so
       The details of how this works varies between platforms, in particular
       the three major systems: Unix ELF platforms, Windows and Mac OS X.
     </para>
+    <sect3 id="finding-shared-libs-unix">
+    <title>Unix</title>
     <para>
       On Unix there are two mechanisms. Shared libraries can be installed
       into standard locations that the dynamic linker knows about. For
@@ -190,20 +185,21 @@ ghc -dynamic -shared Foo.o -o libfoo.so
     <para>
       GHC has a <literal>-dynload</literal> linking flag to select the method
       that is used to find shared libraries at runtime. There are currently
-      three modes:
+      two modes:
       <variablelist>
 	<varlistentry>
 	  <term>sysdep</term>
 	  <listitem>
 	    <para>
 	      A system-dependent mode. This is also the default mode. On Unix
-	      ELF systems this embeds rpaths into the shared library or
-	      executable. In particular it uses absolute paths to where the
-	      shared libraries for the rts and each package can be found.
-	      This means the program can immediately be run and it will be
-	      able to find the libraries it needs. However it may not be
-	      suitable for deployment if the libraries are installed in a
-	      different location on another machine.
+	      ELF systems this embeds
+        <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+        shared library or executable. In particular it uses absolute paths to
+        where the shared libraries for the rts and each package can be found.
+	      This means the program can immediately be run and it will be able to
+        find the libraries it needs. However it may not be suitable for
+        deployment if the libraries are installed in a different location on
+        another machine.
 	    </para>
 	  </listitem>
 	</varlistentry>
@@ -220,8 +216,7 @@ ghc -dynamic -shared Foo.o -o libfoo.so
 	</varlistentry>
       </variablelist>
       To use relative paths for dependent libraries on Linux and Solaris you
-      can use the <literal>deploy</literal> mode and pass suitable a -rpath
-      flag to the linker:
+      can pass a suitable <literal>-rpath</literal> flag to the linker:
 <programlisting>
 ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
 </programlisting>
@@ -232,7 +227,24 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
       executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
     </para>
     <para>
-      The standard assumption on Darwin/MacOS X is that dynamic libraries will
+      This relative path technique can be used with either of the two
+      <literal>-dynload</literal> modes, though it makes most sense with the
+      <literal>deploy</literal> mode. The difference is that with the
+      <literal>deploy</literal> mode, the above example will end up with an ELF
+      <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+      the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+      <literal>$ORIGIN</literal> followed by all the library directories of all
+      the packages that the program depends on (e.g. <literal>base</literal>
+      and <literal>rts</literal> packages etc.) which are typically absolute
+      paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+      inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+      entries in ELF shared libraries and executables.
+    </para>
+    </sect3>
+    <sect3 id="finding-shared-libs-mac">
+    <title>Mac OS X</title>
+    <para>
+      The standard assumption on Darwin/Mac OS X is that dynamic libraries will
       be stamped at build time with an "install name", which is the full
       ultimate install path of the library file. Any libraries or executables
       that subsequently link against it (even if it hasn't been installed yet)
@@ -244,6 +256,7 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
       for you. It automatically sets the install name for dynamic libraries to
       the absolute path of the ultimate install location.
     </para>
+    </sect3>
   </sect2>
 
 </sect1>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index 115c290..df01521 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -783,18 +783,6 @@ ghc -c Foo.hs</screen>
     <variablelist>
       <varlistentry>
 	<term>
-          <option>-n</option>
-          <indexterm><primary><option>-n</option></primary></indexterm>
-        </term>
-	<listitem>
-	  <para>Does a dry-run, i.e. GHC goes through all the motions
-          of compiling as normal, but does not actually run any
-          external commands.</para>
-	</listitem>
-      </varlistentry>
-
-      <varlistentry>
-	<term>
           <option>-v</option>
           <indexterm><primary><option>-v</option></primary></indexterm>
         </term>
diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml
index f00e1e2..44f589a 100644
--- a/docs/users_guide/win32-dlls.xml
+++ b/docs/users_guide/win32-dlls.xml
@@ -209,15 +209,6 @@ make-sessions running under cygwin.
 </title>
 
 <para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>).  Note that
-building an entire Haskell application as a single DLL is still supported: it's
-	just multi-DLL Haskell programs that don't work.  The Windows
-	distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
-<para>
 <indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
 <indexterm><primary>DLLs, Win32</primary></indexterm>
 On Win32 platforms, the compiler is capable of both producing and using
@@ -226,6 +217,33 @@ section shows you how to make use of this facility.
 </para>
 
 <para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+  <listitem>
+    <para>
+      You can turn each Haskell package into a DLL, so that multiple
+      Haskell executables using the same packages can share the DLL files.
+      (As opposed to linking the libraries statically, which in effect
+      creates a new copy of the RTS and all libraries for each executable
+      produced.)
+    </para>
+    <para>
+      That is the same as the dynamic linking on other platforms, and it
+      is described in <xref linkend="using-shared-libs"/>.
+    </para>
+  </listitem>
+  <listitem>
+    <para>
+      You can package up a complete Haskell program as a DLL, to be called
+      by some external (usually non-Haskell) program. This is usually used
+      to implement plugins and the like, and is described below.
+    </para>
+  </listitem>
+</itemizedlist>
+</para>
+
+<!--
+<para>
 Until recently, <command>strip</command> didn't work reliably on DLLs, so you
 should test your version with care, or make sure you have the latest
 binutils. Unfortunately, we don't know exactly which version of binutils
diff --git a/ghc.spec.in b/ghc.spec.in
index c8eab26..2a70043 100644
--- a/ghc.spec.in
+++ b/ghc.spec.in
@@ -177,7 +177,6 @@ fi
 %{_prefix}/bin/ghci
 %{_prefix}/bin/ghci-%{version}
 %{_prefix}/bin/ghcprof
-%{_prefix}/bin/hasktags
 %{_prefix}/bin/hp2ps
 %{_prefix}/bin/hpc
 %{_prefix}/bin/hsc2hs-ghc
diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs
index c2e6973..fc5cf00 100644
--- a/ghc/GhciTags.hs
+++ b/ghc/GhciTags.hs
@@ -101,10 +101,11 @@ listModuleTags m = do
                      ]
 
   where
-    tyThing2TagKind (AnId _) = 'v'
+    tyThing2TagKind (AnId _)     = 'v'
     tyThing2TagKind (ADataCon _) = 'd'
-    tyThing2TagKind (ATyCon _) = 't'
-    tyThing2TagKind (AClass _) = 'c'
+    tyThing2TagKind (ATyCon _)   = 't'
+    tyThing2TagKind (AClass _)   = 'c'
+    tyThing2TagKind (ACoAxiom _) = 'x'
 
 
 data TagInfo = TagInfo
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 2685377..0f68607 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -38,7 +38,7 @@ import HscTypes ( handleFlagWarnings )
 import HsImpExp
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import RdrName (RdrName)
-import Outputable       hiding (printForUser, printForUserPartWay)
+import Outputable       hiding (printForUser, printForUserPartWay, bold)
 import Module           -- for ModuleEnv
 import Name
 import SrcLoc
diff --git a/ghc/ghc.wrapper b/ghc/ghc.wrapper
index 5003f9a..083a66d 100644
--- a/ghc/ghc.wrapper
+++ b/ghc/ghc.wrapper
@@ -1 +1 @@
-exec "$executablename" -B"$topdir" -pgmc "$pgmgcc" -pgma "$pgmgcc" -pgml "$pgmgcc" -pgmP "$pgmgcc -E -undef -traditional" ${1+"$@"}
+exec "$executablename" -B"$topdir" ${1+"$@"}
diff --git a/includes/Cmm.h b/includes/Cmm.h
index 0ba14fb..641faa2 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -464,8 +464,10 @@
 #define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
 #endif
 
-#define mutArrPtrsCardWords(n) \
-    ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
 
 #if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
 #define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
diff --git a/includes/Rts.h b/includes/Rts.h
index 51351fa..91ec76d 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -219,6 +219,12 @@ DLL_IMPORT_RTS extern char **prog_argv;	/* so we can get at these from Haskell *
 DLL_IMPORT_RTS extern int    prog_argc;
 DLL_IMPORT_RTS extern char  *prog_name;
 
+#ifdef mingw32_HOST_OS
+// We need these two from Haskell too
+void getWin32ProgArgv(int *argc, wchar_t **argv[]);
+void setWin32ProgArgv(int argc, wchar_t *argv[]);
+#endif
+
 void stackOverflow(void);
 
 void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
@@ -242,9 +248,6 @@ int stg_sig_install (int, int, void *);
    Miscellaneous garbage
    -------------------------------------------------------------------------- */
 
-/* declarations for runtime flags/values */
-#define MAX_RTS_ARGS 32
-
 #ifdef DEBUG
 #define TICK_VAR(arity) \
   extern StgInt SLOW_CALLS_##arity; \
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index f3f56c9..1bbb2f0 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -112,6 +112,7 @@
 #define EVENT_GC_END              10 /* ()                     */
 #define EVENT_REQUEST_SEQ_GC      11 /* ()                     */
 #define EVENT_REQUEST_PAR_GC      12 /* ()                     */
+/* 13, 14 deprecated */
 #define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */
 #define EVENT_LOG_MSG             16 /* (message ...)          */
 #define EVENT_STARTUP             17 /* (num_capabilities)     */
@@ -120,12 +121,40 @@
 #define EVENT_GC_IDLE             20 /* () */
 #define EVENT_GC_WORK             21 /* () */
 #define EVENT_GC_DONE             22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */
+#define EVENT_CAPSET_DELETE       26 /* (capset)               */
+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */
+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */
+/* the RTS identifier is in the form of "GHC-version rts_way"  */
+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings             */
+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */
+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */
+#define EVENT_OSPROCESS_PID       32 /* (capset, pid)          */
+#define EVENT_OSPROCESS_PPID      33 /* (capset, parent_pid)   */
 
-#define NUM_EVENT_TAGS            23
+
+/* Range 34 - 59 is available for new events */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_EVENT_TAGS            34
 
 #if 0  /* DEPRECATED EVENTS: */
+/* ghc changed how it handles sparks so these are no longer applicable */
 #define EVENT_CREATE_SPARK        13 /* (cap, thread) */
 #define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION             23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */
 #endif
 
 /*
@@ -152,6 +181,13 @@
  */
 #define THREAD_SUSPENDED_FOREIGN_CALL 6
 
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */
+
 #ifndef EVENTLOG_CONSTANTS_ONLY
 
 typedef StgWord16 EventTypeNum;
@@ -160,6 +196,8 @@ typedef StgWord32 EventThreadID;
 typedef StgWord16 EventCapNo;
 typedef StgWord16 EventPayloadSize; /* variable-size events */
 typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */
 
 #endif
 
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index b4e7b64..42ca671 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -244,7 +244,7 @@ extern RTS_FLAGS RtsFlags;
 extern int     prog_argc;
 extern char  **prog_argv;
 */
-extern int     rts_argc;  /* ditto */
-extern char   *rts_argv[];
+extern int      rts_argc;  /* ditto */
+extern char   **rts_argv;
 
 #endif	/* RTS_FLAGS_H */
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
index bbed216..3c6e6f6 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -53,24 +53,32 @@
  *
  * ------------------------------------------------------------------------- */
 
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size.  The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord.  Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
 typedef struct nursery_ {
     bdescr *       blocks;
-    unsigned int   n_blocks;
+    memcount       n_blocks;
 } nursery;
 
 typedef struct generation_ {
     unsigned int   no;			// generation number
 
     bdescr *       blocks;	        // blocks in this gen
-    unsigned int   n_blocks;	        // number of blocks
-    unsigned int   n_words;             // number of used words
+    memcount       n_blocks;            // number of blocks
+    memcount       n_words;             // number of used words
 
     bdescr *       large_objects;	// large objects (doubly linked)
-    unsigned int   n_large_blocks;      // no. of blocks used by large objs
-    unsigned long  n_new_large_words;   // words of new large objects
+    memcount       n_large_blocks;      // no. of blocks used by large objs
+    memcount       n_new_large_words;   // words of new large objects
                                         // (for allocation stats)
 
-    unsigned int   max_blocks;		// max blocks
+    memcount       max_blocks;          // max blocks
 
     StgTSO *       threads;             // threads in this gen
                                         // linked via global_link
@@ -98,11 +106,11 @@ typedef struct generation_ {
     // are copied into the following two fields.  After GC, these blocks
     // are freed.
     bdescr *     old_blocks;	        // bdescr of first from-space block
-    unsigned int n_old_blocks;		// number of blocks in from-space
-    unsigned int live_estimate;         // for sweeping: estimate of live data
+    memcount     n_old_blocks;         // number of blocks in from-space
+    memcount     live_estimate;         // for sweeping: estimate of live data
     
     bdescr *     scavenged_large_objects;  // live large objs after GC (d-link)
-    unsigned int n_scavenged_large_blocks; // size (not count) of above
+    memcount     n_scavenged_large_blocks; // size (not count) of above
 
     bdescr *     bitmap;  		// bitmap for compacting collection
 
diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h
index cd98666..6b1d319 100644
--- a/includes/stg/MachRegs.h
+++ b/includes/stg/MachRegs.h
@@ -67,6 +67,11 @@
    Caller-saves regs have to be saved around C-calls made from STG
    land, so this file defines CALLER_SAVES_<reg> for each <reg> that
    is designated caller-saves in that machine's C calling convention.
+
+   As it stands, the only registers that are ever marked caller saves
+   are the RX, FX, DX and USER registers; as a result, if you
+   decide to caller save a system register (e.g. SP, HP, etc), note that
+   this code path is completely untested! -- EZY
    -------------------------------------------------------------------------- */
 
 /* -----------------------------------------------------------------------------
diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h
index f1b0422..52fd6f1 100644
--- a/includes/stg/SMP.h
+++ b/includes/stg/SMP.h
@@ -306,6 +306,7 @@ load_load_barrier(void) {
 #define store_load_barrier() /* nothing */
 #define load_load_barrier()  /* nothing */
 
+#if !IN_STG_CODE || IN_STGCRUN
 INLINE_HEADER StgWord
 xchg(StgPtr p, StgWord w)
 {
@@ -337,6 +338,7 @@ atomic_dec(StgVolatilePtr p)
 {
     return --(*p);
 }
+#endif
 
 #define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p)))
 
diff --git a/mk/build.mk.sample b/mk/build.mk.sample
index a7764e2..a31b576 100644
--- a/mk/build.mk.sample
+++ b/mk/build.mk.sample
@@ -39,7 +39,7 @@ SRC_HC_OPTS     = -O -H64m
 GhcStage1HcOpts = -O -fasm
 GhcStage2HcOpts = -O2 -fasm
 GhcHcOpts       = -Rghc-timing
-GhcLibHcOpts    = -O2 -XGenerics
+GhcLibHcOpts    = -O2
 GhcLibWays     += p
 
 ifeq "$(PlatformSupportsSharedLibs)" "YES"
@@ -136,15 +136,6 @@ endif
 # -----------------------------------------------------------------------------
 # Other settings that might be useful
 
-# profiled RTS
-#GhcRtsCcOpts =  -pg -g
-
-# Optimised/profiled RTS
-#GhcRtsCcOpts = -O2 -pg
-
-#GhcRtsWithFrontPanel = YES
-#SRC_HC_OPTS += `gtk-config --libs`
-
 # NoFib settings
 NoFibWays =
 STRIP_CMD = :
diff --git a/mk/config.mk.in b/mk/config.mk.in
index f96302b..d4a7cbe 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -282,13 +282,8 @@ GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO)
 #
 # 	-O(2) is pretty desirable, otherwise no inlining of prelude
 #		things (incl "+") happens when compiling with this compiler
-#
-#	-XGenerics switches on generation of support code for 
-#		derivable type classes.  This is now off by default,
-#		but we switch it on for the libraries so that we generate
-#		the code in case someone importing wants it
 
-GhcLibHcOpts=-O2 -XGenerics
+GhcLibHcOpts=-O2
 
 # Strip local symbols from libraries?  This can make the libraries smaller,
 # but makes debugging somewhat more difficult.  Doesn't work with all ld's.
@@ -548,6 +543,11 @@ CC_STAGE0       = @CC_STAGE0@
 CC_STAGE1       = $(CC)
 CC_STAGE2       = $(CC)
 CC_STAGE3       = $(CC)
+AS              = $(WhatGccIsCalled)
+AS_STAGE0       = @CC_STAGE0@
+AS_STAGE1       = $(AS)
+AS_STAGE2       = $(AS)
+AS_STAGE3       = $(AS)
 
 # C compiler and linker flags from configure (e.g. -m<blah> to select
 # correct C compiler backend). The stage number is the stage of GHC
@@ -599,11 +599,11 @@ AR			= @ArCmd@
 AR_OPTS			= @ArArgs@
 ArSupportsAtFile = @ArSupportsAtFile@
 
-AR_STAGE0 = $(AR)
+AR_STAGE0 = @AR_STAGE0@
 AR_STAGE1 = $(AR)
 AR_STAGE2 = $(AR)
 AR_STAGE3 = $(AR)
-AR_OPTS_STAGE0 = $(AR_OPTS)
+AR_OPTS_STAGE0 = @AR_OPTS_STAGE0@
 AR_OPTS_STAGE1 = $(AR_OPTS)
 AR_OPTS_STAGE2 = $(AR_OPTS)
 AR_OPTS_STAGE3 = $(AR_OPTS)
@@ -611,7 +611,7 @@ EXTRA_AR_ARGS_STAGE0 = $(EXTRA_AR_ARGS)
 EXTRA_AR_ARGS_STAGE1 = $(EXTRA_AR_ARGS)
 EXTRA_AR_ARGS_STAGE2 = $(EXTRA_AR_ARGS)
 EXTRA_AR_ARGS_STAGE3 = $(EXTRA_AR_ARGS)
-ArSupportsAtFile_STAGE0 = $(ArSupportsAtFile)
+ArSupportsAtFile_STAGE0 = @ArSupportsAtFile_STAGE0@
 ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile)
 ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile)
 ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile)
@@ -769,8 +769,6 @@ ALEX_VERSION		= @AlexVersion@
 #
 SRC_ALEX_OPTS		= -g
 
-HSTAGS = @HstagsCmd@
-
 # Should we build haddock docs?
 HADDOCK_DOCS = YES
 # And HsColour the sources?
diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk
index c000f85..b7f788b 100644
--- a/mk/validate-settings.mk
+++ b/mk/validate-settings.mk
@@ -36,8 +36,7 @@ ifeq "$(ValidateHpc)" "YES"
 GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/
 endif
 ifeq "$(ValidateSlow)" "YES"
-GhcStage2HcOpts += -XGenerics -DDEBUG
-GhcLibHcOpts    += -XGenerics
+GhcStage2HcOpts += -DDEBUG
 endif
 
 ######################################################################
diff --git a/rts/Capability.c b/rts/Capability.c
index 9091fdd..fe5dbdc 100644
--- a/rts/Capability.c
+++ b/rts/Capability.c
@@ -253,6 +253,8 @@ initCapability( Capability *cap, nat i )
     cap->transaction_tokens = 0;
     cap->context_switch = 0;
     cap->pinned_object_block = NULL;
+
+    traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
 }
 
 /* ---------------------------------------------------------------------------
@@ -266,6 +268,10 @@ initCapability( Capability *cap, nat i )
 void
 initCapabilities( void )
 {
+    /* Declare a single capability set representing the process. 
+       Each capability will get added to this capset. */ 
+    traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
+
 #if defined(THREADED_RTS)
     nat i;
 
@@ -677,6 +683,31 @@ prodCapability (Capability *cap, Task *task)
 }
 
 /* ----------------------------------------------------------------------------
+ * tryGrabCapability
+ *
+ * Attempt to gain control of a Capability if it is free.
+ *
+ * ------------------------------------------------------------------------- */
+
+rtsBool
+tryGrabCapability (Capability *cap, Task *task)
+{
+    if (cap->running_task != NULL) return rtsFalse;
+    ACQUIRE_LOCK(&cap->lock);
+    if (cap->running_task != NULL) {
+	RELEASE_LOCK(&cap->lock);
+	return rtsFalse;
+    }
+    task->cap = cap;
+    cap->running_task = task;
+    RELEASE_LOCK(&cap->lock);
+    return rtsTrue;
+}
+
+
+#endif /* THREADED_RTS */
+
+/* ----------------------------------------------------------------------------
  * shutdownCapability
  *
  * At shutdown time, we want to let everything exit as cleanly as
@@ -692,8 +723,11 @@ prodCapability (Capability *cap, Task *task)
  * ------------------------------------------------------------------------- */
 
 void
-shutdownCapability (Capability *cap, Task *task, rtsBool safe)
+shutdownCapability (Capability *cap,
+                    Task *task USED_IF_THREADS,
+                    rtsBool safe USED_IF_THREADS)
 {
+#if defined(THREADED_RTS)
     nat i;
 
     task->cap = cap;
@@ -785,33 +819,23 @@ shutdownCapability (Capability *cap, Task *task, rtsBool safe)
     // threads performing foreign calls that will eventually try to 
     // return via resumeThread() and attempt to grab cap->lock.
     // closeMutex(&cap->lock);
-}
+    
+#endif /* THREADED_RTS */
 
-/* ----------------------------------------------------------------------------
- * tryGrabCapability
- *
- * Attempt to gain control of a Capability if it is free.
- *
- * ------------------------------------------------------------------------- */
+    traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no);
+}
 
-rtsBool
-tryGrabCapability (Capability *cap, Task *task)
+void
+shutdownCapabilities(Task *task, rtsBool safe)
 {
-    if (cap->running_task != NULL) return rtsFalse;
-    ACQUIRE_LOCK(&cap->lock);
-    if (cap->running_task != NULL) {
-	RELEASE_LOCK(&cap->lock);
-	return rtsFalse;
+    nat i;
+    for (i=0; i < n_capabilities; i++) {
+        ASSERT(task->incall->tso == NULL);
+        shutdownCapability(&capabilities[i], task, safe);
     }
-    task->cap = cap;
-    cap->running_task = task;
-    RELEASE_LOCK(&cap->lock);
-    return rtsTrue;
+    traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
 }
 
-
-#endif /* THREADED_RTS */
-
 static void
 freeCapability (Capability *cap)
 {
diff --git a/rts/Capability.h b/rts/Capability.h
index d580a83..d380af9 100644
--- a/rts/Capability.h
+++ b/rts/Capability.h
@@ -240,11 +240,6 @@ void prodCapability (Capability *cap, Task *task);
 //
 void prodAllCapabilities (void);
 
-// Waits for a capability to drain of runnable threads and workers,
-// and then acquires it.  Used at shutdown time.
-//
-void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
-
 // Attempt to gain control of a Capability if it is free.
 //
 rtsBool tryGrabCapability (Capability *cap, Task *task);
@@ -270,6 +265,15 @@ extern void grabCapability (Capability **pCap);
 
 #endif /* !THREADED_RTS */
 
+// Waits for a capability to drain of runnable threads and workers,
+// and then acquires it.  Used at shutdown time.
+//
+void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
+
+// Shut down all capabilities.
+//
+void shutdownCapabilities(Task *task, rtsBool wait_foreign);
+
 // cause all capabilities to context switch as soon as possible.
 void setContextSwitches(void);
 INLINE_HEADER void contextSwitchCapability(Capability *cap);
diff --git a/rts/GetEnv.h b/rts/GetEnv.h
new file mode 100644
index 0000000..5e3d0cf
--- /dev/null
+++ b/rts/GetEnv.h
@@ -0,0 +1,23 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * OS-independent interface to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef GETENV_H
+#define GETENV_H
+
+#include "BeginPrivate.h"
+
+/* Get the process environment vector (same style interface as argc/argv)
+ */
+void getProgEnvv  (int *out_envc, char **out_envv[]);
+void freeProgEnvv (int envc, char *envv[]);
+
+/* calls to getProgEnvv must have a corresponding freeProgEnvv */
+
+#include "EndPrivate.h"
+
+#endif /* GETENV_H */
diff --git a/rts/Linker.c b/rts/Linker.c
index c1310b0..28ba9a0 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -387,6 +387,8 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stg_asyncReadzh)                     \
       SymI_HasProto(stg_asyncWritezh)                    \
       SymI_HasProto(stg_asyncDoProczh)                   \
+      SymI_HasProto(getWin32ProgArgv)                    \
+      SymI_HasProto(setWin32ProgArgv)                    \
       SymI_HasProto(memset)                              \
       SymI_HasProto(inet_ntoa)                           \
       SymI_HasProto(inet_addr)                           \
@@ -2335,6 +2337,7 @@ unloadObj( char *path )
             //  stgFree(oc->image);
             // #endif
             stgFree(oc->fileName);
+            stgFree(oc->archiveMemberName);
             stgFree(oc->symbols);
             stgFree(oc->sections);
             stgFree(oc);
@@ -3680,31 +3683,6 @@ PLTSize(void)
  * Generic ELF functions
  */
 
-static char *
-findElfSection ( void* objImage, Elf_Word sh_type )
-{
-   char* ehdrC = (char*)objImage;
-   Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
-   Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
-   char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
-   char* ptr = NULL;
-   int i;
-
-   for (i = 0; i < ehdr->e_shnum; i++) {
-      if (shdr[i].sh_type == sh_type
-          /* Ignore the section header's string table. */
-          && i != ehdr->e_shstrndx
-          /* Ignore string tables named .stabstr, as they contain
-             debugging info. */
-          && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
-         ) {
-         ptr = ehdrC + shdr[i].sh_offset;
-         break;
-      }
-   }
-   return ptr;
-}
-
 static int
 ocVerifyImage_ELF ( ObjectCode* oc )
 {
@@ -3712,7 +3690,6 @@ ocVerifyImage_ELF ( ObjectCode* oc )
    Elf_Sym*  stab;
    int i, j, nent, nstrtab, nsymtabs;
    char* sh_strtab;
-   char* strtab;
 
    char*     ehdrC = (char*)(oc->image);
    Elf_Ehdr* ehdr  = (Elf_Ehdr*)ehdrC;
@@ -3794,20 +3771,64 @@ ocVerifyImage_ELF ( ObjectCode* oc )
                ehdrC + shdr[i].sh_offset,
                       ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
 
-      if (shdr[i].sh_type == SHT_REL) {
-          IF_DEBUG(linker,debugBelch("Rel  " ));
-      } else if (shdr[i].sh_type == SHT_RELA) {
-          IF_DEBUG(linker,debugBelch("RelA " ));
-      } else {
-          IF_DEBUG(linker,debugBelch("     "));
+#define SECTION_INDEX_VALID(ndx) (ndx > SHN_UNDEF && ndx < ehdr->e_shnum)
+
+      switch (shdr[i].sh_type) {
+
+        case SHT_REL:
+        case SHT_RELA:
+          IF_DEBUG(linker,debugBelch( shdr[i].sh_type == SHT_REL ? "Rel  " : "RelA "));
+
+          if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+            if (shdr[i].sh_link == SHN_UNDEF)
+              errorBelch("\n%s: relocation section #%d has no symbol table\n"
+                         "This object file has probably been fully striped. "
+                         "Such files cannot be linked.\n",
+                         oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+            else
+              errorBelch("\n%s: relocation section #%d has an invalid link field (%d)\n",
+                         oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+                         i, shdr[i].sh_link);
+            return 0;
+          }
+          if (shdr[shdr[i].sh_link].sh_type != SHT_SYMTAB) {
+            errorBelch("\n%s: relocation section #%d does not link to a symbol table\n",
+                       oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+            return 0;
+          }
+          if (!SECTION_INDEX_VALID(shdr[i].sh_info)) {
+            errorBelch("\n%s: relocation section #%d has an invalid info field (%d)\n",
+                       oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+                       i, shdr[i].sh_info);
+            return 0;
+          }
+
+          break;
+        case SHT_SYMTAB:
+          IF_DEBUG(linker,debugBelch("Sym  "));
+
+          if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+            errorBelch("\n%s: symbol table section #%d has an invalid link field (%d)\n",
+                       oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+                       i, shdr[i].sh_link);
+            return 0;
+          }
+          if (shdr[shdr[i].sh_link].sh_type != SHT_STRTAB) {
+            errorBelch("\n%s: symbol table section #%d does not link to a string table\n",
+                       oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+
+            return 0;
+          }
+          break;
+        case SHT_STRTAB: IF_DEBUG(linker,debugBelch("Str  ")); break;
+        default:         IF_DEBUG(linker,debugBelch("     ")); break;
       }
       if (sh_strtab) {
           IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
       }
    }
 
-   IF_DEBUG(linker,debugBelch( "\nString tables" ));
-   strtab = NULL;
+   IF_DEBUG(linker,debugBelch( "\nString tables\n" ));
    nstrtab = 0;
    for (i = 0; i < ehdr->e_shnum; i++) {
       if (shdr[i].sh_type == SHT_STRTAB
@@ -3817,18 +3838,16 @@ ocVerifyImage_ELF ( ObjectCode* oc )
              debugging info. */
           && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
          ) {
-         IF_DEBUG(linker,debugBelch("   section %d is a normal string table", i ));
-         strtab = ehdrC + shdr[i].sh_offset;
+         IF_DEBUG(linker,debugBelch("   section %d is a normal string table\n", i ));
          nstrtab++;
       }
    }
-   if (nstrtab != 1) {
-      errorBelch("%s: no string tables, or too many", oc->fileName);
-      return 0;
+   if (nstrtab == 0) {
+      IF_DEBUG(linker,debugBelch("   no normal string tables (potentially, but not necessarily a problem)\n"));
    }
 
    nsymtabs = 0;
-   IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
+   IF_DEBUG(linker,debugBelch( "Symbol tables\n" ));
    for (i = 0; i < ehdr->e_shnum; i++) {
       if (shdr[i].sh_type != SHT_SYMTAB) continue;
       IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
@@ -3870,13 +3889,17 @@ ocVerifyImage_ELF ( ObjectCode* oc )
          }
          IF_DEBUG(linker,debugBelch("  " ));
 
-         IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
+         IF_DEBUG(linker,debugBelch("name=%s\n",
+                        ehdrC + shdr[shdr[i].sh_link].sh_offset
+                              + stab[j].st_name ));
       }
    }
 
    if (nsymtabs == 0) {
-      errorBelch("%s: didn't find any symbol tables", oc->fileName);
-      return 0;
+     // Not having a symbol table is not in principle a problem.
+     // When an object file has no symbols then the 'strip' program
+     // typically will remove the symbol table entirely.
+     IF_DEBUG(linker,debugBelch("   no symbol tables (potentially, but not necessarily a problem)\n"));
    }
 
    return 1;
@@ -3923,16 +3946,11 @@ ocGetNames_ELF ( ObjectCode* oc )
 
    char*     ehdrC    = (char*)(oc->image);
    Elf_Ehdr* ehdr     = (Elf_Ehdr*)ehdrC;
-   char*     strtab   = findElfSection ( ehdrC, SHT_STRTAB );
+   char*     strtab;
    Elf_Shdr* shdr     = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
 
    ASSERT(symhash != NULL);
 
-   if (!strtab) {
-      errorBelch("%s: no strtab", oc->fileName);
-      return 0;
-   }
-
    k = 0;
    for (i = 0; i < ehdr->e_shnum; i++) {
       /* Figure out what kind of section it is.  Logic derived from
@@ -3965,12 +3983,16 @@ ocGetNames_ELF ( ObjectCode* oc )
 
       /* copy stuff into this module's object symbol table */
       stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
+      strtab = ehdrC + shdr[shdr[i].sh_link].sh_offset;
       nent = shdr[i].sh_size / sizeof(Elf_Sym);
 
       oc->n_symbols = nent;
       oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
                                    "ocGetNames_ELF(oc->symbols)");
 
+      //TODO: we ignore local symbols anyway right? So we can use the
+      //      shdr[i].sh_info to get the index of the first non-local symbol
+      // ie we should use j = shdr[i].sh_info
       for (j = 0; j < nent; j++) {
 
          char  isLocal = FALSE; /* avoids uninit-var warning */
@@ -4068,21 +4090,24 @@ ocGetNames_ELF ( ObjectCode* oc )
    relocations appear to be of this form. */
 static int
 do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
-                         Elf_Shdr* shdr, int shnum,
-                         Elf_Sym*  stab, char* strtab )
+                         Elf_Shdr* shdr, int shnum )
 {
    int j;
    char *symbol;
    Elf_Word* targ;
    Elf_Rel*  rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
+   Elf_Sym*  stab;
+   char*     strtab;
    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
    int target_shndx = shdr[shnum].sh_info;
    int symtab_shndx = shdr[shnum].sh_link;
+   int strtab_shndx = shdr[symtab_shndx].sh_link;
 
    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+   strtab= (char*)    (ehdrC + shdr[ strtab_shndx ].sh_offset);
    targ  = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
-   IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
-                          target_shndx, symtab_shndx ));
+   IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d and strtab %d\n",
+                          target_shndx, symtab_shndx, strtab_shndx ));
 
    /* Skip sections that we're not interested in. */
    {
@@ -4168,18 +4193,21 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
    sparc-solaris relocations appear to be of this form. */
 static int
 do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
-                          Elf_Shdr* shdr, int shnum,
-                          Elf_Sym*  stab, char* strtab )
+                          Elf_Shdr* shdr, int shnum )
 {
    int j;
    char *symbol = NULL;
    Elf_Addr targ;
    Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
+   Elf_Sym*  stab;
+   char*     strtab;
    int         nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
    int target_shndx = shdr[shnum].sh_info;
    int symtab_shndx = shdr[shnum].sh_link;
+   int strtab_shndx = shdr[symtab_shndx].sh_link;
 
    stab  = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+   strtab= (char*)    (ehdrC + shdr[ strtab_shndx ].sh_offset);
    targ  = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
    IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
                           target_shndx, symtab_shndx ));
@@ -4448,35 +4476,20 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
 static int
 ocResolve_ELF ( ObjectCode* oc )
 {
-   char *strtab;
    int   shnum, ok;
-   Elf_Sym*  stab  = NULL;
    char*     ehdrC = (char*)(oc->image);
    Elf_Ehdr* ehdr  = (Elf_Ehdr*) ehdrC;
    Elf_Shdr* shdr  = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
 
-   /* first find "the" symbol table */
-   stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
-   /* also go find the string table */
-   strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
-   if (stab == NULL || strtab == NULL) {
-      errorBelch("%s: can't find string or symbol table", oc->fileName);
-      return 0;
-   }
-
    /* Process the relocation sections. */
    for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
       if (shdr[shnum].sh_type == SHT_REL) {
-         ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
-                                       shnum, stab, strtab );
+         ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, shnum );
          if (!ok) return ok;
       }
       else
       if (shdr[shnum].sh_type == SHT_RELA) {
-         ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
-                                        shnum, stab, strtab );
+         ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, shnum );
          if (!ok) return ok;
       }
    }
@@ -4509,8 +4522,12 @@ static int ocAllocateSymbolExtras_ELF( ObjectCode *oc )
 
   if( i == ehdr->e_shnum )
   {
-    errorBelch( "This ELF file contains no symtab" );
-    return 0;
+    // Not having a symbol table is not in principle a problem.
+    // When an object file has no symbols then the 'strip' program
+    // typically will remove the symbol table entirely.
+    IF_DEBUG(linker, debugBelch( "The ELF file %s contains no symtab\n",
+             oc->archiveMemberName ? oc->archiveMemberName : oc->fileName ));
+    return 1;
   }
 
   if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 5c9cfb7..e17c6fb 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -212,6 +212,7 @@ stg_unsafeThawArrayzh
   }
 }
 
+
 /* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */
diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index f7fbd32..7d2a450 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -18,6 +18,7 @@
 #include "LdvProfile.h"
 #include "Arena.h"
 #include "Printer.h"
+#include "sm/GCThread.h"
 
 #include <string.h>
 
@@ -812,7 +813,7 @@ dumpCensus( Census *census )
 		rs->id = -(rs->id);
 
 	    // report in the unit of bytes: * sizeof(StgWord)
-	    printRetainerSetShort(hp_file, rs);
+	    printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength);
 	    break;
 	}
 	default:
@@ -1057,8 +1058,9 @@ heapCensusChain( Census *census, bdescr *bd )
 void
 heapCensus( void )
 {
-  nat g;
+  nat g, n;
   Census *census;
+  gen_workspace *ws;
 
   census = &censuses[era];
   census->time  = mut_user_time();
@@ -1080,6 +1082,13 @@ heapCensus( void )
       // Are we interested in large objects?  might be
       // confusing to include the stack in a heap profile.
       heapCensusChain( census, generations[g].large_objects );
+
+      for (n = 0; n < n_capabilities; n++) {
+          ws = &gc_threads[n]->gens[g];
+          heapCensusChain(census, ws->todo_bd);
+          heapCensusChain(census, ws->part_list);
+          heapCensusChain(census, ws->scavd_list);
+      }
   }
 
   // dump out the census info
diff --git a/rts/RetainerSet.c b/rts/RetainerSet.c
index 5e9b37c..d93ae4b 100644
--- a/rts/RetainerSet.c
+++ b/rts/RetainerSet.c
@@ -265,35 +265,34 @@ printRetainer(FILE *f, retainer cc)
 #if defined(RETAINER_SCHEME_INFO)
 // Retainer scheme 1: retainer = info table
 void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
 {
-#define MAX_RETAINER_SET_SPACE  24
-    char tmp[MAX_RETAINER_SET_SPACE + 1];
+    char tmp[max_length + 1];
     int size;
     nat j;
 
     ASSERT(rs->id < 0);
 
-    tmp[MAX_RETAINER_SET_SPACE] = '\0';
+    tmp[max_length] = '\0';
 
     // No blank characters are allowed.
     sprintf(tmp + 0, "(%d)", -(rs->id));
     size = strlen(tmp);
-    ASSERT(size < MAX_RETAINER_SET_SPACE);
+    ASSERT(size < max_length);
 
     for (j = 0; j < rs->num; j++) {
 	if (j < rs->num - 1) {
-	    strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
-	    strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, ",", max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
 	}
 	else {
-	    strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
 	    // size = strlen(tmp);
 	}
     }
@@ -302,10 +301,9 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
 #elif defined(RETAINER_SCHEME_CC)
 // Retainer scheme 3: retainer = cost centre
 void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
 {
-#define MAX_RETAINER_SET_SPACE  24
-    char tmp[MAX_RETAINER_SET_SPACE + 1];
+    char tmp[max_length + 1];
     int size;
     nat j;
 
@@ -313,35 +311,34 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
 #elif defined(RETAINER_SCHEME_CCS)
 // Retainer scheme 2: retainer = cost centre stack
 void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
 {
-#define MAX_RETAINER_SET_SPACE  24
-    char tmp[MAX_RETAINER_SET_SPACE + 1];
-    int size;
+    char tmp[max_length + 1];
+    nat size;
     nat j;
 
     ASSERT(rs->id < 0);
 
-    tmp[MAX_RETAINER_SET_SPACE] = '\0';
+    tmp[max_length] = '\0';
 
     // No blank characters are allowed.
     sprintf(tmp + 0, "(%d)", -(rs->id));
     size = strlen(tmp);
-    ASSERT(size < MAX_RETAINER_SET_SPACE);
+    ASSERT(size < max_length);
 
     for (j = 0; j < rs->num; j++) {
 	if (j < rs->num - 1) {
-	    strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
-	    strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, ",", max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
 	}
 	else {
-	    strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
 	    // size = strlen(tmp);
 	}
     }
@@ -350,46 +347,44 @@ printRetainerSetShort(FILE *f, RetainerSet *rs)
 #elif defined(RETAINER_SCHEME_CC)
 // Retainer scheme 3: retainer = cost centre
 static void
-printRetainerSetShort(FILE *f, retainerSet *rs)
+printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length)
 {
-#define MAX_RETAINER_SET_SPACE  24
-    char tmp[MAX_RETAINER_SET_SPACE + 1];
+    char tmp[max_length + 1];
     int size;
     nat j;
 
     ASSERT(rs->id < 0);
 
-    tmp[MAX_RETAINER_SET_SPACE] = '\0';
+    tmp[max_length] = '\0';
 
     // No blank characters are allowed.
     sprintf(tmp + 0, "(%d)", -(rs->id));
     size = strlen(tmp);
-    ASSERT(size < MAX_RETAINER_SET_SPACE);
+    ASSERT(size < max_length);
 
     for (j = 0; j < rs->num; j++) {
 	if (j < rs->num - 1) {
 	    strncpy(tmp + size, rs->element[j]->label,
-		    MAX_RETAINER_SET_SPACE - size);
+		    max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
-	    strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+	    strncpy(tmp + size, ",", max_length - size);
 	    size = strlen(tmp);
-	    if (size == MAX_RETAINER_SET_SPACE)
+	    if (size == max_length)
 		break;
 	}
 	else {
 	    strncpy(tmp + size, rs->element[j]->label,
-		    MAX_RETAINER_SET_SPACE - size);
+		    max_length - size);
 	    // size = strlen(tmp);
 	}
     }
     fprintf(f, tmp);
 /*
-  #define MAX_RETAINER_SET_SPACE  24
   #define DOT_NUMBER              3
-  // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0')
-  // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for
+  // 1. 32 > max_length + 1 (1 for '\0')
+  // 2. (max_length - DOT_NUMBER ) characters should be enough for
   //    printing one natural number (plus '(' and ')').
   char tmp[32];
   int size, ts;
@@ -400,12 +395,12 @@ printRetainerSetShort(FILE *f, retainerSet *rs)
   // No blank characters are allowed.
   sprintf(tmp + 0, "(%d)", -(rs->id));
   size = strlen(tmp);
-  ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER);
+  ASSERT(size < max_length - DOT_NUMBER);
 
   for (j = 0; j < rs->num; j++) {
     ts = strlen(rs->element[j]->label);
     if (j < rs->num - 1) {
-      if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+      if (size + ts + 1 > max_length - DOT_NUMBER) {
         sprintf(tmp + size, "...");
         break;
       }
@@ -413,7 +408,7 @@ printRetainerSetShort(FILE *f, retainerSet *rs)
       size += ts + 1;
     }
     else {
-      if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+      if (size + ts > max_length - DOT_NUMBER) {
         sprintf(tmp + size, "...");
         break;
       }
diff --git a/rts/RetainerSet.h b/rts/RetainerSet.h
index 74152b9..5004527 100644
--- a/rts/RetainerSet.h
+++ b/rts/RetainerSet.h
@@ -165,7 +165,7 @@ void traverseAllRetainerSet(void (*f)(RetainerSet *));
 
 #ifdef SECOND_APPROACH
 // Prints a single retainer set.
-void printRetainerSetShort(FILE *, RetainerSet *);
+void printRetainerSetShort(FILE *, RetainerSet *, nat);
 #endif
 
 // Print the statistics on all the retainer sets.
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 408e1c7..9c0ec9e 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -33,7 +33,15 @@ int     full_prog_argc = 0;    /* an "int" so as to match normal "argc" */
 char  **full_prog_argv = NULL;
 char   *prog_name = NULL; /* 'basename' of prog_argv[0] */
 int     rts_argc = 0;  /* ditto */
-char   *rts_argv[MAX_RTS_ARGS];
+char  **rts_argv = NULL;
+#if defined(mingw32_HOST_OS)
+// On Windows, we want to use GetCommandLineW rather than argc/argv,
+// but we need to mutate the command line arguments for withProgName and
+// friends. The System.Environment module achieves that using this bit of
+// shared state:
+int       win32_prog_argc = 0;
+wchar_t **win32_prog_argv = NULL;
+#endif
 
 /*
  * constants, used later 
@@ -65,6 +73,10 @@ static void read_trace_flags(char *arg);
 
 static void errorUsage      (void) GNU_ATTRIBUTE(__noreturn__);
 
+static char *  copyArg  (char *arg);
+static char ** copyArgv (int argc, char *argv[]);
+static void    freeArgv (int argc, char *argv[]);
+
 /* -----------------------------------------------------------------------------
  * Command-line option parsing routines.
  * ---------------------------------------------------------------------------*/
@@ -379,15 +391,11 @@ static void splitRtsFlags(char *s)
 	
 	if (c1 == c2) { break; }
 	
-        if (rts_argc < MAX_RTS_ARGS-1) {
-	    s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
-	    strncpy(s, c1, c2-c1);
-	    s[c2-c1] = '\0';
-            rts_argv[rts_argc++] = s;
-	} else {
-	    barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
-	}
-	
+        s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
+        strncpy(s, c1, c2-c1);
+        s[c2-c1] = '\0';
+        rts_argv[rts_argc++] = s;
+
 	c1 = c2;
     } while (*c1 != '\0');
 }
@@ -399,13 +407,13 @@ static void splitRtsFlags(char *s)
      - argv[] is *modified*, any RTS options have been stripped out
      - *argc  contains the new count of arguments in argv[]
 
-     - rts_argv[]  (global) contains the collected RTS args
+     - rts_argv[]  (global) contains a copy of the collected RTS args
      - rts_argc    (global) contains the count of args in rts_argv
 
-     - prog_argv[] (global) contains the non-RTS args (== argv)
+     - prog_argv[] (global) contains a copy of the non-RTS args (== argv)
      - prog_argc   (global) contains the count of args in prog_argv
 
-     - prog_name   (global) contains the basename of argv[0]
+     - prog_name   (global) contains the basename of prog_argv[0]
 
   -------------------------------------------------------------------------- */
 
@@ -422,6 +430,8 @@ void setupRtsFlags (int *argc, char *argv[])
     *argc = 1;
     rts_argc = 0;
 
+    rts_argv = stgCallocBytes(total_arg + 1, sizeof (char *), "setupRtsFlags");
+
     rts_argc0 = rts_argc;
 
     // process arguments from the ghc_rts_opts global variable first.
@@ -473,14 +483,11 @@ void setupRtsFlags (int *argc, char *argv[])
 	else if (strequal("-RTS", argv[arg])) {
 	    mode = PGM;
 	}
-        else if (mode == RTS && rts_argc < MAX_RTS_ARGS-1) {
-            rts_argv[rts_argc++] = argv[arg];
+        else if (mode == RTS) {
+            rts_argv[rts_argc++] = copyArg(argv[arg]);
         }
-        else if (mode == PGM) {
-	    argv[(*argc)++] = argv[arg];
-	}
-	else {
-	  barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
+        else {
+            argv[(*argc)++] = argv[arg];
 	}
     }
     // process remaining program arguments
@@ -1451,6 +1458,41 @@ bad_option(const char *s)
   stg_exit(EXIT_FAILURE);
 }
 
+/* ----------------------------------------------------------------------------
+   Copying and freeing argc/argv
+   ------------------------------------------------------------------------- */
+
+static char * copyArg(char *arg)
+{
+    char *new_arg = stgMallocBytes(strlen(arg) + 1, "copyArg");
+    strcpy(new_arg, arg);
+    return new_arg;
+}
+
+static char ** copyArgv(int argc, char *argv[])
+{
+    int i;
+    char **new_argv;
+
+    new_argv = stgCallocBytes(argc + 1, sizeof (char *), "copyArgv 1");
+    for (i = 0; i < argc; i++) {
+        new_argv[i] = copyArg(argv[i]);
+    }
+    new_argv[argc] = NULL;
+    return new_argv;
+}
+
+static void freeArgv(int argc, char *argv[])
+{
+    int i;
+    if (argv != NULL) {
+        for (i = 0; i < argc; i++) {
+            stgFree(argv[i]);
+        }
+        stgFree(argv);
+    }
+}
+
 /* -----------------------------------------------------------------------------
    Getting/Setting the program's arguments.
 
@@ -1492,10 +1534,29 @@ void
 setProgArgv(int argc, char *argv[])
 {
     prog_argc = argc;
-    prog_argv = argv;
+    prog_argv = copyArgv(argc,argv);
     setProgName(prog_argv);
 }
 
+static void
+freeProgArgv(void)
+{
+    freeArgv(prog_argc,prog_argv);
+    prog_argc = 0;
+    prog_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+   The full argv - a copy of the original program's argc/argv
+   ------------------------------------------------------------------------- */
+
+void
+setFullProgArgv(int argc, char *argv[])
+{
+    full_prog_argc = argc;
+    full_prog_argv = copyArgv(argc,argv);
+}
+
 /* These functions record and recall the full arguments, including the
    +RTS ... -RTS options. The reason for adding them was so that the
    ghc-inplace program can pass /all/ the arguments on to the real ghc. */
@@ -1507,32 +1568,91 @@ getFullProgArgv(int *argc, char **argv[])
 }
 
 void
-setFullProgArgv(int argc, char *argv[])
+freeFullProgArgv (void)
 {
-    int i;
-    full_prog_argc = argc;
-    full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *),
-                                    "setFullProgArgv 1");
-    for (i = 0; i < argc; i++) {
-        full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1,
-                                           "setFullProgArgv 2");
-        strcpy(full_prog_argv[i], argv[i]);
-    }
-    full_prog_argv[argc] = NULL;
+    freeArgv(full_prog_argc, full_prog_argv);
+    full_prog_argc = 0;
+    full_prog_argv = NULL;
 }
 
+/* ----------------------------------------------------------------------------
+   The Win32 argv
+   ------------------------------------------------------------------------- */
+
+#if defined(mingw32_HOST_OS)
+void freeWin32ProgArgv (void);
+
 void
-freeFullProgArgv (void)
+freeWin32ProgArgv (void)
 {
+    freeArgv(win32_prog_argc, win32_prog_argv);
+
     int i;
 
-    if (full_prog_argv != NULL) {
-        for (i = 0; i < full_prog_argc; i++) {
-            stgFree(full_prog_argv[i]);
+    if (win32_prog_argv != NULL) {
+        for (i = 0; i < win32_prog_argc; i++) {
+            stgFree(win32_prog_argv[i]);
         }
-        stgFree(full_prog_argv);
+        stgFree(win32_prog_argv);
     }
 
-    full_prog_argc = 0;
-    full_prog_argv = NULL;
+    win32_prog_argc = 0;
+    win32_prog_argv = NULL;
+}
+
+void
+getWin32ProgArgv(int *argc, wchar_t **argv[])
+{
+    *argc = win32_prog_argc;
+    *argv = win32_prog_argv;
+}
+
+void
+setWin32ProgArgv(int argc, wchar_t *argv[])
+{
+	int i;
+    
+	freeWin32ProgArgv();
+
+    win32_prog_argc = argc;
+	if (argv == NULL) {
+		win32_prog_argv = NULL;
+		return;
+	}
+	
+    win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *),
+                                    "setWin32ProgArgv 1");
+    for (i = 0; i < argc; i++) {
+        win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t),
+                                           "setWin32ProgArgv 2");
+        wcscpy(win32_prog_argv[i], argv[i]);
+    }
+    win32_prog_argv[argc] = NULL;
+}
+#endif
+
+/* ----------------------------------------------------------------------------
+   The RTS argv
+   ------------------------------------------------------------------------- */
+
+static void
+freeRtsArgv(void)
+{
+    freeArgv(rts_argc,rts_argv);
+    rts_argc = 0;
+    rts_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+   All argvs
+   ------------------------------------------------------------------------- */
+
+void freeRtsArgs(void)
+{
+#if defined(mingw32_HOST_OS)
+    freeWin32ProgArgv();
+#endif
+    freeFullProgArgv();
+    freeProgArgv();
+    freeRtsArgv();
 }
diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h
index 3ebfef6..a6bfe0a 100644
--- a/rts/RtsFlags.h
+++ b/rts/RtsFlags.h
@@ -17,6 +17,7 @@
 void initRtsFlagsDefaults (void);
 void setupRtsFlags        (int *argc, char *argv[]);
 void setProgName          (char *argv[]);
+void freeRtsArgs          (void);
 
 #include "EndPrivate.h"
 
diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d
index dbc5111..bd32fca 100644
--- a/rts/RtsProbes.d
+++ b/rts/RtsProbes.d
@@ -23,6 +23,8 @@
  * typedef uint16_t EventCapNo;
  * typedef uint16_t EventPayloadSize; // variable-size events
  * typedef uint16_t EventThreadStatus;
+ * typedef uint32_t EventCapsetID;
+ * typedef uint16_t EventCapsetType;  // types for EVENT_CAPSET_CREATE
  */
 
 /* -----------------------------------------------------------------------------
@@ -60,5 +62,9 @@ provider HaskellEvent {
   probe gc__idle (EventCapNo);
   probe gc__work (EventCapNo);
   probe gc__done (EventCapNo);
+  probe capset__create(EventCapsetID, EventCapsetType);
+  probe capset__delete(EventCapsetID);
+  probe capset__assign__cap(EventCapsetID, EventCapNo);
+  probe capset__remove__cap(EventCapsetID, EventCapNo);
 
 };
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 236d07a..c115701 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -144,15 +144,18 @@ hs_init(int *argc, char **argv[])
 #ifdef TRACING
     initTracing();
 #endif
-    /* Dtrace events are always enabled
+    /* Trace the startup event
      */
-    dtraceEventStartup();
+    traceEventStartup();
 
     /* initialise scheduler data structures (needs to be done before
      * initStorage()).
      */
     initScheduler();
 
+    /* Trace some basic information about the process */
+    traceOSProcessInfo();
+
     /* initialize the storage manager */
     initStorage();
 
@@ -297,9 +300,6 @@ hs_exit_(rtsBool wait_foreign)
     checkFPUStack();
 #endif
 
-    // Free the full argv storage
-    freeFullProgArgv();
-
 #if defined(THREADED_RTS)
     ioManagerDie();
 #endif
@@ -402,6 +402,8 @@ hs_exit_(rtsBool wait_foreign)
     // heap memory (e.g. by being passed a ByteArray#).
     freeStorage(wait_foreign);
 
+    // Free the various argvs
+    freeRtsArgs();
 }
 
 // The real hs_exit():
diff --git a/rts/Schedule.c b/rts/Schedule.c
index f5cb568..fd5536b 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1447,6 +1447,12 @@ delete_threads_and_gc:
         recent_activity = ACTIVITY_YES;
     }
 
+    if (heap_census) {
+        debugTrace(DEBUG_sched, "performing heap census");
+        heapCensus();
+	performHeapProfile = rtsFalse;
+    }
+
 #if defined(THREADED_RTS)
     if (gc_type == PENDING_GC_PAR)
     {
@@ -1454,12 +1460,6 @@ delete_threads_and_gc:
     }
 #endif
 
-    if (heap_census) {
-        debugTrace(DEBUG_sched, "performing heap census");
-        heapCensus();
-	performHeapProfile = rtsFalse;
-    }
-
     if (heap_overflow && sched_state < SCHED_INTERRUPTING) {
         // GC set the heap_overflow flag, so we should proceed with
         // an orderly shutdown now.  Ultimately we want the main
@@ -2030,16 +2030,7 @@ exitScheduler (rtsBool wait_foreign USED_IF_THREADS)
     }
     sched_state = SCHED_SHUTTING_DOWN;
 
-#if defined(THREADED_RTS)
-    { 
-	nat i;
-	
-	for (i = 0; i < n_capabilities; i++) {
-            ASSERT(task->incall->tso == NULL);
-	    shutdownCapability(&capabilities[i], task, wait_foreign);
-	}
-    }
-#endif
+    shutdownCapabilities(task, wait_foreign);
 
     boundTaskExiting(task);
 }
diff --git a/rts/Stats.c b/rts/Stats.c
index fa38472..8366bf4 100644
--- a/rts/Stats.c
+++ b/rts/Stats.c
@@ -547,6 +547,18 @@ stat_exit(int alloc)
             gc_elapsed += GC_coll_elapsed[i];
         }
 
+        init_cpu     = end_init_cpu - start_init_cpu;
+        init_elapsed = end_init_elapsed - start_init_elapsed;
+
+        exit_cpu     = end_exit_cpu - start_exit_cpu;
+        exit_elapsed = end_exit_elapsed - start_exit_elapsed;
+
+        mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed;
+
+        mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu
+            - PROF_VAL(RP_tot_time + HC_tot_time);
+        if (mut_cpu < 0) { mut_cpu = 0; }
+
 	if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) {
 	    showStgWord64(GC_tot_alloc*sizeof(W_), 
 				 temp, rtsTrue/*commas*/);
@@ -635,21 +647,9 @@ stat_exit(int alloc)
             }
 #endif
 
-            init_cpu     = end_init_cpu - start_init_cpu;
-            init_elapsed = end_init_elapsed - start_init_elapsed;
-
-            exit_cpu     = end_exit_cpu - start_exit_cpu;
-            exit_elapsed = end_exit_elapsed - start_exit_elapsed;
-
 	    statsPrintf("  INIT    time  %6.2fs  (%6.2fs elapsed)\n",
                         TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed));
 
-            mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed;
-
-            mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu
-                - PROF_VAL(RP_tot_time + HC_tot_time);
-            if (mut_cpu < 0) { mut_cpu = 0; }
-
             statsPrintf("  MUT     time  %6.2fs  (%6.2fs elapsed)\n",
                         TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed));
             statsPrintf("  GC      time  %6.2fs  (%6.2fs elapsed)\n",
@@ -817,7 +817,7 @@ statDescribeGens(void)
           gen_blocks += gcThreadLiveBlocks(i,g);
       }
 
-      debugBelch("%5d %7d %9d", g, gen->max_blocks, mut);
+      debugBelch("%5d %7ld %9d", g, (lnat)gen->max_blocks, mut);
 
       gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live;
 
diff --git a/rts/Trace.c b/rts/Trace.c
index f2f9e81..e472c5a 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -15,11 +15,16 @@
 #ifdef TRACING
 
 #include "GetTime.h"
+#include "GetEnv.h"
 #include "Stats.h"
 #include "eventlog/EventLog.h"
 #include "Threads.h"
 #include "Printer.h"
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 #ifdef DEBUG
 // debugging flags, set with +RTS -D<something>
 int DEBUG_sched;
@@ -251,6 +256,83 @@ void traceSchedEvent_ (Capability *cap, EventTypeNum tag,
     }
 }
 
+void traceCapsetModify_ (EventTypeNum tag,
+                         CapsetID capset,
+                         StgWord32 other)
+{
+#ifdef DEBUG
+    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+        ACQUIRE_LOCK(&trace_utx);
+
+        tracePreface();
+        switch (tag) {
+        case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+            debugBelch("created capset %d of type %d\n", capset, other);
+            break;
+        case EVENT_CAPSET_DELETE:   // (capset)
+            debugBelch("deleted capset %d\n", capset);
+            break;
+        case EVENT_CAPSET_ASSIGN_CAP:  // (capset, capno)
+            debugBelch("assigned cap %d to capset %d\n", other, capset);
+            break;
+        case EVENT_CAPSET_REMOVE_CAP:  // (capset, capno)
+            debugBelch("removed cap %d from capset %d\n", other, capset);
+            break;
+        }
+        RELEASE_LOCK(&trace_utx);
+    } else
+#endif
+    {
+        if (eventlog_enabled) {
+            postCapsetModifyEvent(tag, capset, other);
+        }
+    }
+}
+
+void traceOSProcessInfo_(void) {
+    if (eventlog_enabled) {
+        postCapsetModifyEvent(EVENT_OSPROCESS_PID,
+                              CAPSET_OSPROCESS_DEFAULT,
+                              getpid());
+
+#if !defined(cygwin32_HOST_OS) && !defined (mingw32_HOST_OS)
+/* Windows has no strong concept of process heirarchy, so no getppid().
+ * In any case, this trace event is mainly useful for tracing programs
+ * that use 'forkProcess' which Windows doesn't support anyway.
+ */
+        postCapsetModifyEvent(EVENT_OSPROCESS_PPID,
+                              CAPSET_OSPROCESS_DEFAULT,
+                              getppid());
+#endif
+        {
+            char buf[256];
+            snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
+            postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
+                               CAPSET_OSPROCESS_DEFAULT,
+                               buf);
+        }
+        {
+            int argc = 0; char **argv;
+            getFullProgArgv(&argc, &argv);
+            if (argc != 0) {
+                postCapsetVecEvent(EVENT_PROGRAM_ARGS,
+                                   CAPSET_OSPROCESS_DEFAULT,
+                                   argc, argv);
+            }
+        }
+        {
+            int envc = 0; char **envv;
+            getProgEnvv(&envc, &envv);
+            if (envc != 0) {
+                postCapsetVecEvent(EVENT_PROGRAM_ENV,
+                                   CAPSET_OSPROCESS_DEFAULT,
+                                   envc, envv);
+            }
+            freeProgEnvv(envc, envv);
+        }
+    }
+}
+
 void traceEvent_ (Capability *cap, EventTypeNum tag)
 {
 #ifdef DEBUG
@@ -359,6 +441,12 @@ void traceThreadStatus_ (StgTSO *tso USED_IF_DEBUG)
     }
 }
 
+void traceEventStartup_(int nocaps)
+{
+    if (eventlog_enabled) {
+        postEventStartup(nocaps);
+    }
+}
 
 #ifdef DEBUG
 void traceBegin (const char *str, ...)
diff --git a/rts/Trace.h b/rts/Trace.h
index 6209156..1544971 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -31,6 +31,13 @@ void resetTracing (void);
 
 #endif /* TRACING */
 
+typedef StgWord32 CapsetID;
+typedef StgWord16 CapsetType;
+enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
+                  CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
+                  CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
+#define CAPSET_OSPROCESS_DEFAULT 0
+
 // -----------------------------------------------------------------------------
 // Message classes
 // -----------------------------------------------------------------------------
@@ -160,6 +167,23 @@ void traceUserMsg(Capability *cap, char *msg);
 
 void traceThreadStatus_ (StgTSO *tso);
 
+void traceEventStartup_ (int n_caps);
+
+/*
+ * Events for describing capability sets in the eventlog
+ *
+ * Note: unlike other events, these are not conditional on TRACE_sched or
+ * similar because they are not "real" events themselves but provide
+ * information and context for other "real" events. Other events depend on
+ * the capset info events so for simplicity, rather than working out if
+ * they're necessary we always emit them. They should be very low volume.
+ */
+void traceCapsetModify_ (EventTypeNum tag,
+                         CapsetID capset,
+                         StgWord32 other);
+
+void traceOSProcessInfo_ (void);
+
 #else /* !TRACING */
 
 #define traceSchedEvent(cap, tag, tso, other) /* nothing */
@@ -170,6 +194,9 @@ void traceThreadStatus_ (StgTSO *tso);
 #define debugTrace(class, str, ...) /* nothing */
 #define debugTraceCap(class, cap, str, ...) /* nothing */
 #define traceThreadStatus(class, tso) /* nothing */
+#define traceEventStartup_(n_caps) /* nothing */
+#define traceCapsetModify_(tag, capset, other) /* nothing */
+#define traceOSProcessInfo_() /* nothing */
 
 #endif /* TRACING */
 
@@ -226,6 +253,14 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
     HASKELLEVENT_GC_WORK(cap)
 #define dtraceGcDone(cap)                               \
     HASKELLEVENT_GC_DONE(cap)
+#define dtraceCapsetCreate(capset, capset_type)         \
+    HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
+#define dtraceCapsetDelete(capset)                      \
+    HASKELLEVENT_CAPSET_DELETE(capset)
+#define dtraceCapsetAssignCap(capset, capno)            \
+    HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
+#define dtraceCapsetRemoveCap(capset, capno)            \
+    HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
 
 #else /* !defined(DTRACE) */
 
@@ -248,6 +283,10 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
 #define dtraceGcIdle(cap)                               /* nothing */
 #define dtraceGcWork(cap)                               /* nothing */
 #define dtraceGcDone(cap)                               /* nothing */
+#define dtraceCapsetCreate(capset, capset_type)         /* nothing */
+#define dtraceCapsetDelete(capset)                      /* nothing */
+#define dtraceCapsetAssignCap(capset, capno)            /* nothing */
+#define dtraceCapsetRemoveCap(capset, capno)            /* nothing */
 
 #endif
 
@@ -374,17 +413,18 @@ INLINE_HEADER void traceEventCreateSparkThread(Capability  *cap      STG_UNUSED,
     dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid);
 }
 
-// This applies only to dtrace as EVENT_STARTUP in the logging framework is
-// handled specially in 'EventLog.c'.
-//
-INLINE_HEADER void dtraceEventStartup(void)
+INLINE_HEADER void traceEventStartup(void)
 {
+    int n_caps;
 #ifdef THREADED_RTS
     // XXX n_capabilities hasn't been initislised yet
-    dtraceStartup(RtsFlags.ParFlags.nNodes);
+    n_caps = RtsFlags.ParFlags.nNodes;
 #else
-    dtraceStartup(1);
+    n_caps = 1;
 #endif
+
+    traceEventStartup_(n_caps);
+    dtraceStartup(n_caps);
 }
 
 INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED)
@@ -405,6 +445,40 @@ INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED)
     dtraceGcDone((EventCapNo)cap->no);
 }
 
+INLINE_HEADER void traceCapsetCreate(CapsetID   capset      STG_UNUSED,
+                                     CapsetType capset_type STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type);
+    dtraceCapsetCreate(capset, capset_type);
+}
+
+INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0);
+    dtraceCapsetDelete(capset);
+}
+
+INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
+                                        nat      capno  STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno);
+    dtraceCapsetAssignCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
+                                        nat      capno  STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno);
+    dtraceCapsetRemoveCap(capset, capno);
+}
+
+INLINE_HEADER void traceOSProcessInfo(void)
+{
+    traceOSProcessInfo_();
+    /* Note: no DTrace equivalent because all this OS process info
+     * is available to DTrace directly */
+}
+
 #include "EndPrivate.h"
 
 #endif /* TRACE_H */
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index a77c257..cea313e 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -75,7 +75,16 @@ char *EventDesc[] = {
   [EVENT_GC_IDLE]             = "GC idle",
   [EVENT_GC_WORK]             = "GC working",
   [EVENT_GC_DONE]             = "GC done",
-  [EVENT_BLOCK_MARKER]        = "Block marker"
+  [EVENT_BLOCK_MARKER]        = "Block marker",
+  [EVENT_CAPSET_CREATE]       = "Create capability set",
+  [EVENT_CAPSET_DELETE]       = "Delete capability set",
+  [EVENT_CAPSET_ASSIGN_CAP]   = "Add capability to capability set",
+  [EVENT_CAPSET_REMOVE_CAP]   = "Remove capability from capability set",
+  [EVENT_RTS_IDENTIFIER]      = "RTS name and version",
+  [EVENT_PROGRAM_ARGS]        = "Program arguments",
+  [EVENT_PROGRAM_ENV]         = "Program environment variables",
+  [EVENT_OSPROCESS_PID]       = "Process ID",
+  [EVENT_OSPROCESS_PPID]      = "Parent process ID"
 };
 
 // Event type. 
@@ -146,6 +155,12 @@ static inline void postThreadID(EventsBuf *eb, EventThreadID id)
 static inline void postCapNo(EventsBuf *eb, EventCapNo no)
 { postWord16(eb,no); }
 
+static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
+{ postWord32(eb,id); }
+
+static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
+{ postWord16(eb,type); }
+
 static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
 { postWord16(eb,size); }
 
@@ -259,6 +274,27 @@ initEventLogging(void)
             eventTypes[t].size = sizeof(EventCapNo);
             break;
 
+        case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + sizeof(EventCapsetType);
+            break;
+
+        case EVENT_CAPSET_DELETE:   // (capset)
+            eventTypes[t].size = sizeof(EventCapsetID);
+            break;
+
+        case EVENT_CAPSET_ASSIGN_CAP:  // (capset, cap)
+        case EVENT_CAPSET_REMOVE_CAP:
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + sizeof(EventCapNo);
+            break;
+
+        case EVENT_OSPROCESS_PID:   // (cap, pid)
+        case EVENT_OSPROCESS_PPID:
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + sizeof(StgWord32);
+            break;
+
         case EVENT_SHUTDOWN:        // (cap)
         case EVENT_REQUEST_SEQ_GC:  // (cap)
         case EVENT_REQUEST_PAR_GC:  // (cap)
@@ -272,6 +308,9 @@ initEventLogging(void)
 
         case EVENT_LOG_MSG:          // (msg)
         case EVENT_USER_MSG:         // (msg)
+        case EVENT_RTS_IDENTIFIER:   // (capset, str)
+        case EVENT_PROGRAM_ARGS:     // (capset, strvec)
+        case EVENT_PROGRAM_ENV:      // (capset, strvec)
             eventTypes[t].size = 0xffff;
             break;
 
@@ -296,10 +335,6 @@ initEventLogging(void)
     
     // Prepare event buffer for events (data).
     postInt32(&eventBuf, EVENT_DATA_BEGIN);
-    
-    // Post a STARTUP event with the number of capabilities
-    postEventHeader(&eventBuf, EVENT_STARTUP);
-    postCapNo(&eventBuf, n_caps);
 
     // Flush capEventBuf with header.
     /*
@@ -443,6 +478,115 @@ postSchedEvent (Capability *cap,
     }
 }
 
+void postCapsetModifyEvent (EventTypeNum tag,
+                            EventCapsetID capset,
+                            StgWord32 other)
+{
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForEvent(&eventBuf, tag)) {
+        // Flush event buffer to make room for new event.
+        printAndClearEventBuf(&eventBuf);
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postCapsetID(&eventBuf, capset);
+
+    switch (tag) {
+    case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+    {
+        postCapsetType(&eventBuf, other /* capset_type */);
+        break;
+    }
+
+    case EVENT_CAPSET_DELETE:   // (capset)
+    {
+        break;
+    }
+
+    case EVENT_CAPSET_ASSIGN_CAP:  // (capset, capno)
+    case EVENT_CAPSET_REMOVE_CAP:  // (capset, capno)
+    {
+        postCapNo(&eventBuf, other /* capno */);
+        break;
+    }
+    case EVENT_OSPROCESS_PID:   // (capset, pid)
+    case EVENT_OSPROCESS_PPID:  // (capset, parent_pid)
+    {
+        postWord32(&eventBuf, other);
+        break;
+    }
+    default:
+        barf("postCapsetModifyEvent: unknown event tag %d", tag);
+    }
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetStrEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         char *msg)
+{
+    int strsize = strlen(msg);
+    int size = strsize + sizeof(EventCapsetID);
+
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForVariableEvent(&eventBuf, size)){
+        printAndClearEventBuf(&eventBuf);
+
+        if (!hasRoomForVariableEvent(&eventBuf, size)){
+            // Event size exceeds buffer size, bail out:
+            RELEASE_LOCK(&eventBufMutex);
+            return;
+        }
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postPayloadSize(&eventBuf, size);
+    postCapsetID(&eventBuf, capset);
+
+    postBuf(&eventBuf, (StgWord8*) msg, strsize);
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetVecEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         int argc,
+                         char *argv[])
+{
+    int i, size = sizeof(EventCapsetID);
+
+    for (i = 0; i < argc; i++) {
+        // 1 + strlen to account for the trailing \0, used as separator
+        size += 1 + strlen(argv[i]);
+    }
+
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForVariableEvent(&eventBuf, size)){
+        printAndClearEventBuf(&eventBuf);
+
+        if(!hasRoomForVariableEvent(&eventBuf, size)){
+            // Event size exceeds buffer size, bail out:
+            RELEASE_LOCK(&eventBufMutex);
+            return;
+        }
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postPayloadSize(&eventBuf, size);
+    postCapsetID(&eventBuf, capset);
+
+    for( i = 0; i < argc; i++ ) {
+        // again, 1 + to account for \0
+        postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
+    }
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
 void
 postEvent (Capability *cap, EventTypeNum tag)
 {
@@ -498,6 +642,22 @@ void postUserMsg(Capability *cap, char *msg, va_list ap)
     postLogMsg(&capEventBuf[cap->no], EVENT_USER_MSG, msg, ap);
 }    
 
+void postEventStartup(EventCapNo n_caps)
+{
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForEvent(&eventBuf, EVENT_STARTUP)) {
+        // Flush event buffer to make room for new event.
+        printAndClearEventBuf(&eventBuf);
+    }
+
+    // Post a STARTUP event with the number of capabilities
+    postEventHeader(&eventBuf, EVENT_STARTUP);
+    postCapNo(&eventBuf, n_caps);
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
 void closeBlockMarker (EventsBuf *ebuf)
 {
     StgInt8* save_pos;
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index 0cfab5c..602ac2c 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -45,6 +45,30 @@ void postUserMsg(Capability *cap, char *msg, va_list ap);
 
 void postCapMsg(Capability *cap, char *msg, va_list ap);
 
+void postEventStartup(EventCapNo n_caps);
+
+/*
+ * Post a capability set modification event
+ */
+void postCapsetModifyEvent (EventTypeNum tag,
+                            EventCapsetID capset,
+                            StgWord32 other);
+
+/*
+ * Post a capability set event with a string payload
+ */
+void postCapsetStrEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         char *msg);
+
+/*
+ * Post a capability set event with several strings payload
+ */
+void postCapsetVecEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         int argc,
+                         char *msg[]);
+
 #else /* !TRACING */
 
 INLINE_HEADER void postSchedEvent (Capability *cap  STG_UNUSED,
diff --git a/rts/ghc.mk b/rts/ghc.mk
index a236945..38ddbc0 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -295,6 +295,7 @@ rts/RtsMain_HC_OPTS += -optc-O0
 
 rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
 rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
+rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
 #
 rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
 rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
diff --git a/rts/posix/GetEnv.c b/rts/posix/GetEnv.c
new file mode 100644
index 0000000..4d5c7e2
--- /dev/null
+++ b/rts/posix/GetEnv.c
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#if defined(darwin_HOST_OS)
+
+/* While the "extern char** environ" var does exist on OSX, it is not
+ * available to shared libs. See ghc ticket #2458 and
+ * http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+ */
+#include <crt_externs.h>
+
+static char** get_environ(void) { return *(_NSGetEnviron()); }
+
+#else
+
+/* On proper unix systems the environ is just a global var.
+ */
+extern char** environ;
+static char** get_environ(void) { return environ; }
+
+#endif
+
+
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+    int envc;
+    char **environ = get_environ();
+    
+    for (envc = 0; environ[envc] != NULL; envc++) {};
+
+    *out_envc = envc;
+    *out_envv = environ;
+}
+
+void freeProgEnvv(int envc STG_UNUSED, char *envv[] STG_UNUSED) {
+    /* nothing */
+}
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index 3036140..51eab4e 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -408,16 +408,6 @@ GarbageCollect (rtsBool force_major_gc,
 
   // NO MORE EVACUATION AFTER THIS POINT!
 
-  // Two-space collector: free the old to-space.
-  // g0->old_blocks is the old nursery
-  // g0->blocks is to-space from the previous GC
-  if (RtsFlags.GcFlags.generations == 1) {
-      if (g0->blocks != NULL) {
-	  freeChain(g0->blocks);
-	  g0->blocks = NULL;
-      }
-  }
-
   // Finally: compact or sweep the oldest generation.
   if (major_gc && oldest_gen->mark) {
       if (oldest_gen->compact) 
@@ -1257,7 +1247,7 @@ prepare_collected_gen (generation *gen)
 
     // for a compacted generation, we need to allocate the bitmap
     if (gen->mark) {
-        nat bitmap_size; // in bytes
+        lnat bitmap_size; // in bytes
         bdescr *bitmap_bdescr;
         StgWord *bitmap;
 	
diff --git a/rts/win32/GetEnv.c b/rts/win32/GetEnv.c
new file mode 100644
index 0000000..b8a4395
--- /dev/null
+++ b/rts/win32/GetEnv.c
@@ -0,0 +1,61 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#include <windows.h>
+
+/* Windows does it differently, though arguably the most sanely.
+ * GetEnvironmentStrings() returns a pointer to a block of
+ * environment vars with a double null terminator:
+ *   Var1=Value1\0
+ *   Var2=Value2\0
+ *   ...
+ *   VarN=ValueN\0\0 
+ * But because everyone else (ie POSIX) uses a vector of strings, we convert
+ * to that format. Fortunately this is just a matter of making an array of
+ * offsets into the environment block.
+ *
+ * Note that we have to call FreeEnvironmentStrings() at the end.
+ *
+ */
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+    int envc, i;
+    char *env;
+    char *envp;
+    char **envv;
+
+    /* For now, use the 'A'nsi not 'W'ide variant.
+       Note: corresponding Free below must use the same 'A'/'W' variant. */
+    env = GetEnvironmentStringsA();
+
+    envc = 0;
+    for (envp = env; *envp != 0; envp += strlen(envp) + 1) {
+        envc++;
+    }
+
+    envv = stgMallocBytes(sizeof(char*) * (envc+1));
+
+    i = 0;
+    for (envp = env; *envp != NULL; envp += strlen(envp) + 1) {
+        envv[i] = envp;
+        i++;
+    }
+    /* stash whole env in last+1 entry */
+    envv[envc] = env;
+
+    *out_envc = envc;
+    *out_envv = envv;
+}
+
+void freeProgEnvv(int envc, char *envv[]) {
+    /* we stashed the win32 env block in the last+1 entry */
+    FreeEnvironmentStringsA(envv[envc]);
+    stgFree(envv);
+}
diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk
index 86f9323..9a66d1b 100644
--- a/rules/build-package-data.mk
+++ b/rules/build-package-data.mk
@@ -63,6 +63,11 @@ ifeq "$3" "0"
 $1_$2_CONFIGURE_OPTS += $$(BOOT_PKG_CONSTRAINTS)
 endif
 
+$1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)"
+
 ifneq "$$(BINDIST)" "YES"
 ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES"
 $1/$2/inplace-pkg-config : $1/$2/package-data.mk
@@ -72,7 +77,7 @@ $1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk
 # for our build system, and registers the package for use in-place in
 # the build tree.
 $1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP)
-	"$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" --with-gcc="$$(WhatGccIsCalled)" --configure-option=--with-cc="$$(WhatGccIsCalled)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
+	"$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
 ifeq "$$($1_$2_PROG)" ""
 ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO"
 	"$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config
diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk
index a7dc918..2497e29 100644
--- a/rules/build-package-way.mk
+++ b/rules/build-package-way.mk
@@ -64,17 +64,17 @@ ifeq "$3" "dyn"
 # On windows we have to supply the extra libs this one links to when building it.
 ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32"
 $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
-	"$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
+	"$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
          -shared -dynamic -dynload deploy \
 	 $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \
-         -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+         -no-auto-link-packages \
          -o $$@
 else
 $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
-	"$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
+	"$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
          -shared -dynamic -dynload deploy \
 	     -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \
-         -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+         -no-auto-link-packages \
          -o $$@
 endif
 else
diff --git a/rules/c-suffix-rules.mk b/rules/c-suffix-rules.mk
index bba73a8..a4a0b57 100644
--- a/rules/c-suffix-rules.mk
+++ b/rules/c-suffix-rules.mk
@@ -49,7 +49,7 @@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c
 	"$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
 
 $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s
-	"$$(AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
+	"$$($1_$2_AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
 
 $1/$2/build/%.$$($3_osuf) : $1/%.S | $$$$(dir $$$$@)/.
 	"$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk
index bebbc4d..5c56169 100644
--- a/rules/distdir-way-opts.mk
+++ b/rules/distdir-way-opts.mk
@@ -17,9 +17,9 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
 
 # Options for a Haskell compilation:
 #   - CONF_HC_OPTS                 source-tree-wide options, selected at
-#				   configure-time
+#                                  configure-time
 #   - SRC_HC_OPTS                  source-tree-wide options from build.mk
-#				   (optimisation, heap settings)
+#                                  (optimisation, heap settings)
 #   - libraries/base_HC_OPTS       options from Cabal for libraries/base
 #                                  for all ways
 #   - libraries/base_MORE_HC_OPTS  options from elsewhere in the build
@@ -27,7 +27,7 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
 #   - libraries/base_v_HC_OPTS     options from libraries/base for way v
 #   - WAY_v_HC_OPTS                options for this way
 #   - EXTRA_HC_OPTS                options from the command-line
-#   - -Idir1 -Idir2 ...		   include-dirs from this package
+#   - -Idir1 -Idir2 ...            include-dirs from this package
 #   - -odir/-hidir/-stubdir        put the output files under $3/build
 #   - -osuf/-hisuf/-hcsuf          suffixes for the output files in this way
 
@@ -134,6 +134,8 @@ $1_$2_$3_ALL_HSC2HS_OPTS = \
  --cflag=-D__GLASGOW_HASKELL__=$$(ProjectVersionInt) \
  $$($1_$2_$3_HSC2HS_CC_OPTS) \
  $$($1_$2_$3_HSC2HS_LD_OPTS) \
+ --cflag=-I$1/$2/build/autogen \
+ $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \
  $$($$(basename $$<)_HSC2HS_OPTS) \
  $$(EXTRA_HSC2HS_OPTS)
 
diff --git a/rules/package-config.mk b/rules/package-config.mk
index 7873157..177ca25 100644
--- a/rules/package-config.mk
+++ b/rules/package-config.mk
@@ -17,6 +17,7 @@ $(call profStart, package-config($1,$2,$3))
 
 $1_$2_HC = $$(GHC_STAGE$3)
 $1_$2_CC = $$(CC_STAGE$3)
+$1_$2_AS = $$(AS_STAGE$3)
 $1_$2_AR = $$(AR_STAGE$3)
 $1_$2_AR_OPTS = $$(AR_OPTS_STAGE$3)
 $1_$2_EXTRA_AR_ARGS = $$(EXTRA_AR_ARGS_STAGE$3)
diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk
index 6433957..5cc10dc 100644
--- a/rules/shell-wrapper.mk
+++ b/rules/shell-wrapper.mk
@@ -74,7 +74,6 @@ install_$1_$2_wrapper:
 	echo 'datadir="$$(datadir)"'                             >> "$$(WRAPPER)"
 	echo 'bindir="$$(bindir)"'                               >> "$$(WRAPPER)"
 	echo 'topdir="$$(topdir)"'                               >> "$$(WRAPPER)"
-	echo 'pgmgcc="$$(WhatGccIsCalled)"'                      >> "$$(WRAPPER)"
 	$$($1_$2_SHELL_WRAPPER_EXTRA)
 	$$($1_$2_INSTALL_SHELL_WRAPPER_EXTRA)
 	cat $$($1_$2_SHELL_WRAPPER_NAME)                         >> "$$(WRAPPER)"
diff --git a/settings.in b/settings.in
index f4e922a..5d4e1d3 100644
--- a/settings.in
+++ b/settings.in
@@ -1,4 +1,8 @@
 [("GCC extra via C opts", "@GccExtraViaCOpts@"),
  ("C compiler command", "@WhatGccIsCalled@"),
+ ("C compiler flags", "@CONF_CC_OPTS_STAGE2@"),
+ ("ar command", "@ArCmd@"),
+ ("ar flags", "@ArArgs@"),
+ ("ar supports at file", "@ArSupportsAtFile@"),
  ("perl command", "@PerlCmd@")]
 
diff --git a/sync-all b/sync-all
index 7ccc71d..8b41c97 100755
--- a/sync-all
+++ b/sync-all
@@ -310,20 +310,14 @@ sub scmall {
             if (-d "$localpath/.git") {
                 die "Found both _darcs and .git in $localpath";
             }
-            else {
-                $scm = "darcs";
-            }
-        }
-        else {
-            if (-d "$localpath/.git") {
-                $scm = "git";
-            }
-            elsif ($tag eq "") {
-                die "Required repo $localpath is missing";
-            }
-            else {
-                message "== $localpath repo not present; skipping";
-            }
+            $scm = "darcs";
+        } elsif (-d "$localpath/.git") {
+            $scm = "git";
+        } elsif ($tag eq "") {
+            die "Required repo $localpath is missing";
+        } else {
+             message "== $localpath repo not present; skipping";
+             next;
         }
 
         # Work out the arguments we should give to the SCM
@@ -372,6 +366,9 @@ sub scmall {
             my @scm_args = ("log", "$branch_name..");
             scm ($localpath, $scm, @scm_args, @args);
         }
+        elsif ($command =~ /^log$/) {
+            scm ($localpath, $scm, "log", @args);
+        }
         elsif ($command =~ /^remote$/) {
             my @scm_args;
             if ($subcommand eq 'add') {
@@ -383,6 +380,12 @@ sub scmall {
             }
             scm ($localpath, $scm, @scm_args, @args);
         }
+        elsif ($command =~ /^checkout$/) {
+            # Not all repos are necessarily branched, so ignore failure
+            $ignore_failure = 1;
+            scm ($localpath, $scm, "checkout", @args)
+                unless $scm eq "darcs";
+        }
         elsif ($command =~ /^grep$/) {
             # Hack around 'git grep' failing if there are no matches
             $ignore_failure = 1;
@@ -429,10 +432,12 @@ Supported commands:
  * remote add <branch-name>
  * remote rm <branch-name>
  * remote set-url [--push] <branch-name>
+ * checkout
  * grep
  * clean
  * reset
  * config
+ * log
 
 Available package-tags are:
 END
diff --git a/utils/Makefile b/utils/Makefile
index 881d7d5..e522c32 100644
--- a/utils/Makefile
+++ b/utils/Makefile
@@ -60,7 +60,7 @@ endif
 
 WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc
 
-WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock
+WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock
 ifneq "$(NO_INSTALL_HSC2HS)" "YES"
 WITH_STAGE2 += hsc2hs
 endif
diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py
new file mode 100755
index 0000000..f04b98e
--- /dev/null
+++ b/utils/fingerprint/fingerprint.py
@@ -0,0 +1,248 @@
+#! /usr/bin/env python
+# Script to create and restore a git fingerprint of the ghc repositories.
+
+from   datetime   import datetime
+from   optparse   import OptionParser
+import os
+import os.path
+import re
+import subprocess
+from   subprocess import PIPE, Popen
+import sys
+
+def main():
+  opts, args = parseopts(sys.argv[1:])
+  opts.action(opts)
+
+def create_action(opts):
+  """Action called for the create commmand"""
+  if opts.fpfile:
+    fp = FingerPrint.read(opts.source)
+  else:
+    fp = fingerprint(opts.source)
+  if len(fp) == 0:
+    error("Got empty fingerprint from source: "+str(opts.source))
+  if opts.output_file:
+    print "Writing fingerprint to: ", opts.output_file
+  fp.write(opts.output)
+
+def restore_action(opts):
+  """Action called for the restore commmand"""
+  def branch_name(filename):
+    return "fingerprint_" + os.path.basename(filename).replace(".", "_")
+  if opts.fpfile:
+    try:
+      fp = FingerPrint.read(opts.source)
+      bn = branch_name(opts.fpfile)
+    except MalformedFingerPrintError:
+      error("Error parsing fingerprint file: "+opts.fpfile)
+    if len(fp) == 0:
+      error("No fingerprint found in fingerprint file: "+opts.fpfile)
+  elif opts.logfile:
+    fp = fingerprint(opts.source)
+    bn = branch_name(opts.logfile)
+    if len(fp) == 0:
+      error("No fingerprint found in build log file: "+opts.logfile)
+  else:
+    error("Must restore from fingerprint or log file")
+  restore(fp, branch_name=bn if opts.branch else None)
+
+def fingerprint(source=None):
+  """Create a new fingerprint of current repositories.
+
+  The source argument is parsed to look for the expected output
+  from a `sync-all` command. If the source is `None` then the
+  `sync-all` command will be run to get the current fingerprint.
+  """
+  if source is None:
+    sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"]
+    source  = Popen(sync_all, stdout=PIPE).stdout
+
+  lib = ""
+  commits = {}
+  for line in source.readlines():
+    if line.startswith("=="):
+      lib = line.split()[1].rstrip(":")
+      lib = "." if lib == "running" else lib # hack for top ghc repo
+    elif re.match("[abcdef0-9]{40}", line):
+      commit = line[:40]
+      commits[lib] = commit
+  return FingerPrint(commits)
+
+def restore(fp, branch_name=None):
+  """Restore the ghc repos to the commits in the fingerprint
+
+  This function performs a checkout of each commit specifed in
+  the fingerprint. If `branch_name` is not None then a new branch
+  will be created for the top ghc repository. We also add an entry
+  to the git config that sets the remote for the new branch as `origin`
+  so that the `sync-all` command can be used from the branch.
+  """
+  checkout = ["git", "checkout"]
+
+  # run checkout in all subdirs
+  for (subdir, commit) in fp:
+    if subdir != ".":
+      cmd = checkout + [commit]
+      print "==", subdir, " ".join(cmd)
+      if os.path.exists(subdir):
+        rc = subprocess.call(cmd, cwd=subdir)
+        if rc != 0:
+          error("Too many errors, aborting")
+      else:
+        sys.stderr.write("WARNING: "+
+          subdir+" is in fingerprint but missing in working directory\n")
+
+  # special handling for top ghc repo
+  # if we are creating a new branch then also add an entry to the
+  # git config so the sync-all command is happy
+  branch_args = ["-b", branch_name] if branch_name else []
+  rc = subprocess.call(checkout + branch_args + [fp["."]])
+  if (rc == 0) and branch_name:
+    branch_config = "branch."+branch_name+".remote"
+    subprocess.call(["git", "config", "--add", branch_config, "origin"])
+
+actions = {"create" : create_action, "restore" : restore_action}
+def parseopts(argv):
+  """Parse and check the validity of the command line arguments"""
+  usage = "fingerprint ("+"|".join(sorted(actions.keys()))+") [options]"
+  parser = OptionParser(usage=usage)
+
+  parser.add_option("-d", "--dir", dest="dir",
+    help="write output to directory DIR", metavar="DIR")
+
+  parser.add_option("-o", "--output", dest="output",
+    help="write output to file FILE", metavar="FILE")
+
+  parser.add_option("-l", "--from-log", dest="logfile",
+    help="reconstruct fingerprint from build log", metavar="FILE")
+
+  parser.add_option("-f", "--from-fp", dest="fpfile",
+    help="reconstruct fingerprint from fingerprint file", metavar="FILE")
+
+  parser.add_option("-n", "--no-branch",
+    action="store_false", dest="branch", default=True,
+    help="do not create a new branch when restoring fingerprint")
+
+  parser.add_option("-g", "--ghc-dir", dest="ghcdir",
+    help="perform actions in GHC dir", metavar="DIR")
+
+  opts,args = parser.parse_args(argv)
+  return (validate(opts, args, parser), args)
+
+def validate(opts, args, parser):
+  """ Validate and prepare the command line options.
+
+  It performs the following actions:
+    * Check that we have a valid action to perform
+    * Check that we have a valid output destination
+    * Opens the output file if needed
+    * Opens the input  file if needed
+  """
+  # Determine the action
+  try:
+    opts.action = actions[args[0]]
+  except (IndexError, KeyError):
+    error("Must specify a valid action", parser)
+
+  # Inputs
+  if opts.logfile and opts.fpfile:
+    error("Must specify only one of -l and -f")
+
+  opts.source = None
+  if opts.logfile:
+    opts.source = file(opts.logfile, "r")
+  elif opts.fpfile:
+    opts.source = file(opts.fpfile, "r")
+
+  # Outputs
+  if opts.dir:
+    fname = opts.output
+    if fname is None:
+      fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp"
+    path = os.path.join(opts.dir, fname)
+    opts.output_file = path
+    opts.output = file(path, "w")
+  elif opts.output:
+    opts.output_file = opts.output
+    opts.output = file(opts.output_file, "w")
+  else:
+    opts.output_file = None
+    opts.output = sys.stdout
+
+  # GHC Directory
+  # As a last step change the directory to the GHC directory specified
+  if opts.ghcdir:
+    os.chdir(opts.ghcdir)
+
+  return opts
+
+def error(msg="fatal error", parser=None, exit=1):
+  """Function that prints error message and exits"""
+  print "ERROR:", msg
+  if parser:
+    parser.print_help()
+  sys.exit(exit)
+
+class MalformedFingerPrintError(Exception):
+  """Exception raised when parsing a bad fingerprint file"""
+  pass
+
+class FingerPrint:
+  """Class representing a fingerprint of all ghc git repos.
+
+  A finger print is represented by a dictionary that maps a
+  directory to a commit. The directory "." is used for the top
+  level ghc repository.
+  """
+  def __init__(self, subcommits = {}):
+    self.commits = subcommits
+
+  def __eq__(self, other):
+    if other.__class__ != self.__class__:
+      raise TypeError
+    return self.commits == other.commits
+
+  def __neq__(self, other):
+    not(self == other)
+
+  def __hash__(self):
+    return hash(str(self))
+
+  def __len__(self):
+    return len(self.commits)
+
+  def __repr__(self):
+    return "FingerPrint(" + repr(self.commits) + ")"
+
+  def __str__(self):
+    s = ""
+    for lib in sorted(self.commits.keys()):
+      commit = self.commits[lib]
+      s += "{0}|{1}\n".format(lib, commit)
+    return s
+
+  def __getitem__(self, item):
+    return self.commits[item]
+
+  def __iter__(self):
+    return self.commits.iteritems()
+
+  def write(self, outh):
+      outh.write(str(self))
+      outh.flush()
+
+  @staticmethod
+  def read(inh):
+    """Read a fingerprint from a fingerprint file"""
+    commits = {}
+    for line in inh.readlines():
+      splits = line.strip().split("|", 1)
+      if len(splits) != 2:
+        raise MalformedFingerPrintError(line)
+      lib, commit = splits
+      commits[lib] = commit
+    return FingerPrint(commits)
+
+if __name__ == "__main__":
+  main()
diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index df710d7..6f48c02 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -54,6 +54,7 @@ words :-
     <0>         "thats_all_folks"   { mkT TThatsAllFolks }
     <0>         [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
     <0>         [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+    <0>         [0-9][0-9]*         { mkTv (TInteger . read) }
     <0>         \" [^\"]* \"        { mkTv (TString . tail . init) }
     <in_braces> [^\{\}]+            { mkTv TNoBraces }
     <in_braces> \n                  { mkTv TNoBraces }
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 5b802bc..14f0834 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -46,13 +46,13 @@ main = getArgs >>= \args ->
                                        "commutable" 
                                        "commutableOp" p_o_specs)
 
-                      "--needs-wrapper" 
+                      "--code-size"
                          -> putStr (gen_switch_from_attribs 
-                                       "needs_wrapper" 
-                                       "primOpNeedsWrapper" p_o_specs)
+                                       "code_size"
+                                       "primOpCodeSize" p_o_specs)
 
-                      "--can-fail" 
-                         -> putStr (gen_switch_from_attribs 
+                      "--can-fail"
+                         -> putStr (gen_switch_from_attribs
                                        "can_fail" 
                                        "primOpCanFail" p_o_specs)
 
@@ -91,7 +91,7 @@ known_args
        "--has-side-effects",
        "--out-of-line",
        "--commutable",
-       "--needs-wrapper",
+       "--code-size",
        "--can-fail",
        "--strictness",
        "--primop-primop-info",
@@ -141,6 +141,7 @@ gen_hs_source (Info defaults entries) =
      where opt (OptionFalse n)	  = n ++ " = False"
            opt (OptionTrue n)	  = n ++ " = True"
 	   opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+           opt (OptionInteger n v) = n ++ " = " ++ show v
 
 	   hdr s@(Section {})			 = sec s
 	   hdr (PrimOpSpec { name = n })	 = wrapOp n ++ ","
@@ -409,7 +410,8 @@ gen_latex_doc (Info defaults entries)
 	       Just (OptionTrue _) -> if_true
 	       Just (OptionFalse _) -> if_false
 	       Just (OptionString _ _) -> error "String value for boolean option"
-	       Nothing -> ""
+               Just (OptionInteger _ _) -> error "Integer value for boolean option"
+               Nothing -> ""
 	   
 	   mk_strictness o = 
 	     case lookup_attrib "strictness" o of
@@ -550,6 +552,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
 
          getAltRhs (OptionFalse _)    = "False"
          getAltRhs (OptionTrue _)     = "True"
+         getAltRhs (OptionInteger _ i) = show i
          getAltRhs (OptionString _ s) = s
 
          mkAlt po
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index b20414d..5773abb 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -48,6 +48,7 @@ import Syntax
     lowerName       { TLowerName $$ }
     upperName       { TUpperName $$ }
     string          { TString $$ }
+    integer         { TInteger $$ }
     noBraces        { TNoBraces $$ }
 
 %%
@@ -66,6 +67,7 @@ pOption :: { Option }
 pOption : lowerName '=' false               { OptionFalse  $1 }
         | lowerName '=' true                { OptionTrue   $1 }
         | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+        | lowerName '=' integer             { OptionInteger $1 $3 }
 
 pEntries :: { [Entry] }
 pEntries : pEntry pEntries { $1 : $2 }
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index edc300d..a2b39d7 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -81,6 +81,7 @@ data Token = TEOF
            | TUpperName String
            | TString String
            | TNoBraces String
+           | TInteger Int
     deriving Show
 
 -- Actions
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
index 8094670..5fe4e0b 100644
--- a/utils/genprimopcode/Syntax.hs
+++ b/utils/genprimopcode/Syntax.hs
@@ -40,6 +40,7 @@ data Option
    = OptionFalse  String          -- name = False
    | OptionTrue   String          -- name = True
    | OptionString String String   -- name = { ... unparsed stuff ... }
+   | OptionInteger String Int     -- name = <int>
      deriving Show
 
 -- categorises primops
@@ -120,6 +121,7 @@ get_attrib_name :: Option -> String
 get_attrib_name (OptionFalse nm) = nm
 get_attrib_name (OptionTrue nm)  = nm
 get_attrib_name (OptionString nm _) = nm
+get_attrib_name (OptionInteger nm _) = nm
 
 lookup_attrib :: String -> [Option] -> Maybe Option
 lookup_attrib _ [] = Nothing
diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs
index d64c224..75d1faf 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -296,7 +296,7 @@ generate config_args distdir directory
                                          pd lib lbi clbi
                   final_ipi = installedPkgInfo {
                                   Installed.installedPackageId = ipid,
-                                  Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
+                                  Installed.haddockHTMLs = []
                               }
                   content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
               writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 1cec56a..4e6b531 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -19,7 +19,8 @@ import Distribution.ParseUtils
 import Distribution.Package hiding (depends)
 import Distribution.Text
 import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
 import System.Cmd       ( rawSystem )
 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
                           getModificationTime )
@@ -34,7 +35,8 @@ import Data.Maybe
 import Data.Char ( isSpace, toLower )
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
-                          doesFileExist, renameFile, removeFile )
+                          doesFileExist, renameFile, removeFile,
+                          getCurrentDirectory )
 import System.Exit ( exitWith, ExitCode(..) )
 import System.Environment ( getArgs, getProgName, getEnv )
 import System.IO
@@ -101,6 +103,9 @@ data Flag
   | FlagForce
   | FlagForceFiles
   | FlagAutoGHCiLibs
+  | FlagExpandEnvVars
+  | FlagExpandPkgroot
+  | FlagNoExpandPkgroot
   | FlagSimpleOutput
   | FlagNamesOnly
   | FlagIgnoreCase
@@ -126,6 +131,12 @@ flags = [
          "ignore missing directories and libraries only",
   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
         "automatically build libs for GHCi (with register)",
+  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+        "expand environment variables (${name}-style) in input package descriptions",
+  Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+        "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+  Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+        "preserve ${pkgroot}-relative paths in output package descriptions",
   Option ['?'] ["help"] (NoArg FlagHelp)
         "display this help and exit",
   Option ['V'] ["version"] (NoArg FlagVersion)
@@ -274,6 +285,12 @@ runit verbosity cli nonopts = do
           | FlagForceFiles `elem` cli   = ForceFiles
           | otherwise                   = NoForce
         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+        expand_env_vars= FlagExpandEnvVars `elem` cli
+        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
+                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+                accumExpandPkgroot x _                   = x
+                
         splitFields fields = unfoldr splitComma (',':fields)
           where splitComma "" = Nothing
                 splitComma fs = Just $ break (==',') (tail fs)
@@ -313,9 +330,11 @@ runit verbosity cli nonopts = do
     ["init", filename] ->
         initPackageDB filename verbosity cli
     ["register", filename] ->
-        registerPackage filename verbosity cli auto_ghci_libs False force
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars False force
     ["update", filename] ->
-        registerPackage filename verbosity cli auto_ghci_libs True force
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars True force
     ["unregister", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         unregisterPackage pkgid verbosity cli force
@@ -340,23 +359,24 @@ runit verbosity cli nonopts = do
     ["latest", pkgid_str] -> do
         pkgid <- readGlobPkgId pkgid_str
         latestPackage verbosity cli pkgid
-    ["describe", pkgid_str] ->
-        case substringCheck pkgid_str of
-          Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        describePackage verbosity cli (Id pkgid)
-          Just m -> describePackage verbosity cli (Substring pkgid_str m)
-    ["field", pkgid_str, fields] ->
-        case substringCheck pkgid_str of
-          Nothing -> do pkgid <- readGlobPkgId pkgid_str
-                        describeField verbosity cli (Id pkgid) 
-                                      (splitFields fields)
-          Just m -> describeField verbosity cli (Substring pkgid_str m)
-                                      (splitFields fields)
+    ["describe", pkgid_str] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+        
+    ["field", pkgid_str, fields] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describeField verbosity cli pkgarg
+                      (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
     ["check"] -> do
         checkConsistency verbosity cli
 
     ["dump"] -> do
-        dumpPackages verbosity cli
+        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
 
     ["recache"] -> do
         recache verbosity cli
@@ -402,8 +422,16 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
 --      list, describe, field
 
 data PackageDB 
-  = PackageDB { location :: FilePath,
-                packages :: [InstalledPackageInfo] }
+  = PackageDB {
+      location, locationAbsolute :: !FilePath,
+      -- We need both possibly-relative and definately-absolute package
+      -- db locations. This is because the relative location is used as
+      -- an identifier for the db, so it is important we do not modify it.
+      -- On the other hand we need the absolute path in a few places
+      -- particularly in relation to the ${pkgroot} stuff.
+      
+      packages :: [InstalledPackageInfo]
+    }
 
 type PackageDBStack = [PackageDB]
         -- A stack of package databases.  Convention: head is the topmost
@@ -415,6 +443,7 @@ allPackagesInStack = concatMap packages
 getPkgDatabases :: Verbosity
                 -> Bool    -- we are modifying, not reading
                 -> Bool    -- read caches, if available
+                -> Bool    -- expand vars, like ${pkgroot} and $topdir
                 -> [Flag]
                 -> IO (PackageDBStack, 
                           -- the real package DB stack: [global,user] ++ 
@@ -427,7 +456,7 @@ getPkgDatabases :: Verbosity
                           -- is used as the list of package DBs for
                           -- commands that just read the DB, such as 'list'.
 
-getPkgDatabases verbosity modify use_cache my_flags = do
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
   -- first we determine the location of the global package config.  On Windows,
   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
   -- location is passed to the binary using the --global-config flag by the
@@ -445,6 +474,12 @@ getPkgDatabases verbosity modify use_cache my_flags = do
                        Just path -> return path
         fs -> return (last fs)
 
+  -- The value of the $topdir variable used in some package descriptions
+  -- Note that the way we calculate this is slightly different to how it
+  -- is done in ghc itself. We rely on the convention that the global
+  -- package db lives in ghc's libdir.
+  top_dir <- absolutePath (takeDirectory global_conf)
+
   let no_user_db = FlagNoUserDb `elem` my_flags
 
   -- get the location of the user package database, and create it if necessary
@@ -513,7 +548,11 @@ getPkgDatabases verbosity modify use_cache my_flags = do
         | null db_flags = Just virt_global_conf
         | otherwise     = Just (last db_flags)
 
-  db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+  db_stack  <- sequence
+    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+         if expand_vars then return (mungePackageDBPaths top_dir db)
+                        else return db
+    | db_path <- final_stack ]
 
   let flag_db_stack = [ db | db_name <- flag_db_names,
                         db <- db_stack, location db == db_name ]
@@ -539,13 +578,13 @@ readParseDatabase :: Verbosity
 readParseDatabase verbosity mb_user_conf use_cache path
   -- the user database (only) is allowed to be non-existent
   | Just (user_conf,False) <- mb_user_conf, path == user_conf
-  = return PackageDB { location = path, packages = [] }
+  = mkPackageDB []
   | otherwise
   = do e <- tryIO $ getDirectoryContents path
        case e of
          Left _   -> do
               pkgs <- parseMultiPackageConf verbosity path
-              return PackageDB{ location = path, packages = pkgs }              
+              mkPackageDB pkgs
          Right fs
            | not use_cache -> ignore_cache
            | otherwise -> do
@@ -563,7 +602,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
                         putStrLn ("using cache: " ++ cache)
                      pkgs <- myReadBinPackageDB cache
                      let pkgs' = map convertPackageInfoIn pkgs
-                     return PackageDB { location = path, packages = pkgs' }
+                     mkPackageDB pkgs'
                   | otherwise -> do
                      when (verbosity >= Normal) $ do
                         warn ("WARNING: cache is out of date: " ++ cache)
@@ -574,7 +613,15 @@ readParseDatabase verbosity mb_user_conf use_cache path
                      let confs = filter (".conf" `isSuffixOf`) fs
                      pkgs <- mapM (parseSingletonPackageConf verbosity) $
                                    map (path </>) confs
-                     return PackageDB { location = path, packages = pkgs }
+                     mkPackageDB pkgs
+  where
+    mkPackageDB pkgs = do
+      path_abs <- absolutePath path
+      return PackageDB {
+        location = path,
+        locationAbsolute = path_abs,
+        packages = pkgs
+      }
 
 -- read the package.cache file strictly, to work around a problem with
 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
@@ -600,11 +647,69 @@ parseMultiPackageConf verbosity file = do
 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 parseSingletonPackageConf verbosity file = do
   when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
-  readUTF8File file >>= parsePackageInfo
+  readUTF8File file >>= fmap fst . parsePackageInfo
 
 cachefilename :: FilePath
 cachefilename = "package.cache"
 
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+  where
+    pkgroot = takeDirectory (locationAbsolute db)    
+    -- It so happens that for both styles of package db ("package.conf"
+    -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+    -- ${pkgroot}/package.conf  or  ${pkgroot}/package.conf.d/
+
+mungePackagePaths :: FilePath -> FilePath
+                  -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+    pkg {
+      importDirs  = munge_paths (importDirs pkg),
+      includeDirs = munge_paths (includeDirs pkg),
+      libraryDirs = munge_paths (libraryDirs pkg),
+      frameworkDirs = munge_paths (frameworkDirs pkg),
+      haddockInterfaces = munge_paths (haddockInterfaces pkg),
+      haddockHTMLs = munge_urls (haddockHTMLs pkg)
+    }
+  where
+    munge_paths = map munge_path
+    munge_urls  = map munge_url
+
+    munge_path p
+      | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+      | Just p' <- stripVarPrefix "$topdir"    sp = top_dir </> p'
+      | otherwise                                 = p
+      where
+        sp = splitPath p
+
+    munge_url p
+      | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+      | Just p' <- stripVarPrefix "$httptopdir"   sp = toUrlPath top_dir p'
+      | otherwise                                    = p
+      where
+        sp = splitPath p
+
+    toUrlPath r p = "file:///"
+                 -- URLs always use posix style '/' separators:
+                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+    stripVarPrefix var (root:path')
+      | Just [sep] <- stripPrefix var root
+      , isPathSeparator sep
+      = Just (joinPath path')
+
+    stripVarPrefix _ _ = Nothing
+
+
 -- -----------------------------------------------------------------------------
 -- Creating a new package DB
 
@@ -615,7 +720,11 @@ initPackageDB filename verbosity _flags = do
   when b1 eexist
   b2 <- doesDirectoryExist filename
   when b2 eexist
-  changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+  filename_abs <- absolutePath filename
+  changeDB verbosity [] PackageDB {
+                          location = filename, locationAbsolute = filename_abs,
+                          packages = []
+                        }
 
 -- -----------------------------------------------------------------------------
 -- Registering
@@ -624,17 +733,21 @@ registerPackage :: FilePath
                 -> Verbosity
                 -> [Flag]
                 -> Bool              -- auto_ghci_libs
+                -> Bool              -- expand_env_vars
                 -> Bool              -- update
                 -> Force
                 -> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
   (db_stack, Just to_modify, _flag_dbs) <- 
-      getPkgDatabases verbosity True True my_flags
+      getPkgDatabases verbosity True True False{-expand vars-} my_flags
 
   let
         db_to_operate_on = my_head "register" $
                            filter ((== to_modify).location) db_stack
   --
+  when (auto_ghci_libs && verbosity >= Silent) $
+    warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+  --
   s <-
     case input of
       "-" -> do
@@ -648,16 +761,26 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
             putStr ("Reading package info from " ++ show f ++ " ... ")
         readUTF8File f
 
-  expanded <- expandEnvVars s force
+  expanded <- if expand_env_vars then expandEnvVars s force
+                                 else return s
 
-  pkg <- parsePackageInfo expanded
+  (pkg, ws) <- parsePackageInfo expanded
   when (verbosity >= Normal) $
       putStrLn "done."
 
+  -- report any warnings from the parse phase
+  _ <- reportValidateErrors [] ws
+         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+  -- validate the expanded pkg, but register the unexpanded
+  pkgroot <- absolutePath (takeDirectory to_modify)
+  let top_dir = takeDirectory (location (last db_stack))
+      pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
   let truncated_stack = dropWhile ((/= to_modify).location) db_stack
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
-  validatePackageConfig pkg truncated_stack auto_ghci_libs update force
+  validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
   let 
      removes = [ RemovePackage p
                | p <- packages db_to_operate_on,
@@ -667,10 +790,13 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do
 
 parsePackageInfo
         :: String
-        -> IO InstalledPackageInfo
+        -> IO (InstalledPackageInfo, [ValidateWarning])
 parsePackageInfo str =
   case parseInstalledPackageInfo str of
-    ParseOk _warns ok -> return ok
+    ParseOk warnings ok -> return (ok, ws)
+      where
+        ws = [ msg | PWarning msg <- warnings
+                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
     ParseFailed err -> case locatedErrorMsg err of
                            (Nothing, s) -> die s
                            (Just l, s) -> die (show l ++ ": " ++ s)
@@ -750,7 +876,7 @@ modifyPackage
   -> IO ()
 modifyPackage fn pkgid verbosity my_flags force = do
   (db_stack, Just _to_modify, _flag_dbs) <- 
-      getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
+      getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
 
   (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
   let 
@@ -778,7 +904,7 @@ modifyPackage fn pkgid verbosity my_flags force = do
 recache :: Verbosity -> [Flag] -> IO ()
 recache verbosity my_flags = do
   (db_stack, Just to_modify, _flag_dbs) <- 
-     getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
+     getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
   let
         db_to_operate_on = my_head "recache" $
                            filter ((== to_modify).location) db_stack
@@ -794,7 +920,7 @@ listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
 listPackages verbosity my_flags mPackageName mModuleName = do
   let simple_output = FlagSimpleOutput `elem` my_flags
   (db_stack, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
 
   let db_stack_filtered -- if a package is given, filter out all other packages
         | Just this <- mPackageName =
@@ -887,7 +1013,7 @@ simplePackageList my_flags pkgs = do
 showPackageDot :: Verbosity -> [Flag] -> IO ()
 showPackageDot verbosity myflags = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} myflags
+      getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
 
   let all_pkgs = allPackagesInStack flag_db_stack
       ipix  = PackageIndex.fromList all_pkgs
@@ -909,7 +1035,7 @@ showPackageDot verbosity myflags = do
 latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
 latestPackage verbosity my_flags pkgid = do
   (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
 
   ps <- findPackages flag_db_stack (Id pkgid)
   show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
@@ -920,24 +1046,33 @@ latestPackage verbosity my_flags pkgid = do
 -- -----------------------------------------------------------------------------
 -- Describe
 
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} my_flags
-  ps <- findPackages flag_db_stack pkgarg
-  doDump ps
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  dbs <- findPackagesByDB flag_db_stack pkgarg
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | (db, pkgs) <- dbs, pkg <- pkgs ]
 
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-     getPkgDatabases verbosity False True{-use cache-} my_flags
-  doDump (allPackagesInStack flag_db_stack)
+     getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | db <- flag_db_stack, pkg <- packages db ]
 
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
   -- fix the encoding to UTF-8, since this is an interchange format
   hSetEncoding stdout utf8
-  mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+  putStrLn $
+    intercalate "---\n"
+    [ if expand_pkgroot
+        then showInstalledPackageInfo pkg
+        else showInstalledPackageInfo pkg ++ pkgrootField
+    | (pkg, pkgloc) <- pkgs
+    , let pkgroot      = takeDirectory pkgloc
+          pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
 
 -- PackageId is can have globVersion for the version
 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
@@ -976,14 +1111,13 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 -- -----------------------------------------------------------------------------
 -- Field
 
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
   (_, _, flag_db_stack) <- 
-      getPkgDatabases verbosity False True{-use cache-} my_flags
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
   fns <- toFields fields
   ps <- findPackages flag_db_stack pkgarg
-  let top_dir = takeDirectory (location (last flag_db_stack))
-  mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+  mapM_ (selectFields fns) ps
   where toFields [] = return []
         toFields (f:fs) = case toField f of
             Nothing -> die ("unknown field: " ++ f)
@@ -991,35 +1125,6 @@ describeField verbosity my_flags pkgarg fields = do
                           return (fn:fns)
         selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
 
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
-  where
-  munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
-                   includeDirs       = munge_paths (includeDirs p),
-                   libraryDirs       = munge_paths (libraryDirs p),
-                   frameworkDirs     = munge_paths (frameworkDirs p),
-                   haddockInterfaces = munge_paths (haddockInterfaces p),
-                   haddockHTMLs      = munge_paths (haddockHTMLs p)
-                 }
-
-  munge_paths = map munge_path
-
-  munge_path p
-   | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
-   | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
-   | otherwise                               = p
-
-  toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch []    rest = Just rest
-maybePrefixMatch (_:_) []   = Nothing
-maybePrefixMatch (p:pat) (r:rest)
-  | p == r    = maybePrefixMatch pat rest
-  | otherwise = Nothing
-
 toField :: String -> Maybe (InstalledPackageInfo -> String)
 -- backwards compatibility:
 toField "import_dirs"     = Just $ strList . importDirs
@@ -1045,7 +1150,8 @@ strList = show
 
 checkConsistency :: Verbosity -> [Flag] -> IO ()
 checkConsistency verbosity my_flags = do
-  (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
+  (db_stack, _, _) <- 
+         getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
          -- check behaves like modify for the purposes of deciding which
          -- databases to use, because ordering is important.
 
@@ -1218,6 +1324,9 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do
   mapM_ (checkDir False "import-dirs")  (importDirs pkg)
   mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
   mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
+  mapM_ (checkDir True  "framework-dirs") (frameworkDirs pkg)
+  mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
+  mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
   checkModules pkg
   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
   -- ToDo: check these somehow?
@@ -1269,19 +1378,34 @@ checkDuplicates db_stack pkg update = do
         "Package " ++ display pkgid ++
         " overlaps with: " ++ unwords (map display dups)
 
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir  = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://"  `isPrefixOf` d
+           || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+   -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+   -- variables having been expanded already, see mungePackagePaths.
 
-checkDir :: Bool -> String -> String -> Validate ()
-checkDir warn_only thisfield d
- | "$topdir"     `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
-        -- can't check these, because we don't know what $(http)topdir is
  | isRelative d = verror ForceFiles $
-                     thisfield ++ ": " ++ d ++ " is a relative path"
+                     thisfield ++ ": " ++ d ++ " is a relative path which "
+                  ++ "makes no sense (as there is nothing for it to be "
+                  ++ "relative to). You can make paths relative to the "
+                  ++ "package database itself by using ${pkgroot}."
         -- relative paths don't make any sense; #4134
  | otherwise = do
-   there <- liftIO $ doesDirectoryExist d
+   there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
    when (not there) $
-       let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
+       let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+                                        ++ if is_dir then "directory" else "file"
        in
        if warn_only 
           then vwarn msg
@@ -1320,10 +1444,7 @@ doesFileExistOnPath file path = go path
                        if b then return (Just p) else go ps
 
 doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir"     `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise                = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
 
 checkModules :: InstalledPackageInfo -> Validate ()
 checkModules pkg = do
@@ -1416,6 +1537,8 @@ expandEnvVars str0 force = go str0 ""
         = go str (c:acc)
 
    lookupEnvVar :: String -> IO String
+   lookupEnvVar "pkgroot"    = return "${pkgroot}"    -- these two are special,
+   lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
    lookupEnvVar nm =
         catchIO (System.Environment.getEnv nm)
            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
@@ -1487,16 +1610,17 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
-getExecPath =
-     allocaArray len $ \buf -> do
-         ret <- getModuleFileName nullPtr buf len
-         if ret == 0 then return Nothing
-	             else liftM Just $ peekCString buf
-    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
-    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap Just $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getLibDir :: IO (Maybe String)
 getLibDir = return Nothing
@@ -1628,3 +1752,6 @@ removeFileSafe :: FilePath -> IO ()
 removeFileSafe fn =
   removeFile fn `catchIO` \ e ->
     when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index b3ed58f..c86a92a 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -293,7 +293,6 @@ boundThings modname lbinding =
                LitPat _ -> tl
                NPat _ _ _ -> tl -- form of literal pattern?
                NPlusKPat id _ _ _ -> thing id : tl
-               TypePat _ -> tl -- XXX need help here
                SigPatIn p _ -> patThings p tl
                SigPatOut p _ -> patThings p tl
                _ -> error "boundThings"
diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index ab49513..4424c96 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -149,15 +149,17 @@ dieProg msg = do
 
 getExecPath :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
-getExecPath =
-     allocaArray len $ \buf -> do
-         ret <- getModuleFileName nullPtr buf len
-         if ret == 0 then return Nothing
-                     else liftM Just $ peekCString buf
-    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
-    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap Just $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getExecPath = return Nothing
 #endif
diff --git a/validate b/validate
index b1ae14f..3ca888f 100755
--- a/validate
+++ b/validate
@@ -86,6 +86,21 @@ $make -j$threads ValidateHpc=$hpc ValidateSlow=$slow
 $make binary-dist-prep
 $make test_bindist TEST_PREP=YES
 
+#
+# Install the mtl package into the bindist, because it is used by some
+# tests.  It isn't essential that we do this (the failing tests will
+# be treated as expected failures), but we get a bit more test
+# coverage, and also verify that we can install a package into the
+# bindist with Cabal.
+#
+bindistdir="bindisttest/install dir"
+cd libraries/mtl
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir"
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build  --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install  --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean  --builddir=dist-bindist
+cd $thisdir
+
 fi # testsuite-only
 
 if [ "$hpc" = YES ]