SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, mkLam, newId,
- simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
+import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
+ simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
- mkStop, mkBoringStop,
- contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
+ mkStop, mkBoringStop, pushContArgs,
+ contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
import Var ( mustHaveLocalBinding )
import VarEnv
-import Id ( Id, idType, idInfo, idArity, isDataConId,
- idUnfolding, setIdUnfolding, isDeadBinder,
+import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
+ setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- setIdOccInfo,
- zapLamIdInfo, setOneShotLambda,
+ setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
+import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo,
+ setArityInfo, zapDemandInfo,
setUnfoldingInfo,
occInfo
)
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, mkPiType, findAlt, findDefault,
- exprType, coreAltsType, exprIsValue,
+ exprIsConApp_maybe, mkPiTypes, findAlt,
+ exprType, exprIsValue,
exprOkForSpeculation, exprArity,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
-import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
- funResultTy, splitFunTy_maybe, splitFunTy, eqType
+import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
+ splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy, substExpr,
+import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, simplIdInfo
)
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
import OrdList
import Maybe ( Maybe )
+import Maybes ( orElse )
import Outputable
+import Util ( notNull )
\end{code}
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
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
- simplLetId env bndr `thenSmpl` \ (env, bndr') ->
- simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
-
- -- Make the arguments atomic if necessary,
- -- adding suitable bindings
- mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
- addAtomicBindsE env aux_binds $ \ env ->
+ -- fragile occurrence info in the substitution
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
+ simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 ->
-- Now complete the binding and simplify the body
- completeNonRecX env bndr bndr' rhs2 thing_inside
+ let
+ -- simplLetBndr doesn't deal with the IdInfo, so we must
+ -- do so here (c.f. simplLazyBind)
+ bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ env2 = modifyInScope env1 bndr2 bndr2
+ in
+ completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
- -- fragile occurrence in the substitution
- simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ -- fragile occurrence info in the substitution
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
-> 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) -> ... }
| otherwise
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
- completeNonRecX env bndr bndr' new_rhs thing_inside
+ completeNonRecX env False {- Non-strict; pessimistic -}
+ bndr bndr' new_rhs thing_inside
-completeNonRecX env 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)])
+completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
+ = mkAtomicArgs is_strict
+ True {- OK to float unlifted -}
+ new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
- | otherwise
- = completeLazyBind env NotTopLevel
- old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ addAtomicBindsE env (fromOL aux_binds) $ \ env ->
+ completeLazyBind env NotTopLevel
+ old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
\end{code}
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (FloatsWith SimplEnv)
-simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
- = -- Substitute IdInfo on binder, in the light of earlier
- -- substitutions in this very letrec, and extend the
- -- in-scope env, so that the IdInfo for this binder extends
- -- over the RHS for the binder itself.
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+ = let -- Transfer the IdInfo of the original binder to the new binder
+ -- This is crucial: we must preserve
+ -- strictness
+ -- rules
+ -- worker info
+ -- etc. To do this we must apply the current substitution,
+ -- which incorporates earlier substitutions in this very letrec group.
--
+ -- NB 1. We do this *before* processing the RHS of the binder, so that
+ -- its substituted rules are visible in its own RHS.
-- This is important. Manuel found cases where he really, really
-- wanted a RULE for a recursive function to apply in that function's
- -- own right-hand side.
+ -- own right-hand side.
--
- -- NB: does no harm for non-recursive bindings
- let
- bndr_ty' = idType bndr'
- bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
- env1 = modifyInScope env bndr'' bndr''
+ -- NB 2: We do not transfer the arity (see Subst.substIdInfo)
+ -- The arity of an Id should not be visible
+ -- in its own RHS, else we eta-reduce
+ -- f = \x -> f x
+ -- to
+ -- f = f
+ -- which isn't sound. And it makes the arity in f's IdInfo greater than
+ -- the manifest arity, which isn't good.
+ -- The arity will get added later.
+ --
+ -- NB 3: It's important that we *do* transer the loop-breaker OccInfo,
+ -- because that's what stops the Id getting inlined infinitely, in the body
+ -- of the letrec.
+
+ -- NB 4: does no harm for non-recursive bindings
+
+ bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
- ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
- rhs_cont = mkStop bndr_ty' AnRhs
+ is_top_level = isTopLevel top_lvl
+ ok_float_unlifted = not is_top_level && isNonRec is_rec
+ rhs_cont = mkStop (idType bndr1) AnRhs
in
-- Simplify the RHS; note the mkStop, which tells
-- the simplifier that this is the RHS of a let.
-- 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 bndr''
+ completeLazyBind env1 top_lvl bndr bndr2
(wrapFloats floats rhs1)
else
-- 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 && null aux_binds then -- Shortcut a common case
- completeLazyBind env1 top_lvl bndr bndr'' rhs2
-
- -- 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.
- -- exprIsValue definitely isn't right for that.
- --
- -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
+ 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 || exprIsValue rhs2 then
+ -- WARNING: long dodgy argument coming up
+ -- WANTED: a better way to do this
+ --
+ -- We can't use "exprIsCheap" instead of exprIsValue,
+ -- 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 exprIsValue for the test, which ensures that the
- -- thing is non-strict. I think. The WARN below tests for this
- else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- thing is non-strict. So exprIsValue => 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.
+ -- exprIsValue 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 arg' is a WHNF,
+ -- 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 assert
- WARN( any demanded_float (floatBinds floats),
- ppr (filter demanded_float (floatBinds floats)) )
+ -- Hence the warning
+ ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)),
+ ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env1 floats $ \ env2 ->
- addAtomicBinds env2 aux_binds $ \ env3 ->
- completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+ addAtomicBinds env2 (fromOL aux_binds) $ \ env3 ->
+ completeLazyBind env3 top_lvl bndr bndr2 rhs2)
else
- completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
+ completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
#ifdef DEBUG
demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
-- (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))
-- Add arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
- -- 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
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
-
- final_id = new_bndr `setIdInfo` info_w_unf
+ -- 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
+
+ -- If the unfolding is a value, the demand info may
+ -- go pear-shaped, so we nuke it. Example:
+ -- let x = (a,b) in
+ -- case x of (p,q) -> h p q x
+ -- Here x is certainly demanded. But after we've nuked
+ -- the case, we'll get just
+ -- let x = (a,b) in h a b x
+ -- 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
+ -- (for example) be no longer strictly demanded.
+ -- The solution here is a bit ad hoc...
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ final_info | loop_breaker = new_bndr_info
+ | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ | otherwise = info_w_unf
+
+ final_id = new_bndr `setIdInfo` final_info
in
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
+simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg)
where
expr_ty' = substTy (getSubst env) (exprType expr)
-- The type in the Stop continuation, expr_ty', is usually not used
case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
simplExprF env (Let (Rec pairs) body) cont
- = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
- -- NB: bndrs' don't have unfoldings or spec-envs
- -- We add them as we go down, using simplPrags
+ = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ -- NB: bndrs' don't have unfoldings or rules
+ -- We add them as we go down
simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
addFloats env floats $ \ env ->
simplLam env fun cont
= go env fun cont
where
- zap_it = mkLamBndrZapper fun cont
+ zap_it = mkLamBndrZapper fun (countArgs cont)
cont_ty = contResultType cont
-- Type-beta reduction
-- Ordinary beta reduction
go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick (BetaReduction bndr) `thenSmpl_`
- simplNonRecBind env zapped_bndr arg arg_se cont_ty $ \ env ->
+ simplNonRecBind env (zap_it bndr) arg arg_se cont_ty $ \ env ->
go env body body_cont
- where
- zapped_bndr = zap_it bndr
-- Not enough args, so there are real lambdas left to put in the result
go env lam@(Lam _ _) cont
- = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ = simplLamBndrs env bndrs `thenSmpl` \ (env, bndrs') ->
simplExpr env body `thenSmpl` \ body' ->
mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
addFloats env floats $ \ env ->
go env expr cont = simplExprF env expr cont
mkLamBndrZapper :: CoreExpr -- Function
- -> SimplCont -- The context
+ -> Int -- Number of args supplied, *including* type args
-> Id -> Id -- Use this to zap the binders
-mkLamBndrZapper fun cont
+mkLamBndrZapper fun n_args
| n_args >= n_params fun = \b -> b -- Enough args
| otherwise = \b -> zapLamIdInfo b
where
-- NB: we count all the args incl type args
-- so we must count all the binders (incl type lambdas)
- n_args = countArgs cont
-
n_params (Note _ e) = n_params e
n_params (Lam b e) = 1 + n_params e
n_params other = 0::Int
-- the inner one is redundant
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
- | Just (s1, s2) <- splitFunTy_maybe s1s2
+ | not (isTypeArg arg), -- This whole case only works for value args
+ -- Could upgrade to have equiv thing for type apps too
+ Just (s1, s2) <- splitFunTy_maybe s1s2
-- (coerce (T1->T2) (S1->S2) F) E
-- ===>
-- coerce T2 S2 (F (coerce S1 T1 E))
--
- -- t1t2 must be a function type, T1->T2
+ -- t1t2 must be a function type, T1->T2, because it's applied to something
-- but s1s2 might conceivably not be
--
-- When we build the ApplyTo we can't mix the out-types
-- 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)
-- an interesting context of any kind to combine with
-- (even a type application -- anything except Stop)
= simplExprF env e cont
+
+simplNote env (CoreNote s) e cont
+ = simplExpr env e `thenSmpl` \ e' ->
+ rebuild env (Note (CoreNote s) e') cont
\end{code}
-- the inlined copy!!
---------------------------------------------------------
--- Dealing with a call
+-- Dealing with a call site
completeCall env var occ_info cont
- = getDOptsSmpl `thenSmpl` \ dflags ->
+ = -- Simplify the arguments
+ getDOptsSmpl `thenSmpl` \ dflags ->
let
- in_scope = getInScope env
- chkr = getSwitchChecker env
-
+ chkr = getSwitchChecker env
(args, call_cont, inline_call) = getContArgs chkr var cont
-
- arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env)
- | (arg, arg_env, _) <- args, isValArg arg]
-
- interesting_cont = interestingCallContext (not (null args))
- (not (null arg_infos))
- call_cont
-
- inline_cont | inline_call = discardInline cont
- | otherwise = cont
-
- active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline inline_call occ_info
- var arg_infos interesting_cont
+ fn_ty = idType var
in
- -- First, look for an inlining
- case maybe_inline of {
- Just unfolding -- There is an inlining!
- -> tick (UnfoldingDone var) `thenSmpl_`
- simplExprF env unfolding inline_cont
-
- ;
- Nothing -> -- No inlining!
-
-
- simplifyArgs env args (contResultType call_cont) $ \ env args' ->
+ simplifyArgs env fn_ty args (contResultType call_cont) $ \ env args ->
-- Next, look for rules or specialisations that match
--
-- Some functions have specialisations *and* are strict; in this case,
-- we don't want to inline the wrapper of the non-specialised thing; better
-- to call the specialised thing instead.
- -- But the black-listing mechanism means that inlining of the wrapper
- -- won't occur for things that have specialisations till a later phase, so
- -- it's ok to try for inlining first.
+ -- We used to use the black-listing mechanism to ensure that inlining of
+ -- the wrapper didn't occur for things that have specialisations till a
+ -- later phase, so but now we just try RULES first
--
-- You might think that we shouldn't apply rules for a loop breaker:
-- doing so might give rise to an infinite loop, because a RULE is
-- So it's up to the programmer: rules can cause divergence
let
+ in_scope = getInScope env
maybe_rule = case activeRule env of
Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope var args'
+ Just act_fn -> lookupRule act_fn in_scope var args
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
(if dopt Opt_D_dump_inlinings dflags then
pprTrace "Rule fired" (vcat [
- text "Rule:" <+> ptext rule_name,
- text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
- text "After: " <+> pprCoreExpr rule_rhs])
+ text "Rule:" <+> ftext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
+ text "After: " <+> pprCoreExpr rule_rhs,
+ text "Cont: " <+> ppr call_cont])
else
id) $
simplExprF env rule_rhs call_cont ;
Nothing -> -- No rules
+ -- Next, look for an inlining
+ let
+ arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
+
+ interesting_cont = interestingCallContext (notNull args)
+ (notNull arg_infos)
+ call_cont
+
+ active_inline = activeInline env var occ_info
+ maybe_inline = callSiteInline dflags active_inline inline_call occ_info
+ var arg_infos interesting_cont
+ in
+ case maybe_inline of {
+ Just unfolding -- There is an inlining!
+ -> tick (UnfoldingDone var) `thenSmpl_`
+ makeThatCall env var unfolding args call_cont
+
+ ;
+ Nothing -> -- No inlining!
+
-- Done
- rebuild env (mkApps (Var var) args') call_cont
+ rebuild env (mkApps (Var var) args) call_cont
}}
+
+makeThatCall :: SimplEnv
+ -> Id
+ -> InExpr -- Inlined function rhs
+ -> [OutExpr] -- Arguments, already simplified
+ -> SimplCont -- After the call
+ -> SimplM FloatsWithExpr
+-- Similar to simplLam, but this time
+-- the arguments are already simplified
+makeThatCall orig_env var fun@(Lam _ _) args cont
+ = go orig_env fun args
+ where
+ zap_it = mkLamBndrZapper fun (length args)
+
+ -- Type-beta reduction
+ go env (Lam bndr body) (Type ty_arg : args)
+ = ASSERT( isTyVar bndr )
+ tick (BetaReduction bndr) `thenSmpl_`
+ go (extendSubst env bndr (DoneTy ty_arg)) body args
+
+ -- Ordinary beta reduction
+ go env (Lam bndr body) (arg : args)
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplNonRecX env (zap_it bndr) arg $ \ env ->
+ go env body args
+
+ -- Not enough args, so there are real lambdas left to put in the result
+ go env fun args
+ = simplExprF env fun (pushContArgs orig_env args cont)
+ -- NB: orig_env; the correct environment to capture with
+ -- the arguments.... env has been augmented with substitutions
+ -- from the beta reductions.
+
+makeThatCall env var fun args cont
+ = simplExprF env fun (pushContArgs env args cont)
\end{code}
-- Simplifying the arguments of a call
simplifyArgs :: SimplEnv
+ -> OutType -- Type of the function
-> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
-> OutType -- Type of the continuation
-> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
-- discard the entire application and replace it with (error "foo"). Getting
-- all this at once is TOO HARD!
-simplifyArgs env args cont_ty thing_inside
- = go env args thing_inside
+simplifyArgs env fn_ty args cont_ty thing_inside
+ = go env fn_ty args thing_inside
where
- go env [] thing_inside = thing_inside env []
- go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
- go env args $ \ env args' ->
- thing_inside env (arg':args')
+ go env fn_ty [] thing_inside = thing_inside env []
+ go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty $ \ env arg' ->
+ go env (applyTypeToArg fn_ty arg') args $ \ env args' ->
+ thing_inside env (arg':args')
-simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
+simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside
= simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
thing_inside env (Type new_ty_arg)
-simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
+simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
| is_strict
- = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
-
- | otherwise
- = let
- arg_env = setInScope arg_se env
- in
- simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
- simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
- addFloats env floats $ \ env ->
- thing_inside env arg1
+ = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
+
+ | otherwise -- Lazy argument
+ -- DO NOT float anything outside, hence simplExprC
+ -- There is no benefit (unlike in a let-binding), and we'd
+ -- have to be very careful about bogus strictness through
+ -- floating a demanded let.
+ = simplExprC (setInScope arg_se env) val_arg
+ (mkStop arg_ty AnArg) `thenSmpl` \ arg1 ->
+ thing_inside env arg1
+ where
+ arg_ty = funArgTy fn_ty
-simplStrictArg :: SimplEnv -- The env of the call
- -> LetRhsFlag
- -> InExpr -> SimplEnv -- The arg plus its env
+simplStrictArg :: LetRhsFlag
+ -> SimplEnv -- The env of the call
+ -> InExpr -> SimplEnv -- The arg plus its env
+ -> OutType -- arg_ty: type of the argument
-> OutType -- cont_ty: Type of thing computed by the context
-> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
-- Takes an expression of type rhs_ty,
-- env of the call, plus any new in-scope variables
-> SimplM FloatsWithExpr -- An expression of type cont_ty
-simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
+simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside
= simplExprF (setInScope arg_env call_env) arg
- (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
+ (ArgOf is_rhs arg_ty cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
-- Notice the way we use arg_env (augmented with in-scope vars from call_env)
-- to simplify the argument
-- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
mkAtomicArgs :: Bool -- A strict binding
-> Bool -- OK to float unlifted args
-> OutExpr
- -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
- OutExpr) -- things that need case-binding,
- -- if the strict-binding flag is on
+ -> 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
- = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
- case maybe_stuff of
- Nothing -> returnSmpl ([], rhs)
- Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, 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 = bale_out -- Give up
where
- mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
- -- Nothing => no change
- mk_atomic_args rhs
- | (Var fun, args) <- collectArgs rhs, -- It's an application
- isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
- = -- Worth a try
- go nilOL [] args `thenSmpl` \ maybe_stuff ->
- case maybe_stuff of
- Nothing -> returnSmpl Nothing
- Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
-
- | otherwise
- = returnSmpl Nothing
+ bale_out = returnSmpl (nilOL, rhs)
+
+ go fun binds rev_args []
+ = returnSmpl (binds, mkApps (Var fun) (reverse rev_args))
- go binds rev_args []
- = returnSmpl (Just (binds, reverse rev_args))
- go binds rev_args (arg : args)
- | exprIsTrivial arg -- Easy case
- = go binds (arg:rev_args) args
+ go fun binds rev_args (arg : args)
+ | exprIsTrivial arg -- Easy case
+ = go fun binds (arg:rev_args) args
| not can_float_arg -- Can't make this arg atomic
- = returnSmpl Nothing -- ... so give up
+ = bale_out -- ... so give up
| otherwise -- Don't forget to do it recursively
-- E.g. x = a:b:c:[]
- = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
- case maybe_anf of {
- Nothing -> returnSmpl Nothing ;
- Just (arg_binds,arg') ->
-
- newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
- go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
+ = mkAtomicArgs is_strict 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)
|| (ok_float_unlifted && exprOkForSpeculation arg)
+
addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
-> (SimplEnv -> SimplM (FloatsWith a))
-> SimplM (FloatsWith a)
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)]
- 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, 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 impossible_cons
- case_bndr' better_alts cont' `thenSmpl` \ alts' ->
+ simplAlts alt_env zap_occ_info handled_cons
+ case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
-- Put the case back together
- mkCase scrut 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
- rebuildDone env case_expr
+ rebuild env case_expr nondup_cont
\end{code}
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
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
simplAlts :: SimplEnv
-> (InId -> InId) -- Occ-info zapper
-> [AltCon] -- Alternatives the scrutinee can't be
+ -- in the default case
-> OutId -- Case binder
-> [InAlt] -> SimplCont
-> SimplM [OutAlt] -- Includes the continuation
-simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
+simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
inst_tys' = tyConAppArgs (idType case_bndr')
- -- handled_cons is all the constructors that are dealt
- -- with, either by being impossible, or by there being an alternative
- (con_alts,_) = findDefault alts
- handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
-
simpl_alt (DEFAULT, _, rhs)
= let
-- In the default case we record the constructors that the
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
- add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
+ add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc)
add_evals other_con vs = vs
- cat_evals [] [] = []
- cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isMarkedStrict str = evald_v : cat_evals vs strs
- | otherwise = zapped_v : cat_evals vs strs
+ cat_evals dc vs strs
+ = go vs strs
where
- zapped_v = zap_occ_info v
- evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go [] [] = []
+ go (v:vs) (str:strs)
+ | isTyVar v = v : go vs (str:strs)
+ | isMarkedStrict str = evald_v : go vs strs
+ | otherwise = zapped_v : go vs strs
+ where
+ zapped_v = zap_occ_info v
+ evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
\end{code}
\begin{code}
prepareCaseCont :: SimplEnv
-> [InAlt] -> SimplCont
- -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
- -- plus some extra bindings
+ -> SimplM (FloatsWith (SimplCont,SimplCont))
+ -- Return a duplicatable continuation, a non-duplicable part
+ -- plus some extra bindings
-prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
-- No need to make it duplicatable if there's only one alternative
-
-prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
- mkDupableCont env alts_ty cont
- -- At one time I passed in the un-simplified type, and simplified
- -- it only if we needed to construct a join binder, but that
- -- didn't work because we have to decompse function types
- -- (using funResultTy) in mkDupableCont.
+prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont)))
+prepareCaseCont env alts cont = mkDupableCont env cont
\end{code}
\begin{code}
-mkDupableCont :: SimplEnv
- -> OutType -- Type of the thing to be given to the continuation
- -> SimplCont
- -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
- -- plus some extra bindings
+mkDupableCont :: SimplEnv -> SimplCont
+ -> SimplM (FloatsWith (SimplCont, SimplCont))
-mkDupableCont env ty cont
+mkDupableCont env cont
| contIsDupable cont
- = returnSmpl (emptyFloats env, cont)
-
-mkDupableCont env _ (CoerceIt ty cont)
- = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
- returnSmpl (floats, CoerceIt ty cont')
-
-mkDupableCont env ty (InlinePlease cont)
- = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
- returnSmpl (floats, InlinePlease cont')
-
-mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
- = -- e.g. (...strict-fn...) [...hole...]
+ = returnSmpl (emptyFloats env, (cont, mkBoringStop (contResultType cont)))
+
+mkDupableCont env (CoerceIt ty cont)
+ = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
+ returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont))
+
+mkDupableCont env (InlinePlease cont)
+ = mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
+ returnSmpl (floats, (InlinePlease dup_cont, nondup_cont))
+
+mkDupableCont env cont@(ArgOf _ arg_ty _ _)
+ = returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont))
+ -- Do *not* duplicate an ArgOf continuation
+ -- Because ArgOf continuations are opaque, we gain nothing by
+ -- propagating them into the expressions, and we do lose a lot.
+ -- Here's an example:
+ -- && (case x of { T -> F; F -> T }) E
+ -- Now, && is strict so we end up simplifying the case with
+ -- an ArgOf continuation. If we let-bind it, we get
+ --
+ -- let $j = \v -> && v E
+ -- in simplExpr (case x of { T -> F; F -> T })
+ -- (ArgOf (\r -> $j r)
+ -- And after simplifying more we get
+ --
+ -- let $j = \v -> && v E
+ -- in case of { T -> $j F; F -> $j T }
+ -- Which is a Very Bad Thing
+ --
+ -- The desire not to duplicate is the entire reason that
+ -- mkDupableCont returns a pair of continuations.
+ --
+ -- The original plan had:
+ -- e.g. (...strict-fn...) [...hole...]
-- ==>
-- let $j = \a -> ...strict-fn...
-- in $j [...hole...]
- -- Build the join Id and continuation
- -- We give it a "$j" name just so that for later amusement
- -- we can identify any join points that don't end up as let-no-escapes
- -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
- newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
- newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
-
- cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
- let
- cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
- join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
- in
-
- tick (CaseOfCase join_id) `thenSmpl_`
- -- Want to tick here so that we go round again,
- -- and maybe copy or inline the code;
- -- not strictly CaseOf Case
-
- returnSmpl (unitFloat env join_id join_rhs,
- ArgOf OkToDup is_rhs cont_ty cont_fn)
-
-mkDupableCont env ty (ApplyTo _ arg se cont)
+mkDupableCont env (ApplyTo _ arg se cont)
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
-- in [...hole...] a
- mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
+
+ mkDupableCont env cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
- simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
if exprIsDupable arg' then
- returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
+ 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,
-- Not strictly CaseOfCase, but never mind
returnSmpl (unitFloat env arg_id arg',
- ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
+ (ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) dup_cont,
+ nondup_cont))
-- But what if the arg should be case-bound?
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
-mkDupableCont env ty (Select _ case_bndr alts se cont)
+mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
-- let ji = \xij -> ei
let
alt_env = setInScope se env
in
- prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
+ prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, (dup_cont, nondup_cont)) ->
addFloats alt_env floats1 $ \ alt_env ->
simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- In the new alts we build, we have the new case binder, so it must retain
-- its deadness.
- mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
+ mkDupableAlts alt_env case_bndr' alts dup_cont `thenSmpl` \ (floats2, alts') ->
addFloats alt_env floats2 $ \ alt_env ->
- returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
- (mkBoringStop (contResultType cont)))
+ returnSmpl (emptyFloats alt_env,
+ (Select OkToDup case_bndr' alts' (zapSubstEnv se)
+ (mkBoringStop (contResultType dup_cont)),
+ nondup_cont))
mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
-> SimplM (FloatsWith [InAlt])
-- (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") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
- -- Notice the funky mkPiType. If the contructor has existentials
+ newId (encodeFS FSLIT("$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.
-- Example: Suppose we have
-- in
-- case (case e of ...) of
-- C t xs::[t] -> j t xs
-
let
-- We make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so