From 6d4932994d5a99d0ec7ea707e213b68328fa68a6 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 23 Sep 2003 15:29:02 +0000
Subject: [PATCH] [project @ 2003-09-23 15:29:02 by simonpj]
 --------------------------          Much grunting about
 let-floating 	   --------------------------

We want to avoid putting bindings between the '=' of a defn and a '\':
	let { f = let ... in \y-> ... } in ...

Reason: float-in often follows float-out, and it may then add yte
more bindings there, some of which may be strict.  But f may by
not be marked as not-demanded (for other reasons: see the call to
zapDemandInfo in Simplify.completeLazyBind); and now the strict binding
may not be able to float out again.  (Well, it triggers the ASSERT in
simplLazyBind.)

So this commit adds FloatOut.floatNonRecRhs (to complement floatRhs) which
is a big more vigorous about floating out.

But that in turn showed up a pile of gore to do with unlifted bindings.
We can't have them showing up at top level.  After thrashing in the swamp
for a while, I eventually arranged that
	let x# = e in b
(where x# has an unlifted type) is treated exactly like
	case e of x# -> b
That is, it is never floated.  Yes, we lose opportunities to float some
(very cheap!  unlifted let-bindings are always cheap) out of a lambda,
but we're missing much bigger opportunities already.  For example:
	\x -> f (h y)

where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed.  Possible solution: box it.
Anyway, that's for the future.
---
 ghc/compiler/simplCore/FloatOut.lhs  |   85 +++++++++++++++++++++-------------
 ghc/compiler/simplCore/SetLevels.lhs |   36 ++++++++++----
 2 files changed, 81 insertions(+), 40 deletions(-)

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index c598b4a..b756a63 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -11,12 +11,13 @@ module FloatOut ( floatOutwards ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( mkSCC )
+import CoreUtils	( mkSCC, exprIsValue, exprIsTrivial )
 
 import CmdLineOpts	( DynFlags, DynFlag(..), FloatOutSwitches(..) )
 import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
-import Id		( Id )
+import Id		( Id, idType )
+import Type		( isUnLiftedType )
 import CoreLint		( showPass, endPass )
 import SetLevels	( Level(..), LevelledExpr, LevelledBind,
 			  setLevels, ltMajLvl, ltLvl, isTopLvl )
@@ -99,8 +100,8 @@ vwhich might usefully be separated to
 Well, maybe.  We don't do this at the moment.
 
 \begin{code}
-type FloatBind     = (Level, CoreBind)
-type FloatBinds    = [FloatBind]
+type FloatBind     = (Level, CoreBind)	-- INVARIANT: a FloatBind is always lifted
+type FloatBinds    = [FloatBind]	
 \end{code}
 
 %************************************************************************
@@ -166,37 +167,36 @@ floatBind :: LevelledBind
 	  -> (FloatStats, FloatBinds, CoreBind)
 
 floatBind (NonRec (TB name level) rhs)
-  = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
+  = case (floatNonRecRhs level rhs) of { (fs, rhs_floats, rhs') ->
     (fs, rhs_floats, NonRec name rhs') }
 
 floatBind bind@(Rec pairs)
   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 
-    if not (isTopLvl bind_level) then
-	-- Standard case
+    if not (isTopLvl bind_dest_level) then
+	-- Standard case; the floated bindings can't mention the
+	-- binders, because they couldn't be escaping a major level
+	-- if so.
 	(sum_stats fss, concat rhss_floats, Rec new_pairs)
     else
 	-- In a recursive binding, *destined for* the top level
 	-- (only), the rhs floats may contain references to the 
 	-- bound things.  For example
-	--
 	--	f = ...(let v = ...f... in b) ...
-	--
 	--  might get floated to
-	--
 	--	v = ...f...
 	--	f = ... b ...
-	--
 	-- and hence we must (pessimistically) make all the floats recursive
 	-- with the top binding.  Later dependency analysis will unravel it.
 	--
-	-- Can't happen on nested bindings because floatRhs will dump
-	-- the bindings in the RHS (partitionByMajorLevel treats top specially)
+	-- This can only happen for bindings destined for the top level,
+	-- because only then will partitionByMajorLevel allow through a binding
+	-- that only differs in its minor level
 	(sum_stats fss, [],
 	 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)))
     }
   where
-    bind_level = getBindLevel bind
+    bind_dest_level = getBindLevel bind
 
     do_pair (TB name level, rhs)
       = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
@@ -211,22 +211,42 @@ floatBind bind@(Rec pairs)
 %************************************************************************
 
 \begin{code}
-floatExpr, floatRhs
+floatExpr, floatRhs, floatNonRecRhs
 	 :: Level
 	 -> LevelledExpr
 	 -> (FloatStats, FloatBinds, CoreExpr)
 
-floatRhs lvl arg
+floatRhs lvl arg	-- Used rec rhss, and case-alternative rhss
   = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
     case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
+	-- Dump bindings that aren't going to escape from a lambda;
+	-- in particular, we must dump the ones that are bound by 
+	-- the rec or case alternative
+    (fsa, floats', install heres arg') }}
+
+floatNonRecRhs lvl arg	-- Used for nested non-rec rhss, and fn args
+  = case (floatExpr lvl arg) of { (fsa, floats, arg') ->
 	-- Dump bindings that aren't going to escape from a lambda
-	-- This is to avoid floating the x binding out of
+	-- This isn't a scoping issue (the binder isn't in scope in the RHS of a non-rec binding)
+	-- Rather, it is to avoid floating the x binding out of
 	--	f (let x = e in b)
-	-- unnecessarily.  It even causes a bug to do so if we have
-	--	y = writeArr# a n (let x = e in b)
-	-- because the y binding is an expr-ok-for-speculation one.
-	-- [SLPJ Dec 01: I don't understand this last comment; 
-	--	   	 writeArr# is not ok-for-spec because of its side effect]
+	-- unnecessarily.  But we first test for values or trival rhss,
+	-- because (in particular) we don't want to insert new bindings between
+	-- the "=" and the "\".  E.g.
+	--	f = \x -> let <bind> in <body>
+	-- We do not want
+	--	f = let <bind> in \x -> <body>
+	-- (a) The simplifier will immediately float it further out, so we may
+	--	as well do so right now; in general, keeping rhss as manifest 
+	--	values is good
+	-- (b) If a float-in pass follows immediately, it might add yet more
+	--	bindings just after the '='.  And some of them might (correctly)
+	--	be strict even though the 'let f' is lazy, because f, being a value,
+	--	gets its demand-info zapped by the simplifier.
+    if exprIsValue arg' || exprIsTrivial arg' then
+	(fsa, floats, arg')
+    else
+    case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
     (fsa, floats', install heres arg') }}
 
 floatExpr _ (Var v)   = (zeroStats, [], Var v)
@@ -234,8 +254,8 @@ floatExpr _ (Type ty) = (zeroStats, [], Type ty)
 floatExpr _ (Lit lit) = (zeroStats, [], Lit lit)
 	  
 floatExpr lvl (App e a)
-  = case (floatExpr lvl e) of { (fse, floats_e, e') ->
-    case (floatRhs  lvl a) of { (fsa, floats_a, a') ->
+  = case (floatExpr      lvl e) of { (fse, floats_e, e') ->
+    case (floatNonRecRhs lvl a) of { (fsa, floats_a, a') ->
     (fse `add_stats` fsa, floats_e ++ floats_a, App e' a') }}
 
 floatExpr lvl lam@(Lam _ _)
@@ -295,17 +315,18 @@ floatExpr lvl (Note note expr)	-- Other than SCCs
   = case (floatExpr lvl expr)    of { (fs, floating_defns, expr') ->
     (fs, floating_defns, Note note expr') }
 
+floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
+  | isUnLiftedType (idType bndr)	-- Treat unlifted lets just like a case
+  = case floatExpr lvl rhs	of { (fs, rhs_floats, rhs') ->
+    case floatRhs bndr_lvl body of { (fs, body_floats, body') ->
+    (fs, rhs_floats ++ body_floats, Let (NonRec bndr rhs') body') }}
+
 floatExpr lvl (Let bind body)
   = case (floatBind bind)     of { (fsb, rhs_floats,  bind') ->
     case (floatExpr lvl body) of { (fse, body_floats, body') ->
---    if isInlineCtxt lvl then	-- No floating inside an InlineMe
---	ASSERT( null rhs_floats && null body_floats )
---	(add_stats fsb fse, [], Let bind' body')
---    else
-	(add_stats fsb fse,
-	 rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
-	 body')
-    }}
+    (add_stats fsb fse,
+     rhs_floats ++ [(bind_lvl, bind')] ++ body_floats,
+     body')  }}
   where
     bind_lvl = getBindLevel bind
 
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 647e22c..e4d9fc6 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -309,6 +309,23 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
 	-- but not nearly so much now non-recursive newtypes are transparent.
 	-- [See SetLevels rev 1.50 for a version with this approach.]
 
+lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body)
+  | isUnLiftedType (idType bndr)
+	-- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e)
+	-- That is, leave it exactly where it is
+	-- We used to float unlifted bindings too (e.g. to get a cheap primop
+	-- outside a lambda (to see how, look at lvlBind in rev 1.58)
+	-- but an unrelated change meant that these unlifed bindings
+	-- could get to the top level which is bad.  And there's not much point;
+	-- unlifted bindings are always cheap, and so hardly worth floating.
+  = lvlExpr ctxt_lvl env rhs		`thenLvl` \ rhs' ->
+    lvlExpr incd_lvl env' body		`thenLvl` \ body' ->
+    returnLvl (Let (NonRec bndr' rhs') body')
+  where
+    incd_lvl = incMinorLvl ctxt_lvl
+    bndr' = TB bndr incd_lvl
+    env'  = extendLvlEnv env [bndr']
+
 lvlExpr ctxt_lvl env (_, AnnLet bind body)
   = lvlBind NotTopLevel ctxt_lvl env bind	`thenLvl` \ (bind', new_env) ->
     lvlExpr ctxt_lvl new_env body		`thenLvl` \ body' ->
@@ -335,6 +352,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 the expression, so that it can itself be floated.
 
+[NOTE: unlifted MFEs]
+We don't float unlifted MFEs, which potentially loses big opportunites.
+For example:
+	\x -> f (h y)
+where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
+the \x, but we don't because it's unboxed.  Possible solution: box it.
+
 \begin{code}
 lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 	-> Level		-- Level of innermost enclosing lambda/tylam
@@ -345,8 +369,9 @@ lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 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; 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
@@ -420,7 +445,7 @@ 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
+  | isInlineCtxt ctxt_lvl		-- Don't do anything inside InlineMe
   = lvlExpr ctxt_lvl env rhs			`thenLvl` \ rhs' ->
     returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env)
 
@@ -439,12 +464,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
   where
     bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
     abs_vars = abstractVars dest_lvl env bind_fvs
-
-    dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0
-	     | otherwise		    = destLevel env bind_fvs (isFunction rhs)
-	-- Hack alert!  We do have some unlifted bindings, for cheap primops, and 
-	-- it is ok to float them out; but not to the top level.  If they would otherwise
-	-- go to the top level, we pin them inside the topmost lambda
+    dest_lvl = destLevel env bind_fvs (isFunction rhs)
 \end{code}
 
 
-- 
1.7.10.4