X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FFloatOut.lhs;h=361b3cf86657fdcc327f7d72148a43b706ab35fc;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=9ab7221e84f216834bb15ea6b968c033f610f5cc;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index 9ab7221..361b3cf 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[FloatOut]{Float bindings outwards (towards the top level)}
 
@@ -10,34 +10,40 @@
 
 module FloatOut ( floatOutwards ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import PlainCore
-
-import BasicLit		( BasicLit(..), PrimKind )
-import CmdLineOpts	( GlobalSwitch(..) )
-import CostCentre	( dupifyCC, CostCentre )
-import SetLevels
-import Id		( eqId )
-import IdEnv
-import Maybes		( Maybe(..), catMaybes, maybeToBool )
-import SplitUniq
-import Util
+IMP_Ubiq(){-uitous-}
+
+import CoreSyn
+
+import CmdLineOpts	( opt_D_verbose_core2core, opt_D_simplifier_stats )
+import CostCentre	( dupifyCC )
+import Id		( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv(..),
+			  GenId{-instance Outputable-}
+			)
+import Outputable	( Outputable(..){-instance (,)-} )
+import PprCore		( GenCoreBinding{-instance-} )
+import PprStyle		( PprStyle(..) )
+import PprType		( GenTyVar )
+import Pretty		( ppInt, ppStr, ppBesides, ppAboves )
+import SetLevels	-- all of it
+import TyVar		( GenTyVar{-instance Eq-} )
+import Unique		( Unique{-instance Eq-} )
+import Usage		( UVar(..) )
+import Util		( pprTrace, panic )
 \end{code}
 
 Random comments
 ~~~~~~~~~~~~~~~
-At the moment we never float a binding out to between two adjacent lambdas.  For
-example:
+
+At the moment we never float a binding out to between two adjacent
+lambdas.  For example:
+
 @
 	\x y -> let t = x+x in ...
 ===>
 	\x -> let t = x+x in \y -> ...
 @
-Reason: this is less efficient in the case where the original lambda is
-never partially applied.
+Reason: this is less efficient in the case where the original lambda
+is never partially applied.
 
 But there's a case I've seen where this might not be true.  Consider:
 @
@@ -57,19 +63,19 @@ which might usefully be separated to
 @
 Well, maybe.  We don't do this at the moment.
 
-
 \begin{code}
-type LevelledExpr  = CoreExpr	 (Id, Level) Id
-type LevelledBind  = CoreBinding (Id, Level) Id
+type LevelledExpr  = GenCoreExpr    (Id, Level) Id TyVar UVar
+type LevelledBind  = GenCoreBinding (Id, Level) Id TyVar UVar
 type FloatingBind  = (Level, Floater)
 type FloatingBinds = [FloatingBind]
 
-data Floater = LetFloater     PlainCoreBinding
-
-	     | CaseFloater   (PlainCoreExpr -> PlainCoreExpr)
-				-- Give me a right-hand side of the
-				-- (usually single) alternative, and
-				-- I'll build the case
+data Floater
+  = LetFloater	CoreBinding
+  | CaseFloater	(CoreExpr -> CoreExpr)
+		-- A CoreExpr with a hole in it:
+		-- "Give me a right-hand side of the
+		-- (usually single) alternative, and
+		-- I'll build the case..."
 \end{code}
 
 %************************************************************************
@@ -79,40 +85,43 @@ data Floater = LetFloater     PlainCoreBinding
 %************************************************************************
 
 \begin{code}
-floatOutwards :: (GlobalSwitch -> Bool)	 -- access to all global cmd-line opts
-	      -> SplitUniqSupply
-	      -> PlainCoreProgram 
-	      -> PlainCoreProgram
+floatOutwards :: UniqSupply -> [CoreBinding] -> [CoreBinding]
 
-floatOutwards sw_chker us pgm
-  = case (setLevels pgm sw_chker us) of { annotated_w_levels ->
+floatOutwards us pgm
+  = case (setLevels pgm us) of { annotated_w_levels ->
 
-    case unzip3 (map (floatTopBind sw_chker) annotated_w_levels)
-		of { (fcs, lcs, final_toplev_binds_s) ->
+    case (unzip (map floatTopBind annotated_w_levels))
+		of { (fss, final_toplev_binds_s) ->
 
-    (if sw_chker D_verbose_core2core
-     then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
+    (if opt_D_verbose_core2core
+     then pprTrace "Levels added:\n"
+		   (ppAboves (map (ppr PprDebug) annotated_w_levels))
      else id
     )
-    ( if  sw_chker D_simplifier_stats
-      then pprTrace "FloatOut stats: " (ppBesides [
-		ppInt (sum fcs), ppStr " Lets floated out of ",
-		ppInt (sum lcs), ppStr " Lambdas"])
-      else id
+    ( if not (opt_D_simplifier_stats) then
+	 id
+      else
+	 let
+	    (tlets, ntlets, lams) = get_stats (sum_stats fss)
+	 in
+	 pprTrace "FloatOut stats: " (ppBesides [
+		ppInt tlets,  ppStr " Lets floated to top level; ",
+		ppInt ntlets, ppStr " Lets floated elsewhere; from ",
+		ppInt lams,   ppStr " Lambda groups"])
     )
     concat final_toplev_binds_s
     }}
 
-floatTopBind sw bind@(CoNonRec _ _)
-  = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, bind', _) ->
-    (fc,lc, floatsToBinds floats ++ [bind'])
+floatTopBind bind@(NonRec _ _)
+  = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
+    (fs, floatsToBinds floats ++ [bind'])
     }
 
-floatTopBind sw bind@(CoRec _)
-  = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, CoRec pairs', _) ->
+floatTopBind bind@(Rec _)
+  = case (floatBind nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
 	-- Actually floats will be empty
     --false:ASSERT(null floats)
-    (fc,lc, [CoRec (floatsToBindPairs floats ++ pairs')])
+    (fs, [Rec (floatsToBindPairs floats ++ pairs')])
     }
 \end{code}
 
@@ -124,30 +133,31 @@ floatTopBind sw bind@(CoRec _)
 
 
 \begin{code}
-floatBind :: (GlobalSwitch -> Bool) 
-	  -> IdEnv Level
+floatBind :: IdEnv Level
 	  -> Level
 	  -> LevelledBind
-	  -> (Int,Int, FloatingBinds, PlainCoreBinding, IdEnv Level)
+	  -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
 
-floatBind sw env lvl (CoNonRec (name,level) rhs)
-  = case (floatExpr sw env level rhs) of { (fc,lc, rhs_floats, rhs') ->
+floatBind env lvl (NonRec (name,level) rhs)
+  = case (floatExpr env level rhs) of { (fs, rhs_floats, rhs') ->
 
 	-- A good dumping point
-    case (partitionByMajorLevel level rhs_floats)	of { (rhs_floats', heres) ->
+    case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 
-    (fc,lc, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
+    (fs, rhs_floats',
+     NonRec name (install heres rhs'),
+     addOneToIdEnv env name level)
     }}
-    
-floatBind sw env lvl bind@(CoRec pairs)
-  = case (unzip4 (map do_pair pairs)) of { (fcs,lcs, rhss_floats, new_pairs) ->
+
+floatBind env lvl bind@(Rec pairs)
+  = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
 
     if not (isTopLvl bind_level) then
 	-- Standard case
-	(sum fcs,sum lcs, concat rhss_floats, CoRec new_pairs, new_env)
+	(sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
     else
-	{- In a recursive binding, destined for the top level (only), 
-	   the rhs floats may contain 
+	{- 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) ...
@@ -157,12 +167,13 @@ floatBind sw env lvl bind@(CoRec pairs)
 		v = ...f...
 		f = ... b ...
 
-	   and hence we must (pessimistically) make all the floats recursive 
+	   and hence we must (pessimistically) make all the floats recursive
 	   with the top binding.  Later dependency analysis will unravel it.
 	-}
 
-	(sum fcs,sum lcs, [], 
-	 CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
+	(sum_stats fss,
+	 [],
+	 Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
 	 new_env)
 
     }
@@ -172,12 +183,12 @@ floatBind sw env lvl bind@(CoRec pairs)
     bind_level = getBindLevel bind
 
     do_pair ((name, level), rhs)
-      = case (floatExpr sw new_env level rhs) of { (fc,lc, rhs_floats, rhs') ->
+      = case (floatExpr new_env level rhs) of { (fs, rhs_floats, rhs') ->
 
 		-- A good dumping point
-	case (partitionByMajorLevel level rhs_floats)	of { (rhs_floats', heres) ->
+	case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
 
-	(fc,lc, rhs_floats', (name, install heres rhs'))
+	(fs, rhs_floats', (name, install heres rhs'))
 	}}
 \end{code}
 
@@ -188,101 +199,103 @@ floatBind sw env lvl bind@(CoRec pairs)
 %************************************************************************
 
 \begin{code}
-floatExpr :: (GlobalSwitch -> Bool) 
-	  -> IdEnv Level
-	  -> Level 
+floatExpr :: IdEnv Level
+	  -> Level
 	  -> LevelledExpr
-	  -> (Int,Int, FloatingBinds, PlainCoreExpr)
-
-floatExpr sw env _ (CoVar v)	     = (0,0, [], CoVar v)
-
-floatExpr sw env _ (CoLit l)     = (0,0, [], CoLit l)
+	  -> (FloatStats, FloatingBinds, CoreExpr)
 
-floatExpr sw env _ (CoPrim op ty as) = (0,0, [], CoPrim op ty as)
-floatExpr sw env _ (CoCon con ty as) = (0,0, [], CoCon con ty as)
+floatExpr env _ (Var v)	     = (zero_stats, [], Var v)
+floatExpr env _ (Lit l)      = (zero_stats, [], Lit l)
+floatExpr env _ (Prim op as) = (zero_stats, [], Prim op as)
+floatExpr env _ (Con con as) = (zero_stats, [], Con con as)
+	  
+floatExpr env lvl (App e a)
+  = case (floatExpr env lvl e) of { (fs, floating_defns, e') ->
+    (fs, floating_defns, App e' a) }
 
-floatExpr sw env lvl (CoApp e a)
-  = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
-    (fc,lc, floating_defns, CoApp e' a) }
-    
-floatExpr sw env lvl (CoTyApp e ty)
-  = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
-    (fc,lc, floating_defns, CoTyApp e' ty) }
+floatExpr env lvl (Lam (UsageBinder _) e)
+  = panic "FloatOut.floatExpr: Lam UsageBinder"
 
-floatExpr sw env lvl (CoTyLam tv e)
+floatExpr env lvl (Lam (TyBinder tv) e)
   = let
 	incd_lvl = incMinorLvl lvl
     in
-    case (floatExpr sw env incd_lvl e) of { (fc,lc, floats, e') ->
+    case (floatExpr env incd_lvl e) of { (fs, floats, e') ->
 
 	-- Dump any bindings which absolutely cannot go any further
     case (partitionByLevel incd_lvl floats)	of { (floats', heres) ->
 
-    (fc,lc, floats', CoTyLam tv (install heres e'))
+    (fs, floats', Lam (TyBinder tv) (install heres e'))
     }}
 
-floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
+floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs)
   = let
-	args'	 = map fst args
-	new_env  = growIdEnvList env args
+	new_env  = addOneToIdEnv env arg incd_lvl
     in
-    case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, floats, rhs') ->
+    case (floatExpr new_env incd_lvl rhs) of { (fs, floats, rhs') ->
 
 	-- Dump any bindings which absolutely cannot go any further
     case (partitionByLevel incd_lvl floats)	of { (floats', heres) ->
 
-    (fc +  length floats', lc + 1,
-     floats', mkCoLam args' (install heres rhs'))
+    (add_to_stats fs floats',
+     floats',
+     Lam (ValBinder arg) (install heres rhs'))
     }}
 
-floatExpr sw env lvl (CoSCC cc expr)
-  = case (floatExpr sw env lvl expr)    of { (fc,lc, floating_defns, expr') ->
+floatExpr env lvl (SCC cc expr)
+  = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
     let
 	-- annotate bindings floated outwards past an scc expression
 	-- with the cc.  We mark that cc as "duplicated", though.
 
 	annotated_defns = annotate (dupifyCC cc) floating_defns
     in
-    (fc,lc, annotated_defns, CoSCC cc expr') }
+    (fs, annotated_defns, SCC cc expr') }
   where
     annotate :: CostCentre -> FloatingBinds -> FloatingBinds
 
     annotate dupd_cc defn_groups
       = [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
       where
-	ann_bind (LetFloater (CoNonRec binder rhs)) 
-	  = LetFloater (CoNonRec binder (ann_rhs rhs))
+	ann_bind (LetFloater (NonRec binder rhs))
+	  = LetFloater (NonRec binder (ann_rhs rhs))
 
-	ann_bind (LetFloater (CoRec pairs))
-	  = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
+	ann_bind (LetFloater (Rec pairs))
+	  = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
 
-	ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
+	ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
 
-	ann_rhs (CoLam	 args e) = CoLam   args (ann_rhs e)
-	ann_rhs (CoTyLam tv   e) = CoTyLam tv	(ann_rhs e)
-	ann_rhs rhs@(CoCon _ _ _)= rhs	-- no point in scc'ing WHNF data
-	ann_rhs rhs		 = CoSCC dupd_cc rhs
+	ann_rhs (Lam arg e)   = Lam arg (ann_rhs e)
+	ann_rhs rhs@(Con _ _) = rhs	-- no point in scc'ing WHNF data
+	ann_rhs rhs	      = SCC dupd_cc rhs
 
 	-- Note: Nested SCC's are preserved for the benefit of
 	--       cost centre stack profiling (Durham)
 
-floatExpr sw env lvl (CoLet bind body)
-  = case (floatBind sw env     lvl bind) of { (fcb,lcb, rhs_floats, bind', new_env) ->
-    case (floatExpr sw new_env lvl body) of { (fce,lce, body_floats, body') ->
-    (fcb + fce, lcb + lce,
-     rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats, body')
+floatExpr env lvl (Coerce c ty expr)
+  = case (floatExpr env lvl expr)    of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Coerce c ty expr') }
+
+floatExpr env lvl (Let bind body)
+  = case (floatBind env     lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
+    case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
+    (add_stats fsb fse,
+     rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
+     body')
     }}
   where
     bind_lvl = getBindLevel bind
 
-floatExpr sw env lvl (CoCase scrut alts)
-  = case (floatExpr sw env lvl scrut) of { (fce,lce, fde, scrut') ->
-
-    case (scrut', float_alts alts) of 
+floatExpr env lvl (Case scrut alts)
+  = case (floatExpr env lvl scrut) of { (fse, fde, scrut') ->
 
-{-	CASE-FLOATING DROPPED FOR NOW.  (SLPJ 7/2/94)
+    case (scrut', float_alts alts) of
+	(_, (fsa, fda, alts')) ->
+		(add_stats fse fsa, fda ++ fde, Case scrut' alts')
+    }
+    {-	OLD CASE-FLOATING CODE: DROPPED FOR NOW.  (SLPJ 7/2/94)
 
-	(CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault)) 
+	(Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
 	 	| scrut_var_lvl `ltMajLvl` lvl ->
 
 		-- Candidate for case floater; scrutinising a variable; it can
@@ -291,17 +304,12 @@ floatExpr sw env lvl (CoCase scrut alts)
 
 		where
 		case_floater = (scrut_var_lvl, CaseFloater fn)
-		fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
+		fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
 		scrut_var_lvl = case lookupIdEnv env scrut_var of
 				  Nothing  -> Level 0 0
 				  Just lvl -> unTopify lvl
 
- END OF CASE FLOATING DROPPED  	-}
-
-	(_, (fca,lca, fda, alts')) -> 
-
-		(fce + fca, lce + lca, fda ++ fde, CoCase scrut' alts') 
-    }
+    END OF CASE FLOATING DROPPED -}
   where
       incd_lvl = incMinorLvl lvl
 
@@ -310,34 +318,36 @@ floatExpr sw env lvl (CoCase scrut alts)
 {-	OMITTED
 	We don't want to be too keen about floating lets out of case alternatives
 	because they may benefit from seeing the evaluation done by the case.
-	
+
 	The main reason for doing this is to allocate in fewer larger blocks
 	but that's really an STG-level issue.
 
 			case alts of
 				-- Just one alternative, then dump only
 				-- what *has* to be dumped
-			CoAlgAlts  [_] CoNoDefault	   -> partitionByLevel
-			CoAlgAlts  []  (CoBindDefault _ _) -> partitionByLevel
-			CoPrimAlts [_] CoNoDefault	   -> partitionByLevel
-			CoPrimAlts []  (CoBindDefault _ _) -> partitionByLevel
+			AlgAlts  [_] NoDefault	   -> partitionByLevel
+			AlgAlts  []  (BindDefault _ _) -> partitionByLevel
+			PrimAlts [_] NoDefault	   -> partitionByLevel
+			PrimAlts []  (BindDefault _ _) -> partitionByLevel
 
 				-- If there's more than one alternative, then
 				-- this is a dumping point
 			other				   -> partitionByMajorLevel
 -}
 
-      float_alts (CoAlgAlts alts deflt)
-	= case (float_deflt  deflt)		 of { (fcd,lcd,   fdd,  deflt') ->
-	  case (unzip4 (map float_alg_alt alts)) of { (fcas,lcas, fdas, alts') ->
-	  (fcd + sum fcas, lcd + sum lcas,
-	   concat fdas ++ fdd, CoAlgAlts alts' deflt') }}
+      float_alts (AlgAlts alts deflt)
+	= case (float_deflt  deflt)		 of { (fsd,  fdd,  deflt') ->
+	  case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
+	  (foldr add_stats fsd fsas,
+	   concat fdas ++ fdd,
+	   AlgAlts alts' deflt') }}
 
-      float_alts (CoPrimAlts alts deflt)
-	= case (float_deflt deflt)		  of { (fcd,lcd,   fdd, deflt') ->
-	  case (unzip4 (map float_prim_alt alts)) of { (fcas,lcas, fdas, alts') ->
-	  (fcd + sum fcas, lcd + sum lcas,
-	   concat fdas ++ fdd, CoPrimAlts alts' deflt') }}
+      float_alts (PrimAlts alts deflt)
+	= case (float_deflt deflt)		  of { (fsd,   fdd, deflt') ->
+	  case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
+	  (foldr add_stats fsd fsas,
+	   concat fdas ++ fdd,
+	   PrimAlts alts' deflt') }}
 
       -------------
       float_alg_alt (con, bs, rhs)
@@ -345,39 +355,68 @@ floatExpr sw env lvl (CoCase scrut alts)
 	      bs' = map fst bs
 	      new_env = growIdEnvList env bs
 	  in
-	  case (floatExpr sw new_env incd_lvl rhs)	of { (fc,lc, rhs_floats, rhs') ->
+	  case (floatExpr new_env incd_lvl rhs)	of { (fs, rhs_floats, rhs') ->
 	  case (partition_fn incd_lvl rhs_floats)	of { (rhs_floats', heres) ->
-	  (fc, lc, rhs_floats', (con, bs', install heres rhs'))
-	  }}
+	  (fs, rhs_floats', (con, bs', install heres rhs')) }}
 
       --------------
       float_prim_alt (lit, rhs)
-	= case (floatExpr sw env incd_lvl rhs)		of { (fc,lc, rhs_floats, rhs') ->
+	= case (floatExpr env incd_lvl rhs)		of { (fs, rhs_floats, rhs') ->
 	  case (partition_fn incd_lvl rhs_floats)	of { (rhs_floats', heres) ->
-	  (fc,lc, rhs_floats', (lit, install heres rhs'))
-	  }}
+	  (fs, rhs_floats', (lit, install heres rhs')) }}
 
       --------------
-      float_deflt CoNoDefault = (0,0, [], CoNoDefault)
+      float_deflt NoDefault = (zero_stats, [], NoDefault)
 
-      float_deflt (CoBindDefault (b,lvl) rhs)
-	= case (floatExpr sw new_env lvl rhs)		of { (fc,lc, rhs_floats, rhs') ->
+      float_deflt (BindDefault (b,lvl) rhs)
+	= case (floatExpr new_env lvl rhs)		of { (fs, rhs_floats, rhs') ->
 	  case (partition_fn incd_lvl rhs_floats)	of { (rhs_floats', heres) ->
-	  (fc,lc, rhs_floats', CoBindDefault b (install heres rhs'))
-	  }}
+	  (fs, rhs_floats', BindDefault b (install heres rhs')) }}
 	where
-	  new_env = addOneToIdEnv env b lvl        
+	  new_env = addOneToIdEnv env b lvl
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Utility bits for floating stats}
+%*									*
+%************************************************************************
+
+I didn't implement this with unboxed numbers.  I don't want to be too
+strict in this stuff, as it is rarely turned on.  (WDP 95/09)
+
+\begin{code}
+data FloatStats
+  = FlS	Int  -- Number of top-floats * lambda groups they've been past
+	Int  -- Number of non-top-floats * lambda groups they've been past
+	Int  -- Number of lambda (groups) seen
+
+get_stats (FlS a b c) = (a, b, c)
+
+zero_stats = FlS 0 0 0
+
+sum_stats xs = foldr add_stats zero_stats xs
+
+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)
+
+add_to_stats (FlS a b c) floats
+  = FlS (a + length top_floats) (b + length other_floats) (c + 1)
+  where
+    (top_floats, other_floats) = partition to_very_top floats
+
+    to_very_top (my_lvl, _) = isTopLvl my_lvl
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[FloatOut-utils]{Utility bits for floating}
+\subsection{Utility bits for floating}
 %*									*
 %************************************************************************
 
 \begin{code}
-getBindLevel (CoNonRec (_, lvl) _)      = lvl
-getBindLevel (CoRec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (_, lvl) _)      = lvl
+getBindLevel (Rec (((_,lvl), _) : _)) = lvl
 \end{code}
 
 \begin{code}
@@ -390,7 +429,7 @@ partitionByMajorLevel, partitionByLevel
 	    FloatingBinds)	-- The rest
 
 
-partitionByMajorLevel ctxt_lvl defns 
+partitionByMajorLevel ctxt_lvl defns
   = partition float_further defns
   where
     float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
@@ -403,25 +442,25 @@ partitionByLevel ctxt_lvl defns
 \end{code}
 
 \begin{code}
-floatsToBinds :: FloatingBinds -> [PlainCoreBinding]
+floatsToBinds :: FloatingBinds -> [CoreBinding]
 floatsToBinds floats = map get_bind floats
 		     where
 		       get_bind (_, LetFloater bind) = bind
 		       get_bind (_, CaseFloater _)   = panic "floatsToBinds"
 
-floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
+floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
 
 floatsToBindPairs floats = concat (map mk_pairs floats)
   where
-   mk_pairs (_, LetFloater (CoRec pairs))         = pairs
-   mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
+   mk_pairs (_, LetFloater (Rec pairs))         = pairs
+   mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
    mk_pairs (_, CaseFloater _) 			  = panic "floatsToBindPairs"
 
-install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
+install :: FloatingBinds -> CoreExpr -> CoreExpr
 
 install defn_groups expr
   = foldr install_group expr defn_groups
   where
-    install_group (_, LetFloater defns) body = CoLet defns body
+    install_group (_, LetFloater defns) body = Let defns body
     install_group (_, CaseFloater fn)   body = fn body
 \end{code}