- = 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
- --
- -- Note [Self-recursive rules]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- 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
- ; rules <- getRules
- ; let in_scope = getInScope env
- maybe_rule = case activeRule dflags 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_rule_firings 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 { 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
+ --
+ -- Note [Rules for recursive functions]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- 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
+ ; rules <- getRules
+ ; let in_scope = getInScope env
+ maybe_rule = case activeRule dflags 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) -> do
+ tick (RuleFired (ru_name rule))
+ (if dopt Opt_D_dump_rule_firings 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 call_cont
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline var
+ (null args) 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" ++ showSDoc (ppr var)) (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)
+ (mkArgInfo var n_val_args call_cont) cont