else
-- ANF-ise a constructor or PAP rhs
- mkAtomicArgs False {- Not strict -}
- ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+ mkAtomicArgs 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)
-- 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
+ -- After inlining 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
Y Y Non-top-level, non-recursive, Bind all args
and strict (demanded)
-
For example, given
x = MkC (y div# z)
a *strict* let, then it would be a good thing to do. Hence the
context information.
+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
+
\begin{code}
mkAtomicArgsE :: SimplEnv
- -> Bool -- A strict binding
- -> OutExpr -- The rhs
+ -> Bool -- A strict binding
+ -> OutExpr -- The rhs
-> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+ -- Consumer for the simpler rhs
-> SimplM FloatsWithExpr
+mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
+ | not (exprIsTrivial rhs)
+ -- Note [Float coersions]
+ -- See also Note [Take care] below
+ = do { id <- newId FSLIT("a") (exprType rhs)
+ ; completeNonRecX env False id id rhs $ \ env ->
+ thing_inside env (Cast (substExpr env (Var id)) co) }
+
mkAtomicArgsE env is_strict rhs thing_inside
| (Var fun, args) <- collectArgs rhs, -- It's an application
isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
| otherwise
= do { arg_id <- newId FSLIT("a") arg_ty
; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
- go env (App fun (Var arg_id)) args }
+ go env (App fun (substExpr env (Var arg_id))) args }
+ -- Note [Take care]:
+ -- If completeNonRecX was to do a postInlineUnconditionally
+ -- (undoing the effect of introducing the let-binding), we'd find arg_id had
+ -- no binding; hence the substExpr. This happens if we see
+ -- C (D x `cast` g)
+ -- Then we start by making a variable a1, thus
+ -- let a1 = D x `cast` g in C a1
+ -- But then we deal with the rhs of a1, getting
+ -- let a2 = D x, a1 = a1 `cast` g in C a1
+ -- And now the preInlineUnconditionally kicks in, and we substitute for a1
+
where
arg_ty = exprType arg
no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
-- Old code: consider rewriting to be more like mkAtomicArgsE
-mkAtomicArgs :: Bool -- A strict binding
- -> Bool -- OK to float unlifted args
+mkAtomicArgs :: Bool -- OK to float unlifted args
-> OutExpr
-> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include
OutExpr) -- things that need case-binding,
-- if the strict-binding flag is on
-mkAtomicArgs is_strict ok_float_unlifted rhs
+mkAtomicArgs ok_float_unlifted (Cast rhs co)
+ | not (exprIsTrivial rhs)
+ -- Note [Float coersions]
+ = do { id <- newId FSLIT("a") (exprType rhs)
+ ; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs
+ ; return (binds `snocOL` (id, rhs'), Cast (Var id) co) }
+
+mkAtomicArgs ok_float_unlifted rhs
| (Var fun, args) <- collectArgs rhs, -- It's an application
isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
= go fun nilOL [] args -- Have a go
| otherwise -- Don't forget to do it recursively
-- E.g. x = a:b:c:[]
- = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') ->
- newId FSLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ = mkAtomicArgs ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') ->
+ newId FSLIT("a") arg_ty `thenSmpl` \ arg_id ->
go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
(Var arg_id : rev_args) args
where
arg_ty = exprType arg
- can_float_arg = is_strict
- || not (isUnLiftedType arg_ty)
+ can_float_arg = not (isUnLiftedType arg_ty)
|| (ok_float_unlifted && exprOkForSpeculation arg)