SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, mkLam, newId,
+import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkStop, mkBoringStop, pushContArgs,
import Var ( mustHaveLocalBinding )
import VarEnv
import Id ( Id, idType, idInfo, idArity, isDataConId,
- idUnfolding, setIdUnfolding, isDeadBinder,
+ setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
+import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo,
setUnfoldingInfo,
import DataCon ( dataConNumInstArgs, dataConRepStrictness )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
+import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
- exprType, coreAltsType, exprIsValue,
- exprOkForSpeculation, exprArity, findDefault,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+ exprType, exprIsValue,
+ exprOkForSpeculation, exprArity,
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
-import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs, funArgTy,
- funResultTy, splitFunTy_maybe, splitFunTy, eqType
+import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
+ splitFunTy_maybe, splitFunTy, eqType
)
import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, simplIdInfo
import OrdList
import Maybe ( Maybe )
import Outputable
+import Util ( notNull )
\end{code}
drop_bs (NonRec _ _) (_ : bs) = bs
drop_bs (Rec prs) bs = drop (length prs) bs
- simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
- simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+ simpl_bind env bind bs
+ = getDOptsSmpl `thenSmpl` \ dflags ->
+ if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs
+ else
+ simpl_bind1 env bind bs
+
+ simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
\end{code}
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
= -- Don't use simplBinder because that doesn't keep
- -- fragile occurrence in the substitution
+ -- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
- simplStrictArg AnRhs env rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 ->
+ let
+ -- simplLetBndr doesn't deal with the IdInfo, so we must
+ -- do so here (c.f. simplLazyBind)
+ bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ env1 = modifyInScope env bndr'' bndr''
+ in
+ simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 ->
-- Now complete the binding and simplify the body
- completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside
+ completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
- -- fragile occurrence in the substitution
+ -- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
-> SimplM FloatsWithExpr
simplNonRecX env bndr new_rhs thing_inside
+ | needsCaseBinding (idType bndr) new_rhs
+ -- Make this test *before* the preInlineUnconditionally
+ -- 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.
+ = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
+ thing_inside env `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)])
+
| preInlineUnconditionally env NotTopLevel bndr
-- This happens; for example, the case_bndr during case of
-- known constructor: case (a,b) of x { (p,q) -> ... }
bndr bndr' new_rhs thing_inside
completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
- | needsCaseBinding (idType new_bndr) new_rhs
- = thing_inside env `thenSmpl` \ (floats, body) ->
- returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
-
- | otherwise
= mkAtomicArgs is_strict
True {- OK to float unlifted -}
new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
--
-- NB: does no harm for non-recursive bindings
let
- is_top_level = isTopLevel top_lvl
- bndr_ty' = idType bndr'
- bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
+ bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
env1 = modifyInScope env bndr'' bndr''
rhs_env = setInScope rhs_se env1
+ is_top_level = isTopLevel top_lvl
ok_float_unlifted = not is_top_level && isNonRec is_rec
- rhs_cont = mkStop bndr_ty' AnRhs
+ rhs_cont = mkStop (idType bndr') AnRhs
in
-- Simplify the RHS; note the mkStop, which tells
-- the simplifier that this is the RHS of a let.
-- (as usual) use the in-scope-env from the floats
completeLazyBind env top_lvl old_bndr new_bndr new_rhs
- | postInlineUnconditionally env new_bndr loop_breaker new_rhs
+ | postInlineUnconditionally env new_bndr occ_info new_rhs
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
let
arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
- interesting_cont = interestingCallContext (not (null args))
- (not (null arg_infos))
+ interesting_cont = interestingCallContext (notNull args)
+ (notNull arg_infos)
call_cont
active_inline = activeInline env var occ_info
| 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 SLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ 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
rebuild env expr (Stop _ _ _) = rebuildDone env expr
rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
= knownCon env (LitAlt lit) [] case_bndr alts cont
| otherwise
- = -- Prepare case alternatives
- -- Filter out alternatives that can't possibly match
- let
- impossible_cons = case scrut of
- Var v -> otherCons (idUnfolding v)
- other -> []
- better_alts = case impossible_cons of
- [] -> alts
- other -> [alt | alt@(con,_,_) <- alts,
- not (con `elem` impossible_cons)]
-
- -- "handled_cons" are handled either by the context,
- -- or by a branch in this case expression
- -- Don't add DEFAULT to the handled_cons!!
- (alts_wo_default, _) = findDefault better_alts
- handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default]
- in
+ = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
- prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
- addFloats env floats $ \ env ->
+ prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
+ addFloats env floats $ \ env ->
-- Deal with variable scrutinee
- simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
+ simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
-- Deal with the case alternatives
simplAlts alt_env zap_occ_info handled_cons
- case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
+ case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
-- Put the case back together
- mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr ->
+ mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
-- Notice that rebuildDone returns the in-scope set from env, not alt_env
-- The case binder *not* scope over the whole returned case-expression
case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
...other cases .... }
-But there is no point in doing it for the inner case,
-because w1 can't be inlined anyway. Furthermore, doing the case-swapping
-involves zapping w2's occurrence info (see paragraphs that follow),
-and that forces us to bind w2 when doing case merging. So we get
+But there is no point in doing it for the inner case, because w1 can't
+be inlined anyway. Furthermore, doing the case-swapping involves
+zapping w2's occurrence info (see paragraphs that follow), and that
+forces us to bind w2 when doing case merging. So we get
case x of w1 { A -> let w2 = w1 in e1
B -> let w2 = w1 in e2
if exprIsDupable arg' then
returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont))
else
- newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
+ newId FSLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
tick (CaseOfCase arg_id) `thenSmpl_`
-- Want to tick here so that we go round again,
-- (the \v alone is enough to make CPR happy) but I think it's rare
( if null used_bndrs'
- then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
+ then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
+ newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
projects / ghc-hetmet.git / blobdiff