-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
contIsDupable, contResultType,
- countValArgs, countArgs,
+ countValArgs, countArgs, pushContArgs,
mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
+ getContArgs, interestingCallContext, interestingArg, isStrictType
) where
opt_SimplCaseMerge, opt_UF_UpdateInPlace
)
import CoreSyn
-import CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
+import CoreUtils ( cheapEqExpr, exprType,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
findDefault, exprOkForSpeculation, exprIsValue
)
-import Subst ( InScopeSet, mkSubst, substExpr )
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idName,
+import Id ( Id, idType, idInfo,
mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
- idUnfolding, idNewStrictness,
- mkLocalId, idInfo
+ idUnfolding, idNewStrictness
)
-import Name ( setNameUnique )
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Type ( Type, mkForAllTys, seqType,
+import Type ( Type, seqType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
- isUnLiftedType, splitRepFunTys, isStrictType
+ splitRepFunTys, isStrictType
)
import OccName ( UserFS )
import TyCon ( tyConDataConsIfAvailable, isDataTyCon )
import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
-import VarEnv ( SubstEnv )
-import VarSet ( mkVarSet, varSetElems, intersectVarSet )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
contIsDupable other = False
-------------------
-discardInline :: SimplCont -> SimplCont
-discardInline (InlinePlease cont) = cont
-discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
-discardInline cont = cont
-
--------------------
discardableCont :: SimplCont -> Bool
discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
countArgs :: SimplCont -> Int
countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
countArgs other = 0
+
+-------------------
+pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+-- Pushes args with the specified environment
+pushContArgs env [] cont = cont
+pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
\end{code}
other -> vanilla_stricts -- Not enough args, or no strictness
-------------------
-interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
+interestingArg :: OutExpr -> Bool
-- An argument is interesting if it has *some* structure
-- We are here trying to avoid unfolding a function that
-- is applied only to variables that have no unfolding
-- (i.e. they are probably lambda bound): f x y z
-- There is little point in inlining f here.
-interestingArg in_scope arg subst
- = analyse (substExpr (mkSubst in_scope subst) arg)
- -- 'analyse' only looks at the top part of the result
- -- and substExpr is lazy, so this isn't nearly as brutal
- -- as it looks.
- where
- analyse (Var v) = hasSomeUnfolding (idUnfolding v)
- -- Was: isValueUnfolding (idUnfolding v')
- -- But that seems over-pessimistic
- analyse (Type _) = False
- analyse (App fn (Type _)) = analyse fn
- analyse (Note _ a) = analyse a
- analyse other = True
+interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
+ -- Was: isValueUnfolding (idUnfolding v')
+ -- But that seems over-pessimistic
+interestingArg (Type _) = False
+interestingArg (App fn (Type _)) = interestingArg fn
+interestingArg (Note _ a) = interestingArg a
+interestingArg other = True
-- Consider let x = 3 in f x
-- The substitution will contain (x -> ContEx 3), and we want to
-- to say that x is an interesting argument.
import SimplUtils ( mkCase, mkLam, newId,
simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
- mkStop, mkBoringStop,
- contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
+ mkStop, mkBoringStop, pushContArgs,
+ contResultType, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
import Var ( mustHaveLocalBinding )
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 ->
-
-- 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
| 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}
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
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}
-- 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 / commitdiff