X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=e20bc833c7fe8289846b708384c3937d335b7594;hb=c3fe0f3699fa59261a340686bba648c981b3511d;hp=f5a5a268f15898bbcbd9da5cdfae57b6f3dfc76e;hpb=2e06595241350a6548b6ab6430c65d6458f7c197;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index f5a5a26..e20bc83 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -358,7 +358,8 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do
 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 the expression, so that it can itself be floated.
 
-[NOTE: unlifted MFEs]
+Note [Unlifted MFEs]
+~~~~~~~~~~~~~~~~~~~~~
 We don't float unlifted MFEs, which potentially loses big opportunites.
 For example:
 	\x -> f (h y)
@@ -375,9 +376,16 @@ lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 lvlMFE _ _ _ (_, AnnType ty)
   = return (Type ty)
 
+-- No point in floating out an expression wrapped in a coercion;
+-- If we do we'll transform  lvl = e |> co 
+--			 to  lvl' = e; lvl = lvl' |> co
+-- and then inline lvl.  Better just to float out the payload.
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+  = do	{ expr' <- lvlMFE strict_ctxt ctxt_lvl env e
+	; return (Cast expr' co) }
 
 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]
   || isInlineCtxt ctxt_lvl		-- Don't float out of an __inline__ context
   || exprIsTrivial expr			-- Never float if it's trivial
   || not good_destination
@@ -481,7 +489,9 @@ lvlBind :: TopLevelFlag		-- Used solely to decide whether to clone
 	-> LvlM (LevelledBind, LevelEnv)
 
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-  | isInlineCtxt ctxt_lvl		-- Don't do anything inside InlineMe
+  |  isTyVar bndr 		-- Don't do anything for TyVar binders
+				--   (simplifier gets rid of them pronto)
+  || isInlineCtxt ctxt_lvl	-- Don't do anything inside InlineMe
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)