Inline in a call argument if the caller has RULES

This is an experimental change suggested by Roman.  Consider

	{-# INLINE f #-}
	f x y = ...

	....(g (f a b))...

where g has RULES.  Then we'd like to inline f, even though the context of
the call is otherwise 100% boring -- g is lazy and we know nothing about
x and y.

This patch just records in the continuation that f has rules.  And does so
somewhat recursively...e.g.

	...(g (h (f a b)))...

where g has rules.

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 32ad40c..265ded6 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -15,8 +15,9 @@ module SimplUtils (
        SimplCont(..), DupFlag(..), LetRhsFlag(..), 
        contIsDupable, contResultType,
        countValArgs, countArgs, pushContArgs,
-       mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
-       getContArgs, interestingCallContext, interestingArg, isStrictType
+       mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
+       getContArgs, interestingCallContext, interestingArgContext,
+       interestingArg, isStrictType
 
     ) where
 
@@ -29,16 +30,16 @@ import StaticFlags  ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
                          opt_RulesOff )
 import CoreSyn
 import CoreFVs         ( exprFreeVars )
-import CoreUtils       ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
+import CoreUtils       ( cheapEqExpr, exprType, exprIsTrivial, 
                          etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
                          findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts
                        )
 import Literal         ( mkStringLit )
 import CoreUnfold      ( smallEnoughToInline )
 import MkId            ( eRROR_ID )
-import Id              ( idType, isDataConWorkId, idOccInfo, isDictId, 
+import Id              ( Id, idType, isDataConWorkId, idOccInfo, isDictId, 
                          isDeadBinder, idNewDemandInfo, isExportedId,
-                         idUnfolding, idNewStrictness, idInlinePragma,
+                         idUnfolding, idNewStrictness, idInlinePragma, idHasRules
                        )
 import NewDemand       ( isStrictDmd, isBotRes, splitStrictSig )
 import SimplMonad
@@ -63,11 +64,16 @@ import Outputable
 
 \begin{code}
 data SimplCont         -- Strict contexts
-  = Stop     OutType           -- Type of the result
+  = Stop     OutType   -- Type of the result
             LetRhsFlag
-            Bool               -- True <=> This is the RHS of a thunk whose type suggests
-                               --          that update-in-place would be possible
-                               --          (This makes the inliner a little keener.)
+            Bool       -- True <=> There is something interesting about
+                       --          the context, and hence the inliner
+                       --          should be a bit keener (see interestingCallContext)
+                       -- Two cases:
+                       -- (a) This is the RHS of a thunk whose type suggests
+                       --     that update-in-place would be possible
+                       -- (b) This is an argument of a function that has RULES
+                       --     Inlining the call might allow the rule to fire
 
   | CoerceIt OutType                   -- The To-type, simplified
             SimplCont
@@ -86,7 +92,7 @@ data SimplCont                -- Strict contexts
   | ArgOf    LetRhsFlag                -- An arbitrary strict context: the argument 
                                --      of a strict function, or a primitive-arg fn
                                --      or a PrimOp
-                               -- No DupFlag because we never duplicate it
+                               -- No DupFlag, because we never duplicate it
             OutType            -- arg_ty: type of the argument itself
             OutType            -- cont_ty: the type of the expression being sought by the context
                                --      f (error "foo") ==> coerce t (error "foo")
@@ -120,9 +126,14 @@ instance Outputable DupFlag where
 
 
 -------------------
-mkBoringStop, mkRhsStop :: OutType -> SimplCont
-mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
-mkRhsStop    ty = Stop ty AnRhs (canUpdateInPlace ty)
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty AnArg False
+
+mkLazyArgStop :: OutType -> Bool -> SimplCont
+mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
+
+mkRhsStop :: OutType -> SimplCont
+mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
 
 contIsRhs :: SimplCont -> Bool
 contIsRhs (Stop _ AnRhs _)    = True
@@ -382,7 +393,7 @@ interestingCallContext some_args some_val_args cont
                                                -- seen (coerce f) x, where f has an INLINE prag,
                                                -- So we have to give some motivaiton for inlining it
     interesting (ArgOf _ _ _ _)                 = some_val_args
-    interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
+    interesting (Stop ty _ interesting)  = some_val_args && interesting
     interesting (CoerceIt _ cont)        = interesting cont
        -- If this call is the arg of a strict function, the context
        -- is a bit interesting.  If we inline here, we may get useful
@@ -401,6 +412,33 @@ interestingCallContext some_args some_val_args cont
 
 
 -------------------
+interestingArgContext :: Id -> SimplCont -> Bool
+-- If the argument has form (f x y), where x,y are boring,
+-- and f is marked INLINE, then we don't want to inline f.
+-- But if the context of the argument is
+--     g (f x y) 
+-- where g has rules, then we *do* want to inline f, in case it
+-- exposes a rule that might fire.  Similarly, if the context is
+--     h (g (f x x))
+-- where h has rules, then we do want to inline f.
+-- The interesting_arg_ctxt flag makes this happen; if it's
+-- set, the inliner gets just enough keener to inline f 
+-- regardless of how boring f's arguments are, if it's marked INLINE
+--
+-- The alternative would be to *always* inline an INLINE function,
+-- regardless of how boring its context is; but that seems overkill
+-- For example, it'd mean that wrapper functions were always inlined
+interestingArgContext fn cont
+  = idHasRules fn || go cont
+  where
+    go (InlinePlease c)       = go c
+    go (Select {})           = False
+    go (ApplyTo {})          = False
+    go (ArgOf {})            = True
+    go (CoerceIt _ c)        = go c
+    go (Stop _ _ interesting) = interesting
+
+-------------------
 canUpdateInPlace :: Type -> Bool
 -- Consider   let x = <wurble> in ...
 -- If <wurble> returns an explicit constructor, we might be able

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index dd2a22b..329d326 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -15,11 +15,11 @@ import SimplMonad
 import SimplEnv        
 import SimplUtils      ( mkCase, mkLam,
                          SimplCont(..), DupFlag(..), LetRhsFlag(..), 
-                         mkRhsStop, mkBoringStop,  pushContArgs,
+                         mkRhsStop, mkBoringStop,  mkLazyArgStop, pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          getContArgs, interestingCallContext, interestingArg, isStrictType,
                          preInlineUnconditionally, postInlineUnconditionally, 
-                         inlineMode, activeInline, activeRule
+                         interestingArgContext, inlineMode, activeInline, activeRule
                        )
 import Id              ( Id, idType, idInfo, idArity, isDataConWorkId, 
                          idUnfolding, setIdUnfolding, isDeadBinder,
@@ -923,7 +923,8 @@ completeCall env var occ_info cont
        (args, call_cont, inline_call) = getContArgs chkr var cont
        fn_ty                          = idType var
     in
-    simplifyArgs env fn_ty args (contResultType call_cont)     $ \ env args ->
+    simplifyArgs env fn_ty (interestingArgContext var call_cont) args 
+                (contResultType call_cont)     $ \ env args ->
 
        -- Next, look for rules or specialisations that match
        --
@@ -976,11 +977,9 @@ completeCall env var occ_info cont
        -- Next, look for an inlining
     let
        arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
-
        interesting_cont = interestingCallContext (notNull args)
                                                  (notNull arg_infos)
                                                  call_cont
-
        active_inline = activeInline env var occ_info
        maybe_inline  = callSiteInline dflags active_inline inline_call occ_info
                                       var arg_infos interesting_cont
@@ -1053,6 +1052,7 @@ makeThatCall env var fun args cont
 
 simplifyArgs :: SimplEnv 
             -> OutType                         -- Type of the function
+            -> Bool                            -- True if the fn has RULES
             -> [(InExpr, SimplEnv, Bool)]      -- Details of the arguments
             -> OutType                         -- Type of the continuation
             -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
@@ -1083,19 +1083,19 @@ simplifyArgs :: SimplEnv
 -- discard the entire application and replace it with (error "foo").  Getting
 -- all this at once is TOO HARD!
 
-simplifyArgs env fn_ty args cont_ty thing_inside
+simplifyArgs env fn_ty has_rules args cont_ty thing_inside
   = go env fn_ty args thing_inside
   where
     go env fn_ty []        thing_inside = thing_inside env []
-    go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty           $ \ env arg' ->
+    go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty has_rules arg cont_ty $ \ env arg' ->
                                           go env (applyTypeToArg fn_ty arg') args      $ \ env args' ->
                                           thing_inside env (arg':args')
 
-simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside
+simplifyArg env fn_ty has_rules (Type ty_arg, se, _) cont_ty thing_inside
   = simplType (setInScope se env) ty_arg       `thenSmpl` \ new_ty_arg ->
     thing_inside env (Type new_ty_arg)
 
-simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside 
+simplifyArg env fn_ty has_rules (val_arg, arg_se, is_strict) cont_ty thing_inside 
   | is_strict 
   = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
 
@@ -1105,8 +1105,8 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
                -- have to be very careful about bogus strictness through 
                -- floating a demanded let.
   = simplExprC (setInScope arg_se env) val_arg
-              (mkBoringStop arg_ty)            `thenSmpl` \ arg1 ->
-   thing_inside env arg1
+              (mkLazyArgStop arg_ty has_rules)         `thenSmpl` \ arg1 ->
+    thing_inside env arg1
   where
     arg_ty = funArgTy fn_ty