+ simplRecursiveGroup new_env new_ids pairs
+
+ | otherwise
+ = simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
+ let
+ new_id' = new_id `withArity` arity
+
+ -- ToDo: this next bit could usefully share code with completeNonRec
+
+ new_env
+ | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = env
+
+ | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
+ = extendIdEnvWithAtom env binder the_arg
+
+ | otherwise -- Non-atomic
+ = extendEnvGivenBinding env occ_info new_id new_rhs
+ -- Don't eta if it doesn't eliminate the binding
+
+ eta'd_rhs = etaCoreExpr new_rhs
+ the_arg = case eta'd_rhs of
+ Var v -> VarArg v
+ Lit l -> LitArg l
+ in
+ simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
+ returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
+ where
+ ok_to_dup = switchIsSet env SimplOkToDupCode
+\end{code}
+
+
+
+\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 (mkFormSummary rhs)