- flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
-
- get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
- get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
- get b _ = pprPanic "corePrepRecPairs" (ppr b)
-
---------------------------------
-corePrepRhs :: TopLevelFlag -> RecFlag
- -> CorePrepEnv -> (Id, CoreExpr)
- -> UniqSM (Floats, CoreExpr)
--- Used for top-level bindings, and local recursive bindings
-corePrepRhs top_lvl is_rec env (bndr, rhs) = do
- floats_w_rhs <- corePrepExprFloat env rhs
- floatRhs top_lvl is_rec bndr floats_w_rhs
-
-
--- ---------------------------------------------------------------------------
--- Making arguments atomic (function args & constructor args)
--- ---------------------------------------------------------------------------
-
--- This is where we arrange that a non-trivial argument is let-bound
-corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
- -> UniqSM (Floats, CoreArg)
-corePrepArg env arg dem
- = do { (floats, arg') <- corePrepExprFloat env arg
- ; if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
- -- Note [Floating unlifted arguments]
- then return (floats, arg')
- else do { v <- newVar (exprType arg')
- -- Note [Eta expand arguments]
- ; (floats', v') <- mkLocalNonRec v dem floats arg'
- ; return (floats', Var v') } }
-
--- version that doesn't consider an scc annotation to be trivial.
-exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial (Var _) = True
-exprIsTrivial (Type _) = True
-exprIsTrivial (Lit _) = True
-exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
-exprIsTrivial (Note (SCC _) _) = False
-exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Cast e _) = exprIsTrivial e
-exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
-exprIsTrivial _ = False
-\end{code}
-
-Note [Floating unlifted arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider C (let v* = expensive in v)
-
-where the "*" indicates "will be demanded". Usually v will have been
-inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
-do *not* want to get
-
- let v* = expensive in C v
-
-because that has different strictness. Hence the use of 'allLazy'.
-(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
-
+ add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
+ add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
+ add_float b _ = pprPanic "cpeBind" (ppr b)
+
+---------------
+cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
+ -> CorePrepEnv -> Id -> CoreExpr
+ -> UniqSM (Floats, Id, CpeRhs)
+-- Used for all bindings
+cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
+ = do { (floats1, rhs1) <- cpeRhsE env rhs
+
+ -- See if we are allowed to float this stuff out of the RHS
+ ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+ -- Make the arity match up
+ ; (floats3, rhs')
+ <- if manifestArity rhs1 <= arity
+ then return (floats2, cpeEtaExpand arity rhs2)
+ else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+ -- Note [Silly extra arguments]
+ (do { v <- newVar (idType bndr)
+ ; let float = mkFloat False False v rhs2
+ ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
+
+ -- Record if the binder is evaluated
+ -- and otherwise trim off the unfolding altogether
+ -- It's not used by the code generator; getting rid of it reduces
+ -- heap usage and, since we may be changing uniques, we'd have
+ -- to substitute to keep it right
+ ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
+ | otherwise = bndr `setIdUnfolding` noUnfolding
+
+ ; return (floats3, bndr', rhs') }
+ where
+ arity = idArity bndr -- We must match this arity
+
+ ---------------------
+ float_from_rhs floats rhs
+ | isEmptyFloats floats = return (emptyFloats, rhs)
+ | isTopLevel top_lvl = float_top floats rhs
+ | otherwise = float_nested floats rhs
+
+ ---------------------
+ float_nested floats rhs
+ | wantFloatNested is_rec is_strict_or_unlifted floats rhs
+ = return (floats, rhs)
+ | otherwise = dont_float floats rhs
+
+ ---------------------
+ float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
+ | mayHaveCafRefs (idCafInfo bndr)
+ , allLazyTop floats
+ = return (floats, rhs)
+
+ -- So the top-level binding is marked NoCafRefs
+ | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
+ = return (floats', rhs')
+
+ | otherwise
+ = dont_float floats rhs
+
+ ---------------------
+ dont_float floats rhs
+ -- Non-empty floats, but do not want to float from rhs
+ -- So wrap the rhs in the floats
+ -- But: rhs1 might have lambdas, and we can't
+ -- put them inside a wrapBinds
+ = do { body <- rhsToBodyNF rhs
+ ; return (emptyFloats, wrapBinds floats body) }
+
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+ f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+ f' = \x\y. e
+ f = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong? Reason
+(in the days of __inline_me__):
+ f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more. But
+it seems good for CorePrep to be robust.
+-}