Fix Trac #2720: inlining and casts

The issue here is what happens when we have

	(f |> co) x

where f is itself marked INLINE.  We want callSiteInline to "see"
the fact that the function is applied, and hence have some incentive
to inline.  I've done this by extending CoreUnfold.CallCtxt with
ValAppCtxt.  I think that should catch this case without messing up
any of the others.

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index b6706c1..d7ec4c7 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -536,6 +536,10 @@ data CallCtxt = BoringCtxt
                                --      => be keener to inline
                -- INVARIANT: ArgCtxt False 0 ==> BoringCtxt
 
+             | ValAppCtxt      -- We're applied to at least one value arg
+                               -- This arises when we have ((f x |> co) y)
+                               -- Then the (f x) has argument 'x' but in a ValAppCtxt
+
              | CaseCtxt        -- We're the scrutinee of a case
                                -- that decomposes its scrutinee
 
@@ -543,6 +547,7 @@ instance Outputable CallCtxt where
   ppr BoringCtxt    = ptext (sLit "BoringCtxt")
   ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt")
   ppr CaseCtxt             = ptext (sLit "CaseCtxt")
+  ppr ValAppCtxt    = ptext (sLit "ValAppCtxt")
 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = case idUnfolding id of {
@@ -610,8 +615,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                        = case cont_info of
                            BoringCtxt -> not is_top && n_vals_wanted > 0       -- Note [Nested functions] 
                            CaseCtxt   -> not lone_variable || not is_value     -- Note [Lone variables]
-                           ArgCtxt {} -> n_vals_wanted > 0 
-                               -- See Note [Inlining in ArgCtxt]
+                           ArgCtxt {} -> n_vals_wanted > 0                     -- Note [Inlining in ArgCtxt]
+                           ValAppCtxt -> True                                  -- Note [Cast then apply]
 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 
@@ -619,7 +624,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                    res_discount' = case cont_info of
                                        BoringCtxt  -> 0
                                        CaseCtxt    -> res_discount
-                                       ArgCtxt _ _ -> 4 `min` res_discount
+                                       _other      -> 4 `min` res_discount
                        -- res_discount can be very large when a function returns
                        -- construtors; but we only want to invoke that large discount
                        -- when there's a case continuation.
@@ -655,6 +660,16 @@ branches.  Then inlining it doesn't increase allocation, but it does
 increase the chance that the constructor won't be allocated at all in
 the branches that don't use it.
 
+Note [Cast then apply]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   myIndex = __inline_me ( (/\a. <blah>) |> co )
+   co :: (forall a. a -> a) ~ (forall a. T a)
+     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...
+
+We need to inline myIndex to unravel this; but the actual call (myIndex a) has
+no value arguments.  The ValAppCtxt gives it enough incentive to inline.
+
 Note [Inlining in ArgCtxt]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 The condition (n_vals_wanted > 0) here is very important, because otherwise

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 097ecd2..0f6cf73 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -308,17 +308,17 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interestingCtxt = ArgCtxt False 2  -- Give *some* incentive!
-
     interesting (Select _ bndr _ _ _)
-       | isDeadBinder bndr       = CaseCtxt
-       | otherwise               = interestingCtxt
+       | isDeadBinder bndr = CaseCtxt
+       | otherwise         = ArgCtxt False 2   -- If the binder is used, this
+                                               -- is like a strict let
                
-    interesting (ApplyTo {})      = interestingCtxt
-                               -- Can happen if we have (coerce t (f x)) y
-                               -- Perhaps interestingCtxt is a bit over-keen, but I've
-                               -- seen (coerce f) x, where f has an INLINE prag,
-                               -- So we have to give some motivation for inlining it
+    interesting (ApplyTo _ arg _ cont)
+       | isTypeArg arg = interesting cont
+       | otherwise     = ValAppCtxt    -- Can happen if we have (f Int |> co) y
+                                       -- If f has an INLINE prag we need to give it some
+                                       -- motivation to inline. See Note [Cast then apply]
+                                       -- in CoreUnfold
 
     interesting (StrictArg _ cci _ _)  = cci
     interesting (StrictBind {})                = BoringCtxt