-ppr_uf_Expr in_scopes (Case scrutinee alts)
- = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
- pp_alts alts, ppChar '}']
- where
- pp_alts (AlgAlts alts deflt)
- = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt]
- pp_alts (PrimAlts alts deflt)
- = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
-
- pp_alg (con, params, rhs)
- = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
- ppIntersperse ppSP (map ppr_uf_Binder params),
- ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
-
- pp_prim (lit, rhs)
- = ppBesides [ppr ppr_Unfolding lit,
- ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
-
- pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
- pp_deflt (BindDefault binder rhs)
- = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
- ppr_uf_Expr (in_scopes `add1` binder) rhs]
-
-ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
- = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
- ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (Let (Rec pairs) body)
- = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
- ppStr "} in ", ppr_uf_Expr new_in_scopes body]
+\begin{code}
+callSiteInline :: DynFlags
+ -> Bool -- True <=> the Id can be inlined
+ -> Bool -- 'inline' note at call site
+ -> OccInfo
+ -> Id -- The Id
+ -> [Bool] -- One for each value arg; True if it is interesting
+ -> Bool -- True <=> continuation is interesting
+ -> Maybe CoreExpr -- Unfolding, if any
+
+
+callSiteInline dflags active_inline inline_call occ id arg_infos interesting_cont
+ = case idUnfolding id of {
+ NoUnfolding -> Nothing ;
+ OtherCon cs -> Nothing ;
+
+ CompulsoryUnfolding unf_template -> Just unf_template ;
+ -- CompulsoryUnfolding => there is no top-level binding
+ -- for these things, so we must inline it.
+ -- Only a couple of primop-like things have
+ -- compulsory unfoldings (see MkId.lhs).
+ -- We don't allow them to be inactive
+
+ CoreUnfolding unf_template is_top is_value is_cheap guidance ->
+
+ let
+ result | yes_or_no = Just unf_template
+ | otherwise = Nothing
+
+ n_val_args = length arg_infos
+
+ yes_or_no
+ | not active_inline = False
+ | otherwise = case occ of
+ IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
+ IAmALoopBreaker -> False
+ --OneOcc in_lam _ _ -> (not in_lam || is_cheap) && consider_safe True
+ other -> is_cheap && consider_safe False
+ -- we consider even the once-in-one-branch
+ -- occurrences, because they won't all have been
+ -- caught by preInlineUnconditionally. In particular,
+ -- if the occurrence is once inside a lambda, and the
+ -- rhs is cheap but not a manifest lambda, then
+ -- pre-inline will not have inlined it for fear of
+ -- invalidating the occurrence info in the rhs.
+
+ consider_safe once
+ -- consider_safe decides whether it's a good idea to
+ -- inline something, given that there's no
+ -- work-duplication issue (the caller checks that).
+ | inline_call = True
+
+ | otherwise
+ = case guidance of
+ UnfoldNever -> False
+ UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
+
+ | enough_args && size <= (n_vals_wanted + 1)
+ -- Inline unconditionally if there no size increase
+ -- Size of call is n_vals_wanted (+1 for the function)
+ -> True
+
+ | otherwise
+ -> some_benefit && small_enough
+
+ where
+ some_benefit = or arg_infos || really_interesting_cont ||
+ (not is_top && ({- once || -} (n_vals_wanted > 0 && enough_args)))
+ -- [was (once && not in_lam)]
+ -- If it occurs more than once, there must be
+ -- something interesting about some argument, or the
+ -- result context, to make it worth inlining
+ --
+ -- If a function has a nested defn we also record
+ -- some-benefit, on the grounds that we are often able
+ -- to eliminate the binding, and hence the allocation,
+ -- for the function altogether; this is good for join
+ -- points. But this only makes sense for *functions*;
+ -- inlining a constructor doesn't help allocation
+ -- unless the result is scrutinised. UNLESS the
+ -- constructor occurs just once, albeit possibly in
+ -- multiple case branches. Then inlining it doesn't
+ -- increase allocation, but it does increase the
+ -- chance that the constructor won't be allocated at
+ -- all in the branches that don't use it.
+
+ enough_args = n_val_args >= n_vals_wanted
+ really_interesting_cont | n_val_args < n_vals_wanted = False -- Too few args
+ | n_val_args == n_vals_wanted = interesting_cont
+ | otherwise = True -- Extra args
+ -- really_interesting_cont tells if the result of the
+ -- call is in an interesting context.
+
+ small_enough = (size - discount) <= opt_UF_UseThreshold
+ discount = computeDiscount n_vals_wanted arg_discounts res_discount
+ arg_infos really_interesting_cont
+
+ in
+ if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Considering inlining"
+ (ppr id <+> vcat [text "active:" <+> ppr active_inline,
+ text "occ info:" <+> ppr occ,
+ text "arg infos" <+> ppr arg_infos,
+ text "interesting continuation" <+> ppr interesting_cont,
+ text "is value:" <+> ppr is_value,
+ text "is cheap:" <+> ppr is_cheap,
+ text "guidance" <+> ppr guidance,
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
+ result
+ else
+ result
+ }
+
+computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
+computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
+ -- We multiple the raw discounts (args_discount and result_discount)
+ -- ty opt_UnfoldingKeenessFactor because the former have to do with
+ -- *size* whereas the discounts imply that there's some extra
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions)
+ -- by inlining.
+
+ -- we also discount 1 for each argument passed, because these will
+ -- reduce with the lambdas in the function (we count 1 for a lambda
+ -- in size_up).
+ = 1 + -- Discount of 1 because the result replaces the call
+ -- so we count 1 for the function itself
+ length (take n_vals_wanted arg_infos) +
+ -- Discount of 1 for each arg supplied, because the
+ -- result replaces the call
+ round (opt_UF_KeenessFactor *
+ fromIntegral (arg_discount + result_discount))