+ returnUs (floats, rhs)
+
+ | otherwise
+ -- Don't float; the RHS isn't a value
+ = mkBinds floats rhs `thenUs` \ rhs' ->
+ returnUs (emptyFloats, rhs')
+
+-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
+mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
+ -> Floats -> CoreExpr -- Rhs: let binds in body
+ -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
+ -- to record that it's been evaluated
+
+mkLocalNonRec bndr dem floats rhs
+ | isUnLiftedType (idType bndr)
+ -- If this is an unlifted binding, we always make a case for it.
+ = ASSERT( not (isUnboxedTupleType (idType bndr)) )
+ let
+ float = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ in
+ returnUs (addFloat floats float, evald_bndr)
+
+ | isStrict dem
+ -- It's a strict let so we definitely float all the bindings
+ = let -- Don't make a case for a value binding,
+ -- even if it's strict. Otherwise we get
+ -- case (\x -> e) of ...!
+ float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
+ | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ in
+ returnUs (addFloat floats float, evald_bndr)
+
+ | otherwise
+ = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
+ returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
+ if exprIsHNF rhs' then evald_bndr else bndr)
+
+ where
+ evald_bndr = bndr `setIdUnfolding` evaldUnfolding
+ -- Record if the binder is evaluated
+
+
+mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
+mkBinds (Floats _ binds) body
+ | isNilOL binds = returnUs body
+ | otherwise = deLam body `thenUs` \ body' ->
+ -- Lambdas are not allowed as the body of a 'let'
+ returnUs (foldrOL mk_bind body' binds)
+ where
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
+ mk_bind (FloatLet bind) body = Let bind body
+
+etaExpandRhs bndr rhs
+ = -- Eta expand to match the arity claimed by the binder
+ -- Remember, after CorePrep we must not change arity