+-- Stg doesn't have a lambda *expression*
+deStgLam (StgLam ty bndrs body)
+ -- Try for eta reduction
+ = ASSERT( not (null bndrs) )
+ case eta body of
+ Just e -> -- Eta succeeded
+ returnUs e
+
+ Nothing -> -- Eta failed, so let-bind the lambda
+ newStgVar ty `thenUs` \ fn ->
+ returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
+ where
+ lam_closure = StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ bndrs
+ body
+
+ eta (StgApp f args)
+ | n_remaining >= 0 &&
+ and (zipWith ok bndrs last_args) &&
+ notInExpr bndrs remaining_expr
+ = Just remaining_expr
+ where
+ remaining_expr = StgApp f remaining_args
+ (remaining_args, last_args) = splitAt n_remaining args
+ n_remaining = length args - length bndrs
+
+ eta (StgLet bind@(StgNonRec b r) body)
+ | notInRhs bndrs r = case eta body of
+ Just e -> Just (StgLet bind e)
+ Nothing -> Nothing
+
+ eta _ = Nothing
+
+ ok bndr (StgVarArg arg) = bndr == arg
+ ok bndr other = False
+
+deStgLam expr = returnUs expr
+
+
+--------------------------------------------------
+notInExpr :: [Id] -> StgExpr -> Bool
+notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
+notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
+notInExpr vs other = False -- Safe
+
+notInRhs :: [Id] -> StgRhs -> Bool
+notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
+notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
+ -- Conservative: we could delete the binders from vs, but
+ -- cloning means this will never help
+
+notInArgs :: [Id] -> [StgArg] -> Bool
+notInArgs vs args = all ok args
+ where
+ ok (StgVarArg v) = notInId vs v
+ ok (StgLitArg l) = True
+
+notInId :: [Id] -> Id -> Bool
+notInId vs v = not (v `elem` vs)
+
+
+
+mkStgBinds :: [StgFloatBind]
+ -> StgExpr -- *Can* be a StgLam
+ -> UniqSM StgExpr -- *Can* be a StgLam
+
+mkStgBinds [] body = returnUs body
+mkStgBinds (b:bs) body
+ = deStgLam body `thenUs` \ body' ->
+ go (b:bs) body'
+ where
+ go [] body = returnUs body
+ go (b:bs) body = go bs body `thenUs` \ body' ->
+ mkStgBind b body'
+
+-- The 'body' arg of mkStgBind can't be a StgLam
+mkStgBind NoBindF body = returnUs body
+mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
+
+mkStgBind (NonRecF bndr rhs dem floats) body
+#ifdef DEBUG
+ -- We shouldn't get let or case of the form v=w
+ = case rhs of
+ StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
+ (mk_stg_let bndr rhs dem floats body)
+ other -> mk_stg_let bndr rhs dem floats body
+
+mk_stg_let bndr rhs dem floats body
+#endif
+ | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
+ mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
+
+ | is_whnf
+ = if is_strict then
+ -- Strict let with WHNF rhs
+ mkStgBinds floats $
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
+ else
+ -- Lazy let with WHNF rhs; float until we find a strict binding
+ let
+ (floats_out, floats_in) = splitFloats floats
+ in
+ mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
+ mkStgBinds floats_out $
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
+
+ | otherwise -- Not WHNF
+ = if is_strict then
+ -- Strict let with non-WHNF rhs
+ mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
+ else
+ -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
+ mkStgBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
+
+ where
+ bndr_rep_ty = repType (idType bndr)
+ is_strict = isStrictDem dem
+ is_whnf = case rhs of
+ StgConApp _ _ -> True
+ StgLam _ _ _ -> True
+ other -> False
+
+-- Split at the first strict binding
+splitFloats fs@(NonRecF _ _ dem _ : _)
+ | isStrictDem dem = ([], fs)
+
+splitFloats (f : fs) = case splitFloats fs of
+ (fs_out, fs_in) -> (f : fs_out, fs_in)
+
+splitFloats [] = ([], [])
+\end{code}
+