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

6 files changed, 72 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"
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index c6d90e642d..ada00185c7 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -288,6 +288,20 @@ subexpression elimination pass.
     ``-drule-check=SPEC`` will check whether there are any applications which
     might be subject to a rule created by specialisation.
 
+.. ghc-flag:: -dinline-check=⟨str⟩
+    :shortdesc: Dump information about inlining decisions
+    :type: dynamic
+
+    This flag is useful for debugging why a definition is not inlined.
+
+    When a string is passed to this flag we report information
+    about all functions whose name shares a prefix with the string.
+
+    For example, if you are inspecting the core of your program and you observe
+    that ``foo`` is not being inlined. You can pass ``-dinline-check foo`` and
+    you will see a report about why ``foo`` is not inlined.
+
+
 .. ghc-flag:: -ddump-vect
     :shortdesc: Dump vectoriser input and output
     :type: dynamic
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 976a3169d8..c07badb5f9 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -273,3 +273,4 @@ test('json', normal, compile_fail, ['-ddump-json'])
 test('json2', normal, compile, ['-ddump-types -ddump-json'])
 test('T13604', [], run_command, ['$MAKE -s --no-print-directory T13604'])
 test('T13604a', [], run_command, ['$MAKE -s --no-print-directory T13604a'])
+test('inline-check', normal, compile, ['-dinline-check foo -O -ddebug-output'])
diff --git a/testsuite/tests/driver/inline-check.hs b/testsuite/tests/driver/inline-check.hs
new file mode 100644
index 0000000000..83112e1226
--- /dev/null
+++ b/testsuite/tests/driver/inline-check.hs
@@ -0,0 +1,12 @@
+module InlineCheck where
+
+foo = (+1)
+
+foo1 = (+1)
+{-# NOINLINE foo1 #-}
+
+qux = foo 3
+
+qux1 = foo1 3
+
+too = qux
diff --git a/testsuite/tests/driver/inline-check.stderr b/testsuite/tests/driver/inline-check.stderr
new file mode 100644
index 0000000000..5bf9edaf24
--- /dev/null
+++ b/testsuite/tests/driver/inline-check.stderr
@@ -0,0 +1,26 @@
+Considering inlining: foo
+  arg infos [ValueArg]
+  interesting continuation RhsCtxt
+  some_benefit True
+  is exp: True
+  is work-free: True
+  guidance IF_ARGS [0] 30 0
+  discounted size = 10
+  ANSWER = YES
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Inactive unfolding: foo1
+Considering inlining: foo
+  arg infos []
+  interesting continuation RhsCtxt
+  some_benefit False
+  is exp: True
+  is work-free: True
+  guidance ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+  ANSWER = NO
+Inactive unfolding: foo1