From e2cf518a3dcccdddd609188ddba6fb121c2e25fe Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 7 Jan 2008 14:26:01 +0000
Subject: [PATCH] Fix Trac #2018: float-out was ignoring the kind of a
 coercion variable

The float-out transformation must handle the case where a coercion
variable is free, which in turn mentions type variables in its kind.
Just like a term variable really.

I did a bit of refactoring at the same time.

Test is tc241

MERGE to stable branch
---
 compiler/simplCore/SetLevels.lhs |   41 ++++++++++++++++++++------------------
 1 file changed, 22 insertions(+), 19 deletions(-)

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 043b036..705d545 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -72,7 +72,7 @@ import Id		( Id, idType, mkSysLocal, isOneShotLambda,
 			  idSpecialisation, idWorkerInfo, setIdInfo
 			)
 import IdInfo		( workerExists, vanillaIdInfo, isEmptySpecInfo )
-import Var		( Var )
+import Var
 import VarSet
 import VarEnv
 import Name		( getOccName )
@@ -772,38 +772,41 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
 	-- Find the variables in fvs, free vars of the target expresion,
 	-- whose level is greater than the destination level
 	-- These are the ones we are going to abstract out
-abstractVars dest_lvl env fvs
-  = uniq (sortLe le [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
+abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
+  = uniq (sortLe le [var | fv <- varSetElems fvs
+			 , var <- absVarsOf id_env fv
+			 , abstract_me var])
   where
-	-- Sort the variables so we don't get 
-	-- mixed-up tyvars and Ids; it's just messy
-    v1 `le` v2 = case (isId v1, isId v2) of
-		   (True, False) -> False
-		   (False, True) -> True
+	-- Sort the variables so the true type variables come first;
+	-- the tyvars scope over Ids and coercion vars
+    v1 `le` v2 = case (is_tv v1, is_tv v2) of
+		   (True, False) -> True
+		   (False, True) -> False
 		   other	 -> v1 <= v2	-- Same family
 
+    is_tv v = isTyVar v && not (isCoVar v)
+
     uniq :: [Var] -> [Var]
 	-- Remove adjacent duplicates; the sort will have brought them together
     uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
 		    | otherwise = v1 : uniq (v2:vs)
     uniq vs = vs
 
-absVarsOf :: Level -> LevelEnv -> Var -> [Var]
+    abstract_me v = case lookupVarEnv lvl_env v of
+			Just lvl -> dest_lvl `ltLvl` lvl
+			Nothing  -> False
+
+absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var]
 	-- If f is free in the expression, and f maps to poly_f a b c in the
 	-- current substitution, then we must report a b c as candidate type
 	-- variables
-absVarsOf dest_lvl (_, lvl_env, _, id_env) v 
-  | isId v
-  = [zap av2 | av1 <- lookup_avs v, av2 <- add_tyvars av1, abstract_me av2]
-
-  | otherwise
-  = if abstract_me v then [v] else []
+absVarsOf id_env v 
+  | isId v    = [zap av2 | av1 <- lookup_avs v
+			 , av2 <- add_tyvars av1]
+  | isCoVar v = add_tyvars v
+  | otherwise = [v]
 
   where
-    abstract_me v = case lookupVarEnv lvl_env v of
-			Just lvl -> dest_lvl `ltLvl` lvl
-			Nothing  -> False
-
     lookup_avs v = case lookupVarEnv id_env v of
 			Just (abs_vars, _) -> abs_vars
 			Nothing	           -> [v]
-- 
1.7.10.4