- = do { dflags <- getDOptsSmpl
- ; let (args,call_cont) = contArgs cont
- -- The args are OutExprs, obtained by *lazily* substituting
- -- in the args found in cont. These args are only examined
- -- to limited depth (unless a rule fires). But we must do
- -- the substitution; rule matching on un-simplified args would
- -- be bogus
-
- ------------- First try rules ----------------
- -- Do this before trying inlining. Some functions have
- -- rules *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.
- --
- -- 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
- -- rather like an extra equation for the function:
- -- RULE: f (g x) y = x+y
- -- Eqn: f a y = a-y
- --
- -- But it's too drastic to disable rules for loop breakers.
- -- Even the foldr/build rule would be disabled, because foldr
- -- is recursive, and hence a loop breaker:
- -- foldr k z (build g) = g k z
- -- So it's up to the programmer: rules can cause divergence
- ; let in_scope = getInScope env
- rules = getRules env
- maybe_rule = case activeRule env of
- Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope
- rules var args
- ; case maybe_rule of {
- Just (rule, rule_rhs) ->
- tick (RuleFired (ru_name rule)) `thenSmpl_`
- (if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Rule fired" (vcat [
- text "Rule:" <+> ftext (ru_name rule),
- text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
- text "After: " <+> pprCoreExpr rule_rhs,
- text "Cont: " <+> ppr call_cont])
- else
- id) $
- simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
- -- The ruleArity says how many args the rule consumed
-
- ; Nothing -> do -- No rules
-
- ------------- Next try inlining ----------------
- { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
- n_val_args = length arg_infos
- interesting_cont = interestingCallContext (notNull args)
- (notNull arg_infos)
- call_cont
- active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline
- var arg_infos interesting_cont
- ; case maybe_inline of {
- Just unfolding -- There is an inlining!
- -> do { tick (UnfoldingDone var)
- ; (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 cont }
-
- ; Nothing -> -- No inlining!
-
- ------------- No inlining! ----------------
- -- Next, look for rules or specialisations that match
- --
- rebuildCall env (Var var) (idType var)
- (mkArgInfo var n_val_args call_cont) cont
- }}}}
+ = do { ------------- Try inlining ----------------
+ dflags <- getDOptsSmpl
+ ; let (lone_variable, arg_infos, call_cont) = contArgs cont
+ -- The args are OutExprs, obtained by *lazily* substituting
+ -- in the args found in cont. These args are only examined
+ -- to limited depth (unless a rule fires). But we must do
+ -- the substitution; rule matching on un-simplified args would
+ -- be bogus
+
+ n_val_args = length arg_infos
+ interesting_cont = interestingCallContext call_cont
+ unfolding = activeUnfolding env var
+ maybe_inline = callSiteInline dflags var unfolding
+ lone_variable arg_infos interesting_cont
+ ; case maybe_inline of {
+ Just expr -- There is an inlining!
+ -> do { tick (UnfoldingDone var)
+ ; trace_inline dflags expr cont $
+ simplExprF (zapSubstEnv env) expr cont }
+
+ ; Nothing -> do -- No inlining!
+
+ { rule_base <- getSimplRules
+ ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
+ ; rebuildCall env info cont
+ }}}
+ where
+ trace_inline dflags unfolding cont stuff
+ | not (dopt Opt_D_dump_inlinings dflags) = stuff
+ | not (dopt Opt_D_verbose_core2core dflags)
+ = if isExternalName (idName var) then
+ pprTrace "Inlining done:" (ppr var) stuff
+ else stuff
+ | otherwise
+ = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+ (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
+ text "Cont: " <+> ppr cont])
+ stuff