X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatOut.lhs;h=f5f894648af86776ff78e88326020b7df53ddf47;hp=d65f7bd17e646b668ebce87eb3dfde880bdccb4c;hb=b84ba676034763b3082bbd9405794a4fde499d14;hpb=015d3d46b6de2f95386a515a7d166d996a0416db

diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index d65f7bd..f5f8946 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -10,11 +10,12 @@ module FloatOut ( floatOutwards ) where
 
 import CoreSyn
 import CoreUtils
+import CoreArity	( etaExpand )
 
 import DynFlags	( DynFlags, DynFlag(..), FloatOutSwitches(..) )
 import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
-import Id		( Id, idType )
+import Id		( Id, idType, idArity, isBottomingId )
 import Type		( isUnLiftedType )
 import SetLevels	( Level(..), LevelledExpr, LevelledBind,
 			  setLevels, isTopLvl, tOP_LEVEL )
@@ -144,13 +145,18 @@ floatTopBind bind
 %*									*
 %************************************************************************
 
-
 \begin{code}
 floatBind :: LevelledBind -> (FloatStats, FloatBinds)
 
-floatBind (NonRec (TB name level) rhs)
+floatBind (NonRec (TB var level) rhs)
   = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
-    (fs, rhs_floats `plusFloats` unitFloat level (NonRec name rhs')) }
+
+	-- A tiresome hack: 
+	-- see Note [Bottoming floats: eta expansion] in SetLevels
+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
+	      | otherwise         = rhs'
+
+    in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) }
 
 floatBind bind@(Rec pairs)
   = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
@@ -297,8 +303,8 @@ floatExpr lvl (Cast expr co)
     (fs, floating_defns, Cast expr' co) }
 
 floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body)
-  | isUnLiftedType (idType bndr)	-- Treat unlifted lets just like a case
-				-- I.e. floatExpr for rhs, floatCaseAlt for body
+  | isUnLiftedType (idType bndr)  -- Treat unlifted lets just like a case
+				  -- I.e. floatExpr for rhs, floatCaseAlt for body
   = case floatExpr lvl rhs	    of { (_, rhs_floats, rhs') ->
     case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
     (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }}