- = let
- (env1,bndr2) = addLetIdInfo env bndr bndr1
- 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 bndr2)
- 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
- WARN( not (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)
+ = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+ do { let rhs_env = rhs_se `setInScope` env
+ (tvs, body) = case collectTyBinders rhs of
+ (tvs, body) | not_lam body -> (tvs,body)
+ | otherwise -> ([], rhs)
+ not_lam (Lam _ _) = False
+ not_lam _ = True
+ -- Do not do the "abstract tyyvar" thing if there's
+ -- a lambda inside, becuase it defeats eta-reduction
+ -- f = /\a. \x. g a x
+ -- should eta-reduce
+
+ ; (body_env, tvs') <- simplBinders rhs_env tvs
+ -- See Note [Floating and type abstraction] in SimplUtils
+
+ -- Simplify the RHS
+ ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
+ -- ANF-ise a constructor or PAP rhs
+ ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
+
+ ; (env', rhs')
+ <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
+ then -- No floating, revert to body1
+ do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1)
+ ; return (env, rhs') }
+
+ else if null tvs then -- Simple floating
+ do { tick LetFloatFromLet
+ ; return (addFloats env body_env2, body2) }
+
+ else -- Do type-abstraction first
+ do { tick LetFloatFromLet
+ ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
+ ; rhs' <- mkLam env tvs' body3
+ ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
+ ; return (env', rhs') }
+
+ ; completeBind env' top_lvl bndr bndr1 rhs' }
+\end{code}
+
+A specialised variant of simplNonRec used when the RHS is already simplified,
+notably in knownCon. It uses case-binding where necessary.
+
+\begin{code}
+simplNonRecX :: SimplEnv
+ -> InId -- Old binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM SimplEnv
+
+simplNonRecX env bndr new_rhs
+ | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+ = return env -- Here c is dead, and we avoid creating
+ -- the binding c = (a,b)
+ | Coercion co <- new_rhs
+ = return (extendCvSubst env bndr co)
+ | otherwise -- the binding b = (a,b)
+ = do { (env', bndr') <- simplBinder env bndr
+ ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
+ -- simplNonRecX is only used for NotTopLevel things
+
+completeNonRecX :: TopLevelFlag -> SimplEnv
+ -> Bool
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM SimplEnv
+
+completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
+ = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
+ ; (env2, rhs2) <-
+ if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
+ then do { tick LetFloatFromLet
+ ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
+ else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
+ ; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
+\end{code}
+
+{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
+ Doing so risks exponential behaviour, because new_rhs has been simplified once already
+ In the cases described by the folowing commment, postInlineUnconditionally will
+ catch many of the relevant cases.
+ -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ --
+ -- Similarly, single occurrences can be inlined vigourously
+ -- e.g. case (f x, g y) of (a,b) -> ....
+ -- If a,b occur once we can avoid constructing the let binding for them.
+
+ Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
+ -- Consider case I# (quotInt# x y) of
+ -- I# v -> let w = J# v in ...
+ -- If we gaily inline (quotInt# x y) for v, we end up building an
+ -- extra thunk:
+ -- let w = J# (quotInt# x y) in ...
+ -- because quotInt# can fail.
+
+ | preInlineUnconditionally env NotTopLevel bndr new_rhs
+ = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
+-}
+
+----------------------------------
+prepareRhs takes a putative RHS, checks whether it's a PAP or
+constructor application and, if so, converts it to ANF, so that the
+resulting thing can be inlined more easily. Thus
+ x = (f a, g b)
+becomes
+ t1 = f a
+ t2 = g b
+ x = (t1,t2)
+
+We also want to deal well cases like this
+ v = (f e1 `cast` co) e2
+Here we want to make e1,e2 trivial and get
+ x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
+That's what the 'go' loop in prepareRhs does
+
+\begin{code}
+prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
+-- Adds new floats to the env iff that allows us to return a good RHS
+prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
+ | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
+ = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
+ ; return (env', Cast rhs' co) }
+ where
+ sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+ `setDemandInfo` demandInfo info
+ info = idInfo id
+
+prepareRhs top_lvl env0 _ rhs0
+ = do { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
+ ; return (env1, rhs1) }
+ where
+ go n_val_args env (Cast rhs co)
+ = do { (is_exp, env', rhs') <- go n_val_args env rhs
+ ; return (is_exp, env', Cast rhs' co) }
+ go n_val_args env (App fun (Type ty))
+ = do { (is_exp, env', rhs') <- go n_val_args env fun
+ ; return (is_exp, env', App rhs' (Type ty)) }
+ go n_val_args env (App fun arg)
+ = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
+ ; case is_exp of
+ True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
+ ; return (True, env'', App fun' arg') }
+ False -> return (False, env, App fun arg) }
+ go n_val_args env (Var fun)
+ = return (is_exp, env, Var fun)
+ where
+ is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
+ -- See Note [CONLIKE pragma] in BasicTypes
+ -- The definition of is_exp should match that in
+ -- OccurAnal.occAnalApp
+
+ go _ env other
+ = return (False, env, other)
+\end{code}
+
+
+Note [Float coercions]
+~~~~~~~~~~~~~~~~~~~~~~
+When we find the binding
+ x = e `cast` co
+we'd like to transform it to
+ x' = e
+ x = x `cast` co -- A trivial binding
+There's a chance that e will be a constructor application or function, or something
+like that, so moving the coerion to the usage site may well cancel the coersions
+and lead to further optimisation. Example:
+
+ data family T a :: *
+ data instance T Int = T Int
+
+ foo :: Int -> Int -> Int
+ foo m n = ...
+ where
+ x = T m
+ go 0 = 0
+ go n = case x of { T m -> go (n-m) }
+ -- This case should optimise
+
+Note [Preserve strictness when floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the Note [Float coercions] transformation, keep the strictness info.
+Eg
+ f = e `cast` co -- f has strictness SSL
+When we transform to
+ f' = e -- f' also has strictness SSL
+ f = f' `cast` co -- f still has strictness SSL
+
+Its not wrong to drop it on the floor, but better to keep it.
+
+Note [Float coercions (unlifted)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT don't do [Float coercions] if 'e' has an unlifted type.
+This *can* happen:
+
+ foo :: Int = (error (# Int,Int #) "urk")
+ `cast` CoUnsafe (# Int,Int #) Int
+
+If do the makeTrivial thing to the error call, we'll get
+ foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
+But 'v' isn't in scope!
+
+These strange casts can happen as a result of case-of-case
+ bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
+ (# p,q #) -> p+q