idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda
)
-import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo, zapDemandInfo,
- setUnfoldingInfo,
- occInfo
+import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo,
+ setUnfoldingInfo, occInfo
)
import NewDemand ( isStrictDmd )
import TcGadt ( dataConCanMatch )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
- RecFlag(..), isNonRec
+ RecFlag(..), isNonRec, isNonRuleLoopBreaker
)
import OrdList
import List ( nub )
| otherwise
= -- Make the arguments atomic if necessary,
-- adding suitable bindings
- -- pprTrace "completeNonRecX" (ppr new_bndr <+> ppr new_rhs) $
mkAtomicArgsE env is_strict new_rhs $ \ env new_rhs ->
completeLazyBind env NotTopLevel
old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
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)
| otherwise
= let
- -- Add arity info
+ -- Arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ -- Unfolding info
-- 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
+
+ -- Demand info
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
-- 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
final_id `seq`
-- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
returnSmpl (unitFloat env final_id new_rhs, env)
-
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- loop_breaker = isLoopBreaker occ_info
+ loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
\end{code}
simplNote env (CoreNote s) e cont
= simplExpr env e `thenSmpl` \ e' ->
rebuild env (Note (CoreNote s) e') cont
+
+simplNote env note@(TickBox {}) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note note e') cont
+
+simplNote env note@(BinaryTickBox {}) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note note e') cont
\end{code}
= case substId env var of
DoneEx e -> simplExprF (zapSubstEnv env) e cont
ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
- DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
+ DoneId var1 -> completeCall (zapSubstEnv env) var1 cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
---------------------------------------------------------
-- Dealing with a call site
-completeCall env var occ_info cont
+completeCall env var cont
= -- Simplify the arguments
getDOptsSmpl `thenSmpl` \ dflags ->
let
interesting_cont = interestingCallContext (notNull args)
(notNull arg_infos)
call_cont
- active_inline = activeInline env var occ_info
- maybe_inline = callSiteInline dflags active_inline occ_info
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline
var arg_infos interesting_cont
in
case maybe_inline of {
(if dopt Opt_D_dump_inlinings dflags then
pprTrace "Inlining done" (vcat [
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
- text "Inlined fn: " <+> ppr unfolding,
+ text "Inlined fn: " $$ nest 2 (ppr unfolding),
text "Cont: " <+> ppr call_cont])
else
id) $
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)
way, there's a chance that v will now only be used once, and hence
inlined.
-Note 1
-~~~~~~
+Note [no-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~
There is a time we *don't* want to do that, namely when
-fno-case-of-case is on. This happens in the first simplifier pass,
and enhances full laziness. Here's the bad case:
[(m,n) | m <- [1..max], n <- [1..max]]
Hence the check for NoCaseOfCase.
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider case (v `cast` co) of x { I# ->
+ ... (case (v `cast` co) of {...}) ...
+We'd like to eliminate the inner case. We can get this neatly by
+arranging that inside the outer case we add the unfolding
+ v |-> x `cast` (sym co)
+to v. Then we should inline v at the inner case, cancel the casts, and away we go
+
Note 2
~~~~~~
There is another situation when we don't want to do it. If we have
x1) has unfolding MkT y1. THe straightforward thing to do is to do
the binder-swap. So this whole note is a no-op.
-Note 3
-~~~~~~
+Note [zapOccInfo]
+~~~~~~~~~~~~~~~~~
If we replace the scrutinee, v, by tbe case binder, then we have to nuke
any occurrence info (eg IAmDead) in the case binder, because the
case-binder now effectively occurs whenever v does. AND we have to do
the case binder is guaranteed dead.
\begin{code}
-simplCaseBinder env (Var v) case_bndr
- | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+simplCaseBinder env scrut case_bndr
+ | switchIsOn (getSwitchChecker env) NoCaseOfCase
+ -- See Note [no-case-of-case]
+ = do { (env, case_bndr') <- simplBinder env case_bndr
+ ; return (env, case_bndr') }
+simplCaseBinder env (Var v) case_bndr
-- Failed try [see Note 2 above]
-- not (isEvaldUnfolding (idUnfolding v))
-
- = simplBinder env (zapOccInfo case_bndr) `thenSmpl` \ (env, case_bndr') ->
- returnSmpl (modifyInScope env v case_bndr', case_bndr')
+ = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
+ ; return (modifyInScope env v case_bndr', case_bndr') }
-- We could extend the substitution instead, but it would be
-- a hack because then the substitution wouldn't be idempotent
-- any more (v is an OutId). And this does just as well.
+simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast]
+ = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
+ ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
+ ; return (addBinderUnfolding env v rhs, case_bndr') }
+
simplCaseBinder env other_scrut case_bndr
- = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
- returnSmpl (env, case_bndr')
+ = do { (env, case_bndr') <- simplBinder env case_bndr
+ ; return (env, case_bndr') }
-zapOccInfo :: InId -> InId
+zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
zapOccInfo b = b `setIdOccInfo` NoOccInfo
\end{code}
cant_match tys data_con = not (dataConCanMatch data_con tys)
simplify_default imposs_cons
- = do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons)
+ = do { let env' = addBinderOtherCon env case_bndr' imposs_cons
-- Record the constructors that the case-binder *can't* be.
; rhs' <- simplExprC env' rhs cont
; return [(DEFAULT, [], rhs')] }
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
where
- env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
+ env' = addBinderOtherCon env case_bndr' handled_cons
-- Record the constructors that the case-binder *can't* be.
simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
where
- env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
+ env' = addBinderUnfolding env case_bndr' (Lit lit)
simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
= -- Deal with the pattern-bound variables
simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
-- Bind the case-binder to (con args)
- let unf = mkUnfolding False (mkConApp con con_args)
- inst_tys' = tyConAppArgs (idType case_bndr')
+ let inst_tys' = tyConAppArgs (idType case_bndr')
con_args = map Type inst_tys' ++ varsToCoreExprs vs'
- env' = mk_rhs_env env case_bndr' unf
+ env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
in
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
zap_occ_info | isDeadBinder case_bndr' = \id -> id
| otherwise = zapOccInfo
-mk_rhs_env env case_bndr' case_bndr_unf
- = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
+addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
+addBinderUnfolding env bndr rhs
+ = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
+
+addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
+addBinderOtherCon env bndr cons
+ = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
\end{code}
-- Note that the binder might be "dead", because it doesn't occur
-- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
-- Nevertheless we must keep it if the case-binder is alive, because it may
- -- be used in teh con_app
+ -- be used in the con_app. See Note [zapOccInfo]
in
simplNonRecX env b' arg $ \ env ->
bind_args env dead_bndr bs args thing_inside
projects / ghc-hetmet.git / blobdiff