Be a tiny bit keener to inline in the RHS of a let

Seee Note [RHS of lets] in CoreUnfold

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index d467e89..fa9f5dc 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -604,11 +604,13 @@ instance Outputable ArgSummary where
 
 data CallCtxt = BoringCtxt
 
-             | ArgCtxt Bool    -- We're somewhere in the RHS of function with rules
-                               --      => be keener to inline
-                       Int     -- We *are* the argument of a function with this arg discount
-                               --      => be keener to inline
-               -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt
+             | ArgCtxt         -- We are somewhere in the argument of a function
+                        Bool   -- True  <=> we're somewhere in the RHS of function with rules
+                               -- False <=> we *are* the argument of a function with non-zero
+                               --           arg discount
+                                --        OR 
+                                --           we *are* the RHS of a let  Note [RHS of lets]
+                                -- In both cases, be a little keener to inline
 
              | ValAppCtxt      -- We're applied to at least one value arg
                                -- This arises when we have ((f x |> co) y)
@@ -618,10 +620,10 @@ data CallCtxt = BoringCtxt
                                -- that decomposes its scrutinee
 
 instance Outputable CallCtxt where
-  ppr BoringCtxt    = ptext (sLit "BoringCtxt")
-  ppr (ArgCtxt rules disc) = ptext (sLit "ArgCtxt") <> ppr (rules,disc)
-  ppr CaseCtxt             = ptext (sLit "CaseCtxt")
-  ppr ValAppCtxt    = ptext (sLit "ValAppCtxt")
+  ppr BoringCtxt      = ptext (sLit "BoringCtxt")
+  ppr (ArgCtxt rules) = ptext (sLit "ArgCtxt") <+> ppr rules
+  ppr CaseCtxt               = ptext (sLit "CaseCtxt")
+  ppr ValAppCtxt      = ptext (sLit "ValAppCtxt")
 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = let
@@ -707,6 +709,15 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
     }
 \end{code}
 
+Note [RHS of lets]
+~~~~~~~~~~~~~~~~~~
+Be a tiny bit keener to inline in the RHS of a let, because that might
+lead to good thing later
+     f y = (y,y,y)
+     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...
+We'd inline 'f' if the call was in a case context, and it kind-of-is,
+only we can't see it.  So we treat the RHS of a let as not-totally-boring.
+    
 Note [Unsaturated applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When a call is not saturated, we *still* inline if one of the
@@ -806,6 +817,11 @@ At one stage I replaced this condition by 'True' (leading to the above
 slow-down).  The motivation was test eyeball/inline1.hs; but that seems
 to work ok now.
 
+NOTE: arguably, we should inline in ArgCtxt only if the result of the
+call is at least CONLIKE.  At least for the cases where we use ArgCtxt
+for the RHS of a 'let', we only profit from the inlining if we get a 
+CONLIKE thing (modulo lets).
+
 Note [Lone variables]
 ~~~~~~~~~~~~~~~~~~~~~
 The "lone-variable" case is important.  I spent ages messing about

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 56b07c4..e0302a9 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -16,7 +16,7 @@ module SimplUtils (
        SimplCont(..), DupFlag(..), ArgInfo(..),
        contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
        countValArgs, countArgs, 
-       mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
+       mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, 
 
        interestingArg, mkArgInfo,
@@ -152,6 +152,9 @@ instance Outputable DupFlag where
 mkBoringStop :: SimplCont
 mkBoringStop = Stop BoringCtxt
 
+mkRhsStop :: SimplCont -- See Note [RHS of lets] in CoreUnfold
+mkRhsStop = Stop (ArgCtxt False)
+
 mkLazyArgStop :: CallCtxt -> SimplCont
 mkLazyArgStop cci = Stop cci
 
@@ -260,8 +263,9 @@ interestingCallContext cont
   where
     interesting (Select _ bndr _ _ _)
        | isDeadBinder bndr = CaseCtxt
-       | otherwise         = ArgCtxt False 2   -- If the binder is used, this
+       | otherwise         = ArgCtxt False     -- If the binder is used, this
                                                -- is like a strict let
+                                               -- See Note [RHS of lets] in CoreUnfold
                
     interesting (ApplyTo _ arg _ cont)
        | isTypeArg arg = interesting cont
@@ -394,8 +398,8 @@ interestingArgContext rules call_cont
     go (CoerceIt _ c)       = go c
     go (Stop cci)            = interesting cci
 
-    interesting (ArgCtxt rules _) = rules
-    interesting _                 = False
+    interesting (ArgCtxt rules) = rules
+    interesting _               = False
 \end{code}
 
 

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f9cbc0a..6a579db 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -335,8 +335,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
-        ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
-
+        ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
         -- ANF-ise a constructor or PAP rhs
         ; (body_env2, body2) <- prepareRhs body_env1 body1
 
@@ -1190,8 +1189,8 @@ rebuildCall env fun
         ; rebuildCall env (fun `App` arg') arg_info' cont }
   where
     arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
-    cci | has_rules || disc > 0 = ArgCtxt has_rules disc  -- Be keener here
-        | otherwise             = BoringCtxt              -- Nothing interesting
+    cci | has_rules || disc > 0 = ArgCtxt has_rules  -- Be keener here
+        | otherwise             = BoringCtxt         -- Nothing interesting
 
 rebuildCall env fun _ cont
   = rebuild env fun cont