+simplRecOrTopPair is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+
+It assumes the binder has already been simplified, but not its IdInfo.
+
+\begin{code}
+simplRecOrTopPair :: SimplEnv
+ -> TopLevelFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplRecOrTopPair env top_lvl bndr bndr' rhs
+ | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs))
+
+ | otherwise
+ = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
+ -- May not actually be recursive, but it doesn't matter
+\end{code}
+
+
+simplLazyBind is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+ * non-top-level *lazy* non-recursive bindings
+
+[Thus it deals with the lazy cases from simplNonRecBind, and all cases
+from SimplRecOrTopBind]
+
+Nota bene:
+ 1. It assumes that the binder is *already* simplified,
+ and is in scope, but not its IdInfo
+
+ 2. It assumes that the binder type is lifted.
+
+ 3. It does not check for pre-inline-unconditionallly;
+ that should have been done already.
+
+\begin{code}
+simplLazyBind :: SimplEnv
+ -> TopLevelFlag -> RecFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -> SimplEnv -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+ = let -- Transfer the IdInfo of the original binder to the new binder
+ -- This is crucial: we must preserve
+ -- strictness
+ -- rules
+ -- worker info
+ -- etc. To do this we must apply the current substitution,
+ -- which incorporates earlier substitutions in this very letrec group.
+ --
+ -- NB 1. We do this *before* processing the RHS of the binder, so that
+ -- its substituted rules are visible in its own RHS.
+ -- This is important. Manuel found cases where he really, really
+ -- wanted a RULE for a recursive function to apply in that function's
+ -- own right-hand side.
+ --
+ -- NB 2: We do not transfer the arity (see Subst.substIdInfo)
+ -- The arity of an Id should not be visible
+ -- in its own RHS, else we eta-reduce
+ -- f = \x -> f x
+ -- to
+ -- f = f
+ -- which isn't sound. And it makes the arity in f's IdInfo greater than
+ -- the manifest arity, which isn't good.
+ -- The arity will get added later.
+ --
+ -- NB 3: It's important that we *do* transer the loop-breaker OccInfo,
+ -- because that's what stops the Id getting inlined infinitely, in the body
+ -- of the letrec.
+
+ -- NB 4: does no harm for non-recursive bindings
+
+ bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
+ env1 = modifyInScope env bndr2 bndr2
+ rhs_env = setInScope rhs_se env1
+ is_top_level = isTopLevel top_lvl
+ ok_float_unlifted = not is_top_level && isNonRec is_rec
+ rhs_cont = mkRhsStop (idType bndr1)
+ in
+ -- Simplify the RHS; note the mkRhsStop, which tells
+ -- the simplifier that this is the RHS of a let.
+ simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
+
+ -- If any of the floats can't be floated, give up now
+ -- (The allLifted predicate says True for empty floats.)
+ if (not ok_float_unlifted && not (allLifted floats)) then
+ completeLazyBind env1 top_lvl bndr bndr2
+ (wrapFloats floats rhs1)
+ else
+
+ -- ANF-ise a constructor or PAP rhs
+ mkAtomicArgs False {- Not strict -}
+ ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+
+ -- If the result is a PAP, float the floats out, else wrap them
+ -- By this time it's already been ANF-ised (if necessary)
+ if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
+ completeLazyBind env1 top_lvl bndr bndr2 rhs2
+
+ else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
+ -- WARNING: long dodgy argument coming up
+ -- WANTED: a better way to do this
+ --
+ -- We can't use "exprIsCheap" instead of exprIsHNF,
+ -- because that causes a strictness bug.
+ -- x = let y* = E in case (scc y) of { T -> F; F -> T}
+ -- The case expression is 'cheap', but it's wrong to transform to
+ -- y* = E; x = case (scc y) of {...}
+ -- Either we must be careful not to float demanded non-values, or
+ -- we must use exprIsHNF for the test, which ensures that the
+ -- thing is non-strict. So exprIsHNF => bindings are non-strict
+ -- I think. The WARN below tests for this.
+ --
+ -- We use exprIsTrivial here because we want to reveal lone variables.
+ -- E.g. let { x = letrec { y = E } in y } in ...
+ -- Here we definitely want to float the y=E defn.
+ -- exprIsHNF definitely isn't right for that.
+ --
+ -- Again, the floated binding can't be strict; if it's recursive it'll
+ -- be non-strict; if it's non-recursive it'd be inlined.
+ --
+ -- Note [SCC-and-exprIsTrivial]
+ -- If we have
+ -- y = let { x* = E } in scc "foo" x
+ -- then we do *not* want to float out the x binding, because
+ -- it's strict! Fortunately, exprIsTrivial replies False to
+ -- (scc "foo" x).
+
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if (a) arg' is a WHNF, or (b) it's going to top level
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the warning
+ ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)),
+ ppr (filter demanded_float (floatBinds floats)) )
+
+ tick LetFloatFromLet `thenSmpl_` (
+ addFloats env1 floats $ \ env2 ->
+ addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
+ completeLazyBind env3 top_lvl bndr bndr2 rhs2)
+
+ else
+ completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
+
+#ifdef DEBUG
+demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
+ -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
+demanded_float (Rec _) = False
+#endif
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Completing a lazy binding}
+%* *
+%************************************************************************
+
+completeLazyBind
+ * deals only with Ids, not TyVars
+ * takes an already-simplified binder and RHS
+ * is used for both recursive and non-recursive bindings
+ * is used for both top-level and non-top-level bindings
+
+It does the following:
+ - tries discarding a dead binding
+ - tries PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
+
+It does *not* attempt to do let-to-case. Why? Because it is used for
+ - top-level bindings (when let-to-case is impossible)
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
+
+\begin{code}
+completeLazyBind :: SimplEnv
+ -> TopLevelFlag -- Flag stuck into unfolding
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM (FloatsWith SimplEnv)
+-- We return a new SimplEnv, because completeLazyBind may choose to do its work
+-- by extending the substitution (e.g. let x = y in ...)
+-- The new binding (if any) is returned as part of the floats.
+-- NB: the returned SimplEnv has the right SubstEnv, but you should
+-- (as usual) use the in-scope-env from the floats
+
+completeLazyBind env top_lvl old_bndr new_bndr new_rhs
+ | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
+ = -- Drop the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+
+ | otherwise
+ = let
+ -- Add arity info
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+
+ -- If the unfolding is a value, the demand info may
+ -- go pear-shaped, so we nuke it. Example:
+ -- let x = (a,b) in
+ -- case x of (p,q) -> h p q x
+ -- Here x is certainly demanded. But after we've nuked
+ -- the case, we'll get just
+ -- let x = (a,b) in h a b x
+ -- and now x is not demanded (I'm assuming h is lazy)
+ -- This really happens. Similarly
+ -- let f = \x -> e in ...f..f...
+ -- After inling f at some of its call sites the original binding may
+ -- (for example) be no longer strictly demanded.
+ -- The solution here is a bit ad hoc...
+ info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ final_info | loop_breaker = new_bndr_info
+ | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ | otherwise = info_w_unf
+
+ final_id = new_bndr `setIdInfo` final_info
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ returnSmpl (unitFloat env final_id new_rhs, env)
+
+ where
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+\end{code}
+
+
+