- in
- case maybe_inline of {
- Just unfolding -- There is an inlining!
- -> tick (UnfoldingDone var) `thenSmpl_`
- (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 "Cont: " <+> ppr call_cont])
- else
- id) $
- makeThatCall env var unfolding args call_cont
-
- ;
- Nothing -> -- No inlining!
-
- -- Done
- 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 (extendTvSubst env bndr 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}
-
-
-%************************************************************************
-%* *
-\subsection{Arguments}
-%* *
-%************************************************************************
-
-\begin{code}
----------------------------------------------------------
--- Simplifying the arguments of a call
-
-simplifyArgs :: SimplEnv
- -> OutType -- Type of the function
- -> Bool -- True if the fn has RULES
- -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
- -> OutType -- Type of the continuation
- -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
- -> SimplM FloatsWithExpr
-
--- [CPS-like because of strict arguments]
-
--- Simplify the arguments to a call.
--- This part of the simplifier may break the no-shadowing invariant
--- Consider
--- f (...(\a -> e)...) (case y of (a,b) -> e')
--- where f is strict in its second arg
--- If we simplify the innermost one first we get (...(\a -> e)...)
--- Simplifying the second arg makes us float the case out, so we end up with
--- case y of (a,b) -> f (...(\a -> e)...) e'
--- So the output does not have the no-shadowing invariant. However, there is
--- no danger of getting name-capture, because when the first arg was simplified
--- we used an in-scope set that at least mentioned all the variables free in its
--- static environment, and that is enough.
---
--- We can't just do innermost first, or we'd end up with a dual problem:
--- case x of (a,b) -> f e (...(\a -> e')...)
---
--- I spent hours trying to recover the no-shadowing invariant, but I just could
--- not think of an elegant way to do it. The simplifier is already knee-deep in
--- continuations. We have to keep the right in-scope set around; AND we have
--- to get the effect that finding (error "foo") in a strict arg position will
--- discard the entire application and replace it with (error "foo"). Getting
--- all this at once is TOO HARD!
-
-simplifyArgs env fn_ty has_rules args cont_ty thing_inside
- = go env fn_ty args thing_inside
- where
- go env fn_ty [] thing_inside = thing_inside env []
- go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty has_rules arg cont_ty $ \ env arg' ->
- go env (applyTypeToArg fn_ty arg') args $ \ env args' ->
- thing_inside env (arg':args')
-
-simplifyArg env fn_ty has_rules (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 fn_ty has_rules (val_arg, arg_se, is_strict) cont_ty thing_inside
- | is_strict
- = 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
- (mkLazyArgStop arg_ty has_rules) `thenSmpl` \ arg1 ->
- thing_inside env arg1
- where
- arg_ty = funArgTy fn_ty
-
-
-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,
- -- returns an expression of type cont_ty
- -- The env passed to this continuation is the
- -- env of the call, plus any new in-scope variables
- -> SimplM FloatsWithExpr -- An expression of type cont_ty
-
-simplStrictArg is_rhs call_env arg arg_env arg_ty cont_ty thing_inside
- = simplExprF (setInScope arg_env call_env) arg
- (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
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{mkAtomicArgs}
-%* *
-%************************************************************************
-
-mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
-constructor application and, if so, converts it to ANF, so that the
-resulting thing can be inlined more easily. Thus
- x = (f a, g b)
-becomes
- t1 = f a
- t2 = g b
- x = (t1,t2)
-
-There are three sorts of binding context, specified by the two
-boolean arguments
-
-Strict
- OK-unlifted
-
-N N Top-level or recursive Only bind args of lifted type
-
-N Y Non-top-level and non-recursive, Bind args of lifted type, or
- but lazy unlifted-and-ok-for-speculation
-
-Y Y Non-top-level, non-recursive, Bind all args
- and strict (demanded)
-
-
-For example, given
-
- x = MkC (y div# z)
-
-there is no point in transforming to
-
- x = case (y div# z) of r -> MkC r
-
-because the (y div# z) can't float out of the let. But if it was
-a *strict* let, then it would be a good thing to do. Hence the
-context information.
-
-\begin{code}
-mkAtomicArgs :: Bool -- A strict binding
- -> 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
- | (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