- 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: " $$ nest 2 (ppr unfolding),
- text "Cont: " <+> ppr call_cont])
- else
- id) $
- simplExprF env unfolding (pushContArgs args call_cont)
-
- ;
- Nothing -> -- No inlining!
-
- -- Done
- rebuild env (mkApps (Var var) args) call_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, Maybe 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 (arg, Nothing, _) cont_ty thing_inside
- = thing_inside env arg -- Already simplified
-
-simplifyArg env fn_ty has_rules (Type ty_arg, Just 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, Just 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.
-
-Note [Float coercions]
-~~~~~~~~~~~~~~~~~~~~~~
-When we find the binding
- x = e `cast` co
-we'd like to transform it to
- x' = e
- x = x `cast` co -- A trivial binding
-There's a chance that e will be a constructor application or function, or something
-like that, so moving the coerion to the usage site may well cancel the coersions
-and lead to further optimisation. Example:
-
- data family T a :: *
- data instance T Int = T Int
-
- foo :: Int -> Int -> Int
- foo m n = ...
- where
- x = T m
- go 0 = 0
- go n = case x of { T m -> go (n-m) }
- -- This case should optimise
-
-\begin{code}
-mkAtomicArgsE :: SimplEnv
- -> Bool -- A strict binding
- -> OutExpr -- The rhs
- -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
- -- Consumer for the simpler rhs
- -> SimplM FloatsWithExpr
-
-mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
- | not (exprIsTrivial rhs)
- -- Note [Float coersions]
- -- See also Note [Take care] below
- = do { id <- newId FSLIT("a") (exprType rhs)
- ; completeNonRecX env False id id rhs $ \ env ->
- thing_inside env (Cast (substExpr env (Var id)) co) }
-
-mkAtomicArgsE env is_strict rhs thing_inside
- | (Var fun, args) <- collectArgs rhs, -- It's an application
- isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
- = go env (Var fun) args
-
- | otherwise = thing_inside env rhs
-
- where
- go env fun [] = thing_inside env fun
-
- go env fun (arg : args)
- | exprIsTrivial arg -- Easy case
- || no_float_arg -- Can't make it atomic
- = go env (App fun arg) args
-
- | otherwise
- = do { arg_id <- newId FSLIT("a") arg_ty
- ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
- go env (App fun (substExpr env (Var arg_id))) args }
- -- Note [Take care]:
- -- If completeNonRecX was to do a postInlineUnconditionally
- -- (undoing the effect of introducing the let-binding), we'd find arg_id had
- -- no binding; hence the substExpr. This happens if we see
- -- C (D x `cast` g)
- -- Then we start by making a variable a1, thus
- -- let a1 = D x `cast` g in C a1
- -- But then we deal with the rhs of a1, getting
- -- let a2 = D x, a1 = a1 `cast` g in C a1
- -- And now the preInlineUnconditionally kicks in, and we substitute for a1
-
- where
- arg_ty = exprType arg
- no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
-
-
--- Old code: consider rewriting to be more like mkAtomicArgsE
-
-mkAtomicArgs :: 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 ok_float_unlifted (Cast rhs co)
- | not (exprIsTrivial rhs)
- -- Note [Float coersions]
- = do { id <- newId FSLIT("a") (exprType rhs)
- ; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs
- ; return (binds `snocOL` (id, rhs'), Cast (Var id) co) }
-
-mkAtomicArgs 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