)
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId,
- simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
- SimplCont(..), DupFlag(..), LetRhsFlag(..),
- mkStop, mkBoringStop,
- contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
+ simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
+ simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ mkStop, mkBoringStop, pushContArgs,
+ contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
import Var ( mustHaveLocalBinding )
import Id ( Id, idType, idInfo, idArity, isDataConId,
idUnfolding, setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- setIdOccInfo,
+ setIdOccInfo, isLocalId,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isLoopBreaker,
-- 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') ->
+ simplTopBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
| 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') ->
+ simplLetBndr 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 ->
-
-- Now complete the binding and simplify the body
- completeNonRecX env bndr bndr' rhs2 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
- simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLetBndr env bndr `thenSmpl` \ (env, bndr') ->
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
| 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
+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
- = completeLazyBind env NotTopLevel
- old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ = mkAtomicArgs is_strict
+ True {- OK to float unlifted -}
+ new_rhs `thenSmpl` \ (aux_binds, rhs2) ->
+
+ -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ addAtomicBindsE env aux_binds $ \ env ->
+ completeLazyBind env NotTopLevel
+ old_bndr new_bndr rhs2 `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
\end{code}
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') ->
+ = simplRecBndrs 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
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 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
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 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) ->
(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 "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "After: " <+> pprCoreExpr rule_rhs])
else
id) $
Nothing -> -- No rules
+ -- Next, look for an inlining
+ let
+ arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
+
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
+
+ active_inline = activeInline env var
+ 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}
[] -> alts
other -> [alt | alt@(con,_,_) <- alts,
not (con `elem` impossible_cons)]
+
+ -- handled_cons are handled either by the context,
+ -- or by an alternative in this case
+ handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
in
-- Deal with the case binder, and prepare the continuation;
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
+ simplAlts alt_env zap_occ_info handled_cons
case_bndr' better_alts cont' `thenSmpl` \ alts' ->
-- Put the case back together
- mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
+ mkCase scrut handled_cons 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
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
-- 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
projects / ghc-hetmet.git / blobdiff