X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=1399870903ffc4aa2f1074cd86c664b11f600d81;hb=970d5b88b1554bbdd7e459dae41aab3668ae897a;hp=8acf9134e3f8fadb47012a978ba5bc8ac84d3cac;hpb=65b5fb0ff8dd2af5c8bed6db5f059b4f60eb05de;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 8acf913..1399870 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -39,6 +39,7 @@ import CoreUnfold
 import MkId
 import Name
 import Id
+import Var	( isCoVar )
 import NewDemand
 import SimplMonad
 import Type
@@ -1041,8 +1042,11 @@ abstractFloats main_tvs body_env body
 		 subst'   = CoreSubst.extendIdSubst subst id poly_app
 	   ; return (subst', (NonRec poly_id poly_rhs)) }
       where
-	rhs'     = CoreSubst.substExpr subst rhs
-	tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+	rhs' = CoreSubst.substExpr subst rhs
+	tvs_here | any isCoVar main_tvs = main_tvs	-- Note [Abstract over coercions]
+		 | otherwise 
+		 = 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
 		-- approach of abstract wrt the tyvars free in the Id's type
@@ -1101,6 +1105,13 @@ abstractFloats main_tvs body_env body
 		-- pinned on x.
 \end{code}
 
+Note [Abstract over coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
+type variable a.  Rather than sort this mess out, we simply bale out and abstract
+wrt all the type variables if any of them are coercion variables.
+
+
 Historical note: if you use let-bindings instead of a substitution, beware of this:
 
 		-- Suppose we start with: