From: simonpj@microsoft.com <unknown>
Date: Wed, 9 May 2007 15:44:47 +0000 (+0000)
Subject: Two more small bugs in abstractFloats
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=42a2b2ae9c5059bad52db63c73bef266e2255517

Two more small bugs in abstractFloats
---

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:
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 5b8f304..d97249f 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -331,7 +331,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 
 		else  				-- Do type-abstraction first
 		     do	{ tick LetFloatFromLet
-			; (poly_binds, body3) <- abstractFloats tvs body_env2 body2
+			; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
 			; rhs' <- mkLam tvs' body3
 			; return (extendFloats env poly_binds, rhs') }