Tidy up treatment of big lambda (fixes Trac #2898)

[ghc-hetmet.git] / compiler / coreSyn / CoreUnfold.lhs

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 45b8b92..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
 
                                --      => 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
 
              | 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 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 {
 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = case idUnfolding id of {

@@ -586,10 +591,13 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                  -> True
 
                  | otherwise
                  -> True
 
                  | otherwise

-                 -> some_benefit && small_enough
+                 -> some_benefit && small_enough && inline_enough_args

 
                  where
                    enough_args = n_val_args >= n_vals_wanted
 
                  where
                    enough_args = n_val_args >= n_vals_wanted

+                    inline_enough_args =
+                      not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
+

 
                    some_benefit = or arg_infos || really_interesting_cont
                                -- There must be something interesting
 
                    some_benefit = or arg_infos || really_interesting_cont
                                -- There must be something interesting

@@ -607,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]
                        = 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 
 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 

@@ -616,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
                    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.
                        -- 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.

@@ -652,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.
 
 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
 Note [Inlining in ArgCtxt]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 The condition (n_vals_wanted > 0) here is very important, because otherwise