[commit: ghc] ghc-8.2: Be a bit more eager to inline in a strict context (f9aa658)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/f9aa658ba8293832a6622323b58063a379b16901/ghc

>---------------------------------------------------------------

commit f9aa658ba8293832a6622323b58063a379b16901
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Apr 27 17:42:01 2017 +0100

    Be a bit more eager to inline in a strict context
    
    If we see f (g x), and f is strict, we want to be a bit more eager to
    inline g, because it may well expose an eval (on x perhaps) that can
    be eliminated or shared.
    
    I saw this in nofib boyer2, function RewriteFuns.onewayunify1.  It
    showed up as a consequence of the preceding patch that makes the
    simplifier do less work (Trac #13379).  We had
    
       f d (g x)
    
    where f was a class-op. Previously we simplified both d and
    (g x) with a RuleArgCtxt (making g a bit more eager to inline).
    But now we simplify only d that way, then fire the rule, and
    only then simplify (g x).  Firing the rule produces a strict
    funciion, so we want to make a strict function encourage
    inlining a bit.
    
    (cherry picked from commit 29d88ee173bc9b04245a33d5268dda032f5dc331)


>---------------------------------------------------------------

f9aa658ba8293832a6622323b58063a379b16901
 compiler/simplCore/SimplUtils.hs                   |  2 ++
 compiler/simplCore/Simplify.hs                     | 26 +++++++++++++++++-----
 .../tests/simplCore/should_compile/T12603.stdout   |  2 +-
 3 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index 3ebdae4..a2c7b8b 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -551,6 +551,8 @@ interestingCallContext cont
         -- If f has an INLINE prag we need to give it some
         -- motivation to inline. See Note [Cast then apply]
         -- in CoreUnfold
+
+    interesting (StrictArg _ BoringCtxt _)  = RhsCtxt
     interesting (StrictArg _ cci _)         = cci
     interesting (StrictBind {})             = BoringCtxt
     interesting (Stop _ cci)                = cci
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 74f8e0e..66208b3 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1801,7 +1801,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
   | str                 -- Strict argument
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
     simplExprF (arg_se `setFloats` env) arg
-               (StrictArg info' cci cont)
+               (StrictArg info' cci_strict cont)
                 -- Note [Shadowing]
 
   | otherwise                           -- Lazy argument
@@ -1810,13 +1810,27 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
         -- have to be very careful about bogus strictness through
         -- floating a demanded let.
   = do  { arg' <- simplExprC (arg_se `setInScopeAndZapFloats` env) arg
-                             (mkLazyArgStop (funArgTy fun_ty) cci)
+                             (mkLazyArgStop arg_ty cci_lazy)
         ; rebuildCall env (addValArgTo info' arg') cont }
   where
-    info' = info { ai_strs = strs, ai_discs = discs }
-    cci | encl_rules = RuleArgCtxt
-        | disc > 0   = DiscArgCtxt  -- Be keener here
-        | otherwise  = BoringCtxt   -- Nothing interesting
+    info'  = info { ai_strs = strs, ai_discs = discs }
+    arg_ty = funArgTy fun_ty
+
+    -- Use this for lazy arguments
+    cci_lazy | encl_rules = RuleArgCtxt
+             | disc > 0   = DiscArgCtxt  -- Be keener here
+             | otherwise  = BoringCtxt   -- Nothing interesting
+
+    -- ..and this for strict arguments
+    cci_strict | encl_rules = RuleArgCtxt
+               | disc > 0   = DiscArgCtxt
+               | otherwise  = RhsCtxt
+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we
+      -- want to be a bit more eager to inline g, because it may
+      -- expose an eval (on x perhaps) that can be eliminated or
+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
+      -- It's worth an 18% improvement in allocation for this
+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
 
 ---------- No further useful info, revert to generic rebuild ------------
 rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
diff --git a/testsuite/tests/simplCore/should_compile/T12603.stdout b/testsuite/tests/simplCore/should_compile/T12603.stdout
index 277aa18..57a2a24 100644
--- a/testsuite/tests/simplCore/should_compile/T12603.stdout
+++ b/testsuite/tests/simplCore/should_compile/T12603.stdout
@@ -1 +1 @@
-lvl = case GHC.Real.$wf1 2# 8# of v { __DEFAULT -> GHC.Types.I# v }
+  = case GHC.Real.$wf1 2# 8# of ww4 { __DEFAULT -> GHC.Types.I# ww4 }