-
-\begin{code}
--- Dead code is now discarded by the occurrence analyser,
-
-simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
- | idWantsToBeINLINEd id
- = complete_bind env rhs -- Don't mess about with floating or let-to-case on
- -- INLINE things
- | otherwise
- = simpl_bind env rhs
- where
- -- Try for strict let of error
- simpl_bind env rhs | will_be_demanded && maybeToBool maybe_error_app
- = returnSmpl retyped_error_app
- where
- maybe_error_app = maybeErrorApp rhs (Just body_ty)
- Just retyped_error_app = maybe_error_app
-
- -- Try let-to-case; see notes below about let-to-case
- simpl_bind env rhs | will_be_demanded &&
- try_let_to_case &&
- singleConstructorType rhs_ty &&
- -- Only do let-to-case for single constructor types.
- -- For other types we defer doing it until the tidy-up phase at
- -- the end of simplification.
- not rhs_is_whnf -- note: WHNF, but not bottom, (comment below)
- = tick Let2Case `thenSmpl_`
- mkIdentityAlts rhs_ty demand_info `thenSmpl` \ id_alts ->
- simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty
- -- NB: it's tidier to call complete_bind not simpl_bind, else
- -- we nearly end up in a loop. Consider:
- -- let x = rhs in b
- -- ==> case rhs of (p,q) -> let x=(p,q) in b
- -- This effectively what the above simplCase call does.
- -- Now, the inner let is a let-to-case target again! Actually, since
- -- the RHS is in WHNF it won't happen, but it's a close thing!
-
- -- Try let-from-let
- simpl_bind env (Let bind rhs) | let_floating_ok
- = tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
- (\env -> simpl_bind env rhs) body_ty
-
- -- Try case-from-let; this deals with a strict let of error too
- simpl_bind env (Case scrut alts) | case_floating_ok scrut
- = tick CaseFloatFromLet `thenSmpl_`
-
- -- First, bind large let-body if necessary
- if ok_to_dup || isSingleton (nonErrorRHSs alts)
- then
- simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
- else
- bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
- let
- body_c' = \env -> simplExpr env new_body [] body_ty
- case_c = \env rhs -> simplBind env (NonRec binder rhs) body_c' body_ty
- in
- simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
- returnSmpl (Let extra_binding case_expr)
-
- -- None of the above; simplify rhs and tidy up
- simpl_bind env rhs = complete_bind env rhs
-
- complete_bind env rhs
- = cloneId env binder `thenSmpl` \ new_id ->
- simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env binder
- (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
- returnSmpl (mkCoLetsAny binds body')
-
-
- -- All this stuff is computed at the start of the simpl_bind loop
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- float_primops = switchIsSet env SimplOkToFloatPrimOps
- ok_to_dup = switchIsSet env SimplOkToDupCode
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
- try_let_to_case = switchIsSet env SimplLetToCase
- no_float = switchIsSet env SimplNoLetFromStrictLet
-
- demand_info = getIdDemandInfo id
- will_be_demanded = willBeDemanded demand_info
- rhs_ty = idType id
-
- form = mkFormSummary rhs
- rhs_is_bot = case form of
- BottomForm -> True
- other -> False
- rhs_is_whnf = case form of
- VarForm -> True
- ValueForm -> True
- other -> False
-
- float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
-
- let_floating_ok = (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
- float_exposes_hnf
-
- case_floating_ok scrut = (will_be_demanded && not no_float) ||
- (float_exposes_hnf && is_cheap_prim_app scrut && float_primops)
- -- See note below
-\end{code}
-
-Float switches
-~~~~~~~~~~~~~~
-The booleans controlling floating have to be set with a little care.
-Here's one performance bug I found:
-
- let x = let y = let z = case a# +# 1 of {b# -> E1}
- in E2
- in E3
- in E4
-
-Now, if E2, E3 aren't HNFs we won't float the y-binding or the z-binding.
-Before case_floating_ok included float_exposes_hnf, the case expression was floated
-*one level per simplifier iteration* outwards. So it made th s
-