--- Preparing arguments for a call
-
-prepareArgs :: SDoc -- Error message info
- -> OutType -> ([Demand],Bool) -> SimplCont
- -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-
-prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside
- = go [] demands orig_fun_ty orig_cont
- where
- not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont
- -- "No strictness info" is signalled by an infinite list of wwLazy
-
- demands | not_enough_args = repeat wwLazy -- Not enough args, or no strictness
- | result_bot = fun_demands -- Enough args, and function returns bottom
- | otherwise = fun_demands ++ repeat wwLazy -- Enough args and function does not return bottom
- -- NB: demands is finite iff enough args and result_bot is True
-
- -- Main game plan: loop through the arguments, simplifying
- -- each of them in turn. We carry with us a list of demands,
- -- and the type of the function-applied-to-earlier-args
-
- -- Type argument
- go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
- = getInScope `thenSmpl` \ in_scope ->
- let
- ty_arg' = substTy (mkSubst in_scope se) ty_arg
- res_ty = applyTy fun_ty ty_arg'
- in
- go (Type ty_arg' : acc) ds res_ty cont
-
- -- Value argument
- go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont)
- = case splitFunTy_maybe fun_ty of {
- Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont)
- (thing_inside (reverse acc) cont) ;
- Just (arg_ty, res_ty) ->
- simplArg arg_ty d val_arg se (contResultType cont) $ \ arg' ->
- go (arg':acc) ds res_ty cont }
-
- -- We've run out of demands, which only happens for functions
- -- we *know* now return bottom
- -- This deals with
- -- * case (error "hello") of { ... }
- -- * (error "Hello") arg
- -- * f (error "Hello") where f is strict
- -- etc
- go acc [] fun_ty cont = tick_case_of_error cont `thenSmpl_`
- thing_inside (reverse acc) (discardCont cont)
-
- -- We're run out of arguments
- go acc ds fun_ty cont = thing_inside (reverse acc) cont
-
--- Boring: we must only record a tick if there was an interesting
--- continuation to discard. If not, we tick forever.
-tick_case_of_error (Stop _) = returnSmpl ()
-tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
-tick_case_of_error other = tick BottomFound
-
----------------------------------------------------------
--- Dealing with a call
-
-completeCall black_list_fn in_scope var args cont
- -- Look for rules or specialisations that match
- -- Do this *before* trying inlining because some functions
- -- have specialisations *and* are strict; we don't want to
- -- inline the wrapper of the non-specialised thing... better
- -- to call the specialised thing instead.
- | maybeToBool maybe_rule_match
- = tick (RuleFired rule_name) `thenSmpl_`
- zapSubstEnv (completeApp rule_rhs rule_args cont)
- -- See note below about zapping the substitution here
-
- -- Look for an unfolding. There's a binding for the
- -- thing, but perhaps we want to inline it anyway
- | maybeToBool maybe_inline
- = tick (UnfoldingDone var) `thenSmpl_`
- zapSubstEnv (completeInlining var unf_template args (discardInlineCont cont))
- -- The template is already simplified, so don't re-substitute.
- -- This is VITAL. Consider
- -- let x = e in
- -- let y = \z -> ...x... in
- -- \ x -> ...y...
- -- We'll clone the inner \x, adding x->x' in the id_subst
- -- Then when we inline y, we must *not* replace x by x' in
- -- the inlined copy!!
-
- | otherwise -- Neither rule nor inlining
- = rebuild (mkApps (Var var) args) cont
-
- where
- ---------- Unfolding stuff
- maybe_inline = callSiteInline black_listed inline_call
- var args interesting_cont
- Just unf_template = maybe_inline
- interesting_cont = contIsInteresting cont
- inline_call = contIsInline cont
- black_listed = black_list_fn var
-
- ---------- Specialisation stuff
- maybe_rule_match = lookupRule in_scope var args
- Just (rule_name, rule_rhs, rule_args) = maybe_rule_match
-
-
--- First a special case
--- Don't actually inline the scrutinee when we see
--- case x of y { .... }
--- and x has unfolding (C a b). Why not? Because
--- we get a silly binding y = C a b. If we don't
--- inline knownCon can directly substitute x for y instead.
-completeInlining var (Con con con_args) args (Select _ bndr alts se cont)
- | conOkForAlt con
- = ASSERT( null args )
- knownCon (Var var) con con_args bndr alts se cont
-
--- Now the normal case
-completeInlining var unfolding args cont
- = completeApp unfolding args cont
-
--- completeApp applies a new InExpr (from an unfolding or rule)
--- to an *already simplified* set of arguments
-completeApp :: InExpr -- (\xs. body)
- -> [OutExpr] -- Args; already simplified
- -> SimplCont -- What to do with result of applicatoin
- -> SimplM OutExprStuff
-completeApp fun args cont
- = go fun args
- where
- zap_it = mkLamBndrZapper fun (length args)
- cont_ty = contResultType cont
-
- -- These equations are very similar to simplLam and simplBeta combined,
- -- except that they deal with already-simplified arguments
-
- -- Type argument
- go (Lam bndr fun) (Type ty:args) = tick (BetaReduction bndr) `thenSmpl_`
- extendSubst bndr (DoneTy ty)
- (go fun args)
-
- -- Value argument
- go (Lam bndr fun) (arg:args)
- | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
- = tick (BetaReduction bndr) `thenSmpl_`
- tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst bndr (DoneEx arg)
- (go fun args)
- | otherwise
- = tick (BetaReduction bndr) `thenSmpl_`
- simplBinder zapped_bndr ( \ bndr' ->
- completeBeta zapped_bndr bndr' arg $
- go fun args
- )
- where
- zapped_bndr = zap_it bndr
-
- -- Consumed all the lambda binders or args
- go fun args = simplExprF fun (pushArgs emptySubstEnv args cont)
-
-
------------ costCentreOk
--- costCentreOk checks that it's ok to inline this thing
--- The time it *isn't* is this:
+-- 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)
+ -> 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.