From: simonpj <unknown>
Date: Tue, 11 Dec 2001 17:51:33 +0000 (+0000)
Subject: [project @ 2001-12-11 17:51:33 by simonpj]
X-Git-Tag: Approximately_9120_patches~414
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=da70405e8fdbb3c93103487099209404b2f5931c;p=ghc-hetmet.git

[project @ 2001-12-11 17:51:33 by simonpj]
More inline/floating fixes; sigh
---

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index 6552bdd..d81c3b9 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -256,7 +256,8 @@ floatExpr env lvl (Note note@(SCC cc) expr)
 
 floatExpr env lvl (Note InlineMe expr)	-- Other than SCCs
   = case floatExpr env InlineCtxt expr of { (fs, floating_defns, expr') ->
-    ASSERT( null floating_defns )	-- We do no floating out of Inlines
+    WARN( not (null floating_defns),
+	  ppr expr $$ ppr floating_defns )	-- We do no floating out of Inlines
     (fs, [], Note InlineMe expr') }	-- See notes in SetLevels
 
 floatExpr env lvl (Note note expr)	-- Other than SCCs
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 0e8506c..a9d5ed2 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -325,7 +325,8 @@ collect_binders lam
   = go [] lam
   where
     go rev_bndrs (_, AnnLam b e)  = go (b:rev_bndrs) e
-    go rev_bndrs (_, AnnNote n e) = go rev_bndrs e
+-- TEMP FIX
+--    go rev_bndrs (_, AnnNote n e) = go rev_bndrs e
     go rev_bndrs rhs		  = (reverse rev_bndrs, rhs)
 	-- Ignore notes, because we don't want to split
 	-- a lambda like this (\x -> coerce t (\s -> ...))
@@ -351,12 +352,13 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
   = returnLvl (Type ty)
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
-  |  isUnLiftedType ty				-- Can't let-bind it
+  |  isUnLiftedType ty			-- Can't let-bind it
+  || isInlineCtxt ctxt_lvl		-- Don't float out of an __inline__ context
   || not good_destination
-  || exprIsTrivial expr				-- Is trivial
-  || (strict_ctxt && exprIsBottom expr)		-- Strict context and is bottom
-						--  e.g. \x -> error "foo"
-						-- No gain from floating this
+  || exprIsTrivial expr			-- Is trivial
+  || (strict_ctxt && exprIsBottom expr)	-- Strict context and is bottom
+					--  e.g. \x -> error "foo"
+					-- No gain from floating this
   = 	-- Don't float it out
     lvlExpr ctxt_lvl env ann_expr
 
@@ -373,16 +375,11 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
 
     good_destination =  dest_lvl `ltMajLvl` ctxt_lvl	-- Escapes a value lambda
 		     || (isTopLvl dest_lvl		-- Goes to the top
-			 && not (isInlineCtxt ctxt_lvl)	-- Don't float out of an __inline__ context
 			 && not strict_ctxt)		--   or from a strict context	
 	-- A decision to float entails let-binding this thing, and we only do 
 	-- that if we'll escape a value lambda, or will go to the top level.
-	-- But beware (a):
-	--	x = __inline__ (f (g y))
-	-- Here we don't want to float the (g y); otherwise it'll get outside the
-	--  	__inline__ envelope, and may never get inlined
 	--
-	-- Also beware (b):
+	-- Beware:
 	--	concat = /\ a -> foldr ..a.. (++) []
 	-- was getting turned into
 	--	concat = /\ a -> lvl a