+
+\begin{code}
+floatBind :: SimplEnv
+ -> Bool -- True <=> Top level
+ -> InBinding
+ -> SmplM [InBinding]
+
+floatBind env top_level bind
+ | not float_lets ||
+ n_extras == 0
+ = returnSmpl [bind]
+
+ | otherwise
+ = tickN LetFloatFromLet n_extras `thenSmpl_`
+ -- It's important to increment the tick counts if we
+ -- do any floating. A situation where this turns out
+ -- to be important is this:
+ -- Float in produces:
+ -- letrec x = let y = Ey in Ex
+ -- in B
+ -- Now floating gives this:
+ -- letrec x = Ex
+ -- y = Ey
+ -- in B
+ --- We now want to iterate once more in case Ey doesn't
+ -- mention x, in which case the y binding can be pulled
+ -- out as an enclosing let(rec), which in turn gives
+ -- the strictness analyser more chance.
+ returnSmpl binds'
+
+ where
+ (binds', _, n_extras) = fltBind bind
+
+ float_lets = switchIsSet env SimplFloatLetsExposingWHNF
+ always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
+
+ -- fltBind guarantees not to return leaky floats
+ -- and all the binders of the floats have had their demand-info zapped
+ fltBind (NonRec bndr rhs)
+ = (binds ++ [NonRec (un_demandify bndr) rhs'],
+ leakFree bndr rhs',
+ length binds)
+ where
+ (binds, rhs') = fltRhs rhs
+
+ fltBind (Rec pairs)
+ = ([Rec (extras
+ ++
+ binders `zip` rhss')],
+ and (zipWith leakFree binders rhss'),
+ length extras
+ )
+
+ where
+ (binders, rhss) = unzip pairs
+ (binds_s, rhss') = mapAndUnzip fltRhs rhss
+ extras = concat (map get_pairs (concat binds_s))
+
+ get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
+ get_pairs (Rec pairs) = pairs
+
+ -- fltRhs has same invariant as fltBind
+ fltRhs rhs
+ | (always_float_let_from_let ||
+ floatExposesHNF True False False rhs)
+ = fltExpr rhs
+
+ | otherwise
+ = ([], rhs)
+
+
+ -- fltExpr has same invariant as fltBind
+ fltExpr (Let bind body)
+ | not top_level || binds_wont_leak
+ -- fltExpr guarantees not to return leaky floats
+ = (binds' ++ body_binds, body')
+ where
+ (body_binds, body') = fltExpr body
+ (binds', binds_wont_leak, _) = fltBind bind
+
+ fltExpr expr = ([], expr)
+
+-- Crude but effective
+leakFree (id,_) rhs = case getIdArity id of
+ ArityAtLeast n | n > 0 -> True
+ ArityExactly n | n > 0 -> True
+ other -> whnfOrBottom rhs
+\end{code}
+
+