floating-point fix for x86_64

[ghc-hetmet.git] / ghc / compiler / simplCore / FloatOut.lhs

diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index ac1c29d..988bd53 100644 (file)
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -11,9 +11,9 @@ module FloatOut ( floatOutwards ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils       ( mkSCC, exprIsValue, exprIsTrivial )
+import CoreUtils       ( mkSCC, exprIsHNF, exprIsTrivial )
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
+import DynFlags        ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
 import ErrUtils                ( dumpIfSet_dyn )
 import CostCentre      ( dupifyCC, CostCentre )
 import Id              ( Id, idType )
@@ -243,7 +243,7 @@ floatNonRecRhs lvl arg      -- Used for nested non-rec rhss, and fn args
        --      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
+    if exprIsHNF arg' || exprIsTrivial arg' then
        (fsa, floats, arg')
     else
     case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
@@ -330,10 +330,10 @@ floatExpr lvl (Let bind body)
   where
     bind_lvl = getBindLevel bind
 
-floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts)
+floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
   = case floatExpr lvl scrut   of { (fse, fde, scrut') ->
     case floatList float_alt alts      of { (fsa, fda, alts')  ->
-    (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
+    (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr ty alts')
     }}
   where
        -- Use floatRhs for the alternatives, so that we