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

Seee Note [RHS of lets] in CoreUnfold

3 files changed, 36 insertions, 17 deletions

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index d467e89ed9..fa9f5dcfb3 100644
--- 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 56b07c4804..e0302a91e5 100644
--- 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 f9cbc0af3e..6a579dbb24 100644
--- 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