X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatOut.lhs;h=ba74afce7669865002b689f1843cb820b0377a91;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=d65f7bd17e646b668ebce87eb3dfde880bdccb4c;hpb=0d291233b14099032c6ffc87f8688abe9bd49f8a;p=ghc-hetmet.git

diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index d65f7bd..ba74afc 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -10,11 +10,13 @@ module FloatOut ( floatOutwards ) where
 
 import CoreSyn
 import CoreUtils
+import CoreArity	( etaExpand )
+import CoreMonad	( FloatOutSwitches(..) )
 
-import DynFlags	( DynFlags, DynFlag(..), FloatOutSwitches(..) )
+import DynFlags		( DynFlags, DynFlag(..) )
 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 +146,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 +304,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') }}