X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=21dca615c3a1d230bfde2c8ff1b0c9e2534f94d6;hp=6871faa79832aa66a7b3c801952575e88e8ef7b8;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=a0f0420865b17ed5f701b98e14c5d802dab6418f

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