Add new debugging flag -dinline-check

This flag reports a summary of the inlining decision for identifiers
prefixed by the flag's argument.

For example, `-dinline-check foo` will report why definitions whose
prefix is `foo` are inlined or not.

Previously the only way to get this information was to pass a
combination of `-dverbose-core2core` and `-ddump-inlinings`.

This combination led to a log of 12 million lines in a module of about
200 lines I recently had to apply it to. This flag provides a much more
direct way to find the occurence you care about.

Reviewers: osa1, dfeuer, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4458

2 files changed, 19 insertions, 9 deletions

diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 2e2b7a3b48..c1f78926e1 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -65,8 +65,10 @@ import Bag
 import Util
 import Outputable
 import ForeignCall
+import Name
 
 import qualified Data.ByteString as BS
+import Data.List
 
 {-
 ************************************************************************
@@ -1155,14 +1157,18 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
           | active_unfolding -> tryUnfolding dflags id lone_variable
                                     arg_infos cont_info unf_template is_top
                                     is_wf is_exp guidance
-          | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing
+          | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing
         NoUnfolding      -> Nothing
         BootUnfolding    -> Nothing
         OtherCon {}      -> Nothing
         DFunUnfolding {} -> Nothing     -- Never unfold a DFun
 
-traceInline :: DynFlags -> String -> SDoc -> a -> a
-traceInline dflags str doc result
+traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a
+traceInline dflags inline_id str doc result
+ | Just prefix <- inlineCheck dflags
+ =  if prefix `isPrefixOf` occNameString (getOccName inline_id)
+      then pprTrace str doc result
+      else result
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
  = pprTrace str doc result
  | otherwise
@@ -1175,25 +1181,25 @@ tryUnfolding dflags id lone_variable
              arg_infos cont_info unf_template is_top
              is_wf is_exp guidance
  = case guidance of
-     UnfNever -> traceInline dflags str (text "UnfNever") Nothing
+     UnfNever -> traceInline dflags id str (text "UnfNever") Nothing
 
      UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
         | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)
                 -- See Note [INLINE for small functions (3)]
-        -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)
         | otherwise
-        -> traceInline dflags str (mk_doc some_benefit empty False) Nothing
+        -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing
         where
           some_benefit = calc_some_benefit uf_arity
           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
 
      UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
         | ufVeryAggressive dflags
-        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | is_wf && some_benefit && small_enough
-        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | otherwise
-        -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing
         where
           some_benefit = calc_some_benefit (length arg_discounts)
           extra_doc = text "discounted size =" <+> int discounted_size
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 0d018a7ec4..ba4d281bf0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -833,6 +833,7 @@ data DynFlags = DynFlags {
   maxSimplIterations    :: Int,         -- ^ Max simplifier iterations
   maxPmCheckIterations  :: Int,         -- ^ Max no iterations for pm checking
   ruleCheck             :: Maybe String,
+  inlineCheck           :: Maybe String, -- ^ A prefix to report inlining decisions about
   strictnessBefore      :: [Int],       -- ^ Additional demand analysis
 
   parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel
@@ -1730,6 +1731,7 @@ defaultDynFlags mySettings myLlvmTargets =
         maxSimplIterations      = 4,
         maxPmCheckIterations    = 2000000,
         ruleCheck               = Nothing,
+        inlineCheck             = Nothing,
         maxRelevantBinds        = Just 6,
         maxValidSubstitutions   = Just 6,
         maxRefSubstitutions     = Just 6,
@@ -3403,6 +3405,8 @@ dynamic_flags_deps = [
       (noArg (\d -> d { liberateCaseThreshold = Nothing }))
   , make_ord_flag defFlag "drule-check"
       (sepArg (\s d -> d { ruleCheck = Just s }))
+  , make_ord_flag defFlag "dinline-check"
+      (sepArg (\s d -> d { inlineCheck = Just s }))
   , make_ord_flag defFlag "freduction-depth"
       (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))
   , make_ord_flag defFlag "fconstraint-solver-iterations"