``Long-distance'' floating of bindings towards the top level.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module FloatOut ( floatOutwards ) where
#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( mkSCC, exprIsHNF, exprIsTrivial )
+import CoreUtils
import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
import ErrUtils ( dumpIfSet_dyn )
floatRhs lvl arg -- Used for nested non-rec rhss, and fn args
-- See Note [Floating out of RHS]
= case (floatExpr lvl arg) of { (fsa, floats, arg') ->
- if exprIsHNF arg' || exprIsTrivial arg' then
+ if exprIsCheap arg' then
(fsa, floats, arg')
else
case (partitionByMajorLevel lvl floats) of { (floats', heres) ->
-- 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.
+--
+-- We use exprIsCheap because that is also what's used by the simplifier
+-- to decide whether to float a let out of a let
floatExpr _ (Var v) = (zeroStats, [], Var v)
floatExpr _ (Type ty) = (zeroStats, [], Type ty)
-- more efficient to test once here than to avoid putting
-- them into floating_defns (which would mean testing for
-- inlineCtxt at every let)
- (fs, [], Note InlineMe (install floating_defns expr')) } -- See notes in SetLevels
+ (fs, [], Note InlineMe (install floating_defns expr')) }
+ -- See Note [FloatOut inside INLINE] in SetLevels
+ -- I'm guessing that floating_dens should be empty
floatExpr lvl (Note note expr) -- Other than SCCs
= case (floatExpr lvl expr) of { (fs, floating_defns, 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') ->
+ -- I.e. floatExpr for rhs, floatCaseAlt for body
+ = case floatExpr lvl rhs of { (fs, rhs_floats, rhs') ->
+ case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') ->
(fs, rhs_floats ++ body_floats, Let (NonRec bndr rhs') body') }}
floatExpr lvl (Let bind body)