Make record selectors into ordinary functions

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

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 9617c59..38513af 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -15,17 +15,11 @@ literal'').  In the corner of a @CoreUnfolding@ unfolding, you will
 find, unsurprisingly, a Core expression.
 
 \begin{code}
 find, unsurprisingly, a Core expression.
 
 \begin{code}

-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-

 module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 
 module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 

-       noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
+       noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, 
+       mkCompulsoryUnfolding, seqUnfolding,

        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,

@@ -34,27 +28,28 @@ module CoreUnfold (
        couldBeSmallEnoughToInline, 
        certainlyWillInline, smallEnoughToInline,
 
        couldBeSmallEnoughToInline, 
        certainlyWillInline, smallEnoughToInline,
 

-       callSiteInline, CallContInfo(..)
+       callSiteInline, CallCtxt(..)

 
     ) where
 
 
     ) where
 

-#include "HsVersions.h"
-

 import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
 import OccurAnal
 import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
 import OccurAnal

+import CoreSubst       ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst
+                       , lookupIdSubst, substBndr, substBndrs, substRecBndrs )

 import CoreUtils
 import Id
 import DataCon
 import Literal
 import PrimOp
 import IdInfo
 import CoreUtils
 import Id
 import DataCon
 import Literal
 import PrimOp
 import IdInfo

-import Type
+import Type hiding( substTy, extendTvSubst )

 import PrelNames
 import Bag
 import FastTypes
 import PrelNames
 import Bag
 import FastTypes

+import FastString

 import Outputable
 
 \end{code}
 import Outputable
 
 \end{code}

@@ -67,8 +62,19 @@ import Outputable
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+mkTopUnfolding :: CoreExpr -> Unfolding

 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
 
 mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
 

+mkImplicitUnfolding :: CoreExpr -> Unfolding
+-- For implicit Ids, do a tiny bit of optimising first
+mkImplicitUnfolding expr 
+  = CoreUnfolding (simpleOptExpr emptySubst expr)
+                 True
+                 (exprIsHNF expr)
+                 (exprIsCheap expr)
+                 (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+
+mkUnfolding :: Bool -> CoreExpr -> Unfolding

 mkUnfolding top_lvl expr
   = CoreUnfolding (occurAnalyseExpr expr)
                  top_lvl
 mkUnfolding top_lvl expr
   = CoreUnfolding (occurAnalyseExpr expr)
                  top_lvl

@@ -90,13 +96,14 @@ mkUnfolding top_lvl expr
        -- it gets fixed up next round
 
 instance Outputable Unfolding where
        -- it gets fixed up next round
 
 instance Outputable Unfolding where

-  ppr NoUnfolding = ptext SLIT("No unfolding")
-  ppr (OtherCon cs) = ptext SLIT("OtherCon") <+> ppr cs
-  ppr (CompulsoryUnfolding e) = ptext SLIT("Compulsory") <+> ppr e
+  ppr NoUnfolding = ptext (sLit "No unfolding")
+  ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e

   ppr (CoreUnfolding e top hnf cheap g) 
   ppr (CoreUnfolding e top hnf cheap g) 

-       = ptext SLIT("Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, 
+       = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, 

                                     ppr e]
 
                                     ppr e]
 

+mkCompulsoryUnfolding :: CoreExpr -> Unfolding

 mkCompulsoryUnfolding expr     -- Used for things that absolutely must be unfolded
   = CompulsoryUnfolding (occurAnalyseExpr expr)
 \end{code}
 mkCompulsoryUnfolding expr     -- Used for things that absolutely must be unfolded
   = CompulsoryUnfolding (occurAnalyseExpr expr)
 \end{code}

@@ -110,9 +117,9 @@ mkCompulsoryUnfolding expr  -- Used for things that absolutely must be unfolded
 
 \begin{code}
 instance Outputable UnfoldingGuidance where
 
 \begin{code}
 instance Outputable UnfoldingGuidance where

-    ppr UnfoldNever    = ptext SLIT("NEVER")
+    ppr UnfoldNever    = ptext (sLit "NEVER")

     ppr (UnfoldIfGoodArgs v cs size discount)
     ppr (UnfoldIfGoodArgs v cs size discount)

-      = hsep [ ptext SLIT("IF_ARGS"), int v,
+      = hsep [ ptext (sLit "IF_ARGS"), int v,

               brackets (hsep (map int cs)),
               int size,
               int discount ]
               brackets (hsep (map int cs)),
               int size,
               int discount ]

@@ -174,7 +181,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
        -- We want to say "2 value binders".  Why?  So that 
        -- we take account of information given for the arguments
 
        -- We want to say "2 value binders".  Why?  So that 
        -- we take account of information given for the arguments
 

-    go inline rev_vbs (Note InlineMe e)     = go True   rev_vbs     e
+    go _      rev_vbs (Note InlineMe e)     = go True   rev_vbs     e

     go inline rev_vbs (Lam b e) | isId b    = go inline (b:rev_vbs) e
                                | otherwise = go inline rev_vbs     e
     go inline rev_vbs e                            = (inline, reverse rev_vbs, e)
     go inline rev_vbs (Lam b e) | isId b    = go inline (b:rev_vbs) e
                                | otherwise = go inline rev_vbs     e
     go inline rev_vbs e                            = (inline, reverse rev_vbs, e)

@@ -190,10 +197,10 @@ sizeExpr :: FastInt           -- Bomb out if it gets bigger than this
 sizeExpr bOMB_OUT_SIZE top_args expr
   = size_up expr
   where
 sizeExpr bOMB_OUT_SIZE top_args expr
   = size_up expr
   where

-    size_up (Type t)         = sizeZero        -- Types cost nothing
-    size_up (Var v)           = sizeOne
+    size_up (Type _)           = sizeZero        -- Types cost nothing
+    size_up (Var _)            = sizeOne

 
 

-    size_up (Note InlineMe body) = sizeOne     -- Inline notes make it look very small
+    size_up (Note InlineMe _)  = sizeOne         -- Inline notes make it look very small

        -- This can be important.  If you have an instance decl like this:
        --      instance Foo a => Foo [a] where
        --         {-# INLINE op1, op2 #-}
        -- This can be important.  If you have an instance decl like this:
        --      instance Foo a => Foo [a] where
        --         {-# INLINE op1, op2 #-}

@@ -201,11 +208,11 @@ sizeExpr bOMB_OUT_SIZE top_args expr
        --         op2 = ...
        -- then we'll get a dfun which is a pair of two INLINE lambdas
 
        --         op2 = ...
        -- then we'll get a dfun which is a pair of two INLINE lambdas
 

-    size_up (Note _        body) = size_up body        -- Other notes cost nothing
+    size_up (Note _      body) = size_up body  -- Other notes cost nothing

     
     

-    size_up (Cast e _)           = size_up e
+    size_up (Cast e _)         = size_up e

 
 

-    size_up (App fun (Type t)) = size_up fun
+    size_up (App fun (Type _)) = size_up fun

     size_up (App fun arg)      = size_up_app fun [arg]
 
     size_up (Lit lit)         = sizeN (litSize lit)
     size_up (App fun arg)      = size_up_app fun [arg]
 
     size_up (Lit lit)         = sizeN (litSize lit)

@@ -267,8 +274,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
                -- alts_size tries to compute a good discount for
                -- the case when we are scrutinising an argument variable
 
                -- alts_size tries to compute a good discount for
                -- the case when we are scrutinising an argument variable

-         alts_size (SizeIs tot tot_disc tot_scrut)             -- Size of all alternatives
-                   (SizeIs max max_disc max_scrut)             -- Size of biggest alternative
+         alts_size (SizeIs tot _tot_disc _tot_scrut)           -- Size of all alternatives
+                   (SizeIs max  max_disc  max_scrut)           -- Size of biggest alternative

                = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` max_disc) max_scrut
                        -- If the variable is known, we produce a discount that
                        -- will take us back to 'max', the size of rh largest alternative
                = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` max_disc) max_scrut
                        -- If the variable is known, we produce a discount that
                        -- will take us back to 'max', the size of rh largest alternative

@@ -302,10 +309,10 @@ sizeExpr bOMB_OUT_SIZE top_args expr
       | fun `hasKey` buildIdKey   = buildSize
       | fun `hasKey` augmentIdKey = augmentSize
       | otherwise 
       | fun `hasKey` buildIdKey   = buildSize
       | fun `hasKey` augmentIdKey = augmentSize
       | otherwise 

-      = case globalIdDetails fun of
+      = case idDetails fun of

          DataConWorkId dc -> conSizeN dc (valArgCount args)
 
          DataConWorkId dc -> conSizeN dc (valArgCount args)
 

-         FCallId fc   -> sizeN opt_UF_DearOp
+         FCallId _    -> sizeN opt_UF_DearOp

          PrimOpId op  -> primOpSize op (valArgCount args)
                          -- foldr addSize (primOpSize op) (map arg_discount args)
                          -- At one time I tried giving an arg-discount if a primop 
          PrimOpId op  -> primOpSize op (valArgCount args)
                          -- foldr addSize (primOpSize op) (map arg_discount args)
                          -- At one time I tried giving an arg-discount if a primop 

@@ -315,7 +322,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
                          -- if we know nothing about it.  And just having it in a primop
                          -- doesn't help at all if we don't know something more.
 
                          -- if we know nothing about it.  And just having it in a primop
                          -- doesn't help at all if we don't know something more.
 

-         other        -> fun_discount fun `addSizeN` 
+         _            -> fun_discount fun `addSizeN`

                          (1 + length (filter (not . exprIsTrivial) args))
                                -- The 1+ is for the function itself
                                -- Add 1 for each non-trivial arg;
                          (1 + length (filter (not . exprIsTrivial) args))
                                -- The 1+ is for the function itself
                                -- Add 1 for each non-trivial arg;

@@ -325,17 +332,17 @@ sizeExpr bOMB_OUT_SIZE top_args expr
                                --      We should really only count for non-prim-typed args in the
                                --      general case, but that seems too much like hard work
 
                                --      We should really only count for non-prim-typed args in the
                                --      general case, but that seems too much like hard work
 

-    size_up_fun other args = size_up other
+    size_up_fun other _ = size_up other

 
     ------------ 
 
     ------------ 

-    size_up_alt (con, bndrs, rhs) = size_up rhs
+    size_up_alt (_con, _bndrs, rhs) = size_up rhs

        -- Don't charge for args, so that wrappers look cheap
        -- (See comments about wrappers with Case)
 
     ------------
        -- We want to record if we're case'ing, or applying, an argument
     fun_discount v | v `elem` top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))
        -- Don't charge for args, so that wrappers look cheap
        -- (See comments about wrappers with Case)
 
     ------------
        -- We want to record if we're case'ing, or applying, an argument
     fun_discount v | v `elem` top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))

-    fun_discount other                = sizeZero
+    fun_discount _                     = sizeZero

 
     ------------
        -- These addSize things have to be here because
 
     ------------
        -- These addSize things have to be here because

@@ -364,14 +371,20 @@ data ExprSize = TooBig
 --     tup = (a_1, ..., a_99)
 --     x = case tup of ...
 --
 --     tup = (a_1, ..., a_99)
 --     x = case tup of ...
 --

+mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize

 mkSizeIs max n xs d | (n -# d) ># max = TooBig
                    | otherwise       = SizeIs n xs d
  
 mkSizeIs max n xs d | (n -# d) ># max = TooBig
                    | otherwise       = SizeIs n xs d
  

+maxSize :: ExprSize -> ExprSize -> ExprSize

 maxSize TooBig         _                                 = TooBig
 maxSize _              TooBig                            = TooBig
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
                                              | otherwise = s2
 
 maxSize TooBig         _                                 = TooBig
 maxSize _              TooBig                            = TooBig
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
                                              | otherwise = s2
 

+sizeZero, sizeOne :: ExprSize
+sizeN :: Int -> ExprSize
+conSizeN :: DataCon ->Int -> ExprSize
+

 sizeZero       = SizeIs (_ILIT(0))  emptyBag (_ILIT(0))
 sizeOne        = SizeIs (_ILIT(1))  emptyBag (_ILIT(0))
 sizeN n        = SizeIs (iUnbox n) emptyBag (_ILIT(0))
 sizeZero       = SizeIs (_ILIT(0))  emptyBag (_ILIT(0))
 sizeOne        = SizeIs (_ILIT(1))  emptyBag (_ILIT(0))
 sizeN n        = SizeIs (iUnbox n) emptyBag (_ILIT(0))

@@ -389,6 +402,7 @@ conSizeN dc n
        --      f x y z = case op# x y z of { s -> (# s, () #) }
        -- and f wasn't getting inlined
 
        --      f x y z = case op# x y z of { s -> (# s, () #) }
        -- and f wasn't getting inlined
 

+primOpSize :: PrimOp -> Int -> ExprSize

 primOpSize op n_args
  | not (primOpIsDupable op) = sizeN opt_UF_DearOp
  | not (primOpOutOfLine op) = sizeN (2 - n_args)
 primOpSize op n_args
  | not (primOpIsDupable op) = sizeN opt_UF_DearOp
  | not (primOpOutOfLine op) = sizeN (2 - n_args)

@@ -403,6 +417,7 @@ primOpSize op n_args
        -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
  | otherwise               = sizeOne
 
        -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
  | otherwise               = sizeOne
 

+buildSize :: ExprSize

 buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
        -- We really want to inline applications of build
        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
 buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
        -- We really want to inline applications of build
        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)

@@ -411,16 +426,19 @@ buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
        -- build is saturated (it usually is).  The "-2" discounts for the \c n, 
        -- The "4" is rather arbitrary.
 
        -- build is saturated (it usually is).  The "-2" discounts for the \c n, 
        -- The "4" is rather arbitrary.
 

+augmentSize :: ExprSize

 augmentSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
        -- e plus ys. The -2 accounts for the \cn 
 augmentSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))
        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
        -- e plus ys. The -2 accounts for the \cn 

-                                               
-nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs (_ILIT(0))
-nukeScrutDiscount TooBig         = TooBig
+
+nukeScrutDiscount :: ExprSize -> ExprSize
+nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0))
+nukeScrutDiscount TooBig          = TooBig

 
 -- When we return a lambda, give a discount if it's used (applied)
 
 -- When we return a lambda, give a discount if it's used (applied)

-lamScrutDiscount  (SizeIs n vs d) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) }
-lamScrutDiscount TooBig                  = TooBig
+lamScrutDiscount :: ExprSize -> ExprSize
+lamScrutDiscount (SizeIs n vs _) = case opt_UF_FunAppDiscount of { d -> SizeIs n vs (iUnbox d) }
+lamScrutDiscount TooBig          = TooBig

 \end{code}
 
 
 \end{code}
 
 

@@ -461,20 +479,20 @@ Just the same as smallEnoughToInline, except that it has no actual arguments.
 \begin{code}
 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
 \begin{code}
 couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
 couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of

-                                               UnfoldNever -> False
-                                               other       -> True
+                                                UnfoldNever -> False
+                                                _           -> True

 
 certainlyWillInline :: Unfolding -> Bool
   -- Sees if the unfolding is pretty certain to inline 
 certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
   = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
 
 certainlyWillInline :: Unfolding -> Bool
   -- Sees if the unfolding is pretty certain to inline 
 certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
   = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold

-certainlyWillInline other
+certainlyWillInline _

   = False
 
 smallEnoughToInline :: Unfolding -> Bool
 smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
   = size <= opt_UF_UseThreshold
   = False
 
 smallEnoughToInline :: Unfolding -> Bool
 smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
   = size <= opt_UF_UseThreshold

-smallEnoughToInline other
+smallEnoughToInline _

   = False
 \end{code}
 
   = False
 \end{code}
 

@@ -506,24 +524,35 @@ callSiteInline :: DynFlags
               -> Id                    -- The Id
               -> Bool                  -- True if there are are no arguments at all (incl type args)
               -> [Bool]                -- One for each value arg; True if it is interesting
               -> Id                    -- The Id
               -> Bool                  -- True if there are are no arguments at all (incl type args)
               -> [Bool]                -- One for each value arg; True if it is interesting

-              -> CallContInfo          -- True <=> continuation is interesting
+              -> CallCtxt              -- True <=> continuation is interesting

               -> Maybe CoreExpr        -- Unfolding, if any
 
 
               -> Maybe CoreExpr        -- Unfolding, if any
 
 

-data CallContInfo = BoringCont         
-                 | InterestingCont     -- Somewhat interesting
-                 | CaseCont            -- Very interesting; the argument of a case
-                                       -- that decomposes its scrutinee
+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

 
 

-instance Outputable CallContInfo where
-  ppr BoringCont      = ptext SLIT("BoringCont")
-  ppr InterestingCont = ptext SLIT("InterestingCont")
-  ppr CaseCont               = ptext SLIT("CaseCont")
+             | 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
+
+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 {
        NoUnfolding -> Nothing ;
 
 callSiteInline dflags active_inline id lone_variable arg_infos cont_info
   = case idUnfolding id of {
        NoUnfolding -> Nothing ;

-       OtherCon cs -> Nothing ;
+       OtherCon _  -> Nothing ;

 
        CompulsoryUnfolding unf_template -> Just unf_template ;
                -- CompulsoryUnfolding => there is no top-level binding
 
        CompulsoryUnfolding unf_template -> Just unf_template ;
                -- CompulsoryUnfolding => there is no top-level binding

@@ -562,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

@@ -581,17 +613,18 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
 
                    interesting_saturated_call 
                        = case cont_info of
 
                    interesting_saturated_call 
                        = case cont_info of

-                           BoringCont -> not is_top && n_vals_wanted > 0       -- Note [Nested functions] 
-                           CaseCont   -> not lone_variable || not is_value     -- Note [Lone variables]
-                           InterestingCont -> n_vals_wanted > 0
+                           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                     -- Note [Inlining in ArgCtxt]
+                           ValAppCtxt -> True                                  -- Note [Cast then apply]

 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 
                                               res_discount' arg_infos
                    res_discount' = case cont_info of
 
                    small_enough = (size - discount) <= opt_UF_UseThreshold
                    discount = computeDiscount n_vals_wanted arg_discounts 
                                               res_discount' arg_infos
                    res_discount' = case cont_info of

-                                       BoringCont      -> 0
-                                       CaseCont        -> res_discount
-                                       InterestingCont -> 4 `min` res_discount
+                                       BoringCtxt  -> 0
+                                       CaseCtxt    -> 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.

@@ -627,8 +660,31 @@ 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
+we end up inlining top-level stuff into useless places; eg
+   x = I# 3#
+   f = \y.  g x
+This can make a very big difference: it adds 16% to nofib 'integer' allocs,
+and 20% to 'power'.
+
+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 [Lone variables]
 Note [Lone variables]

-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~

 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
 variable appears all alone
 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
 variable appears all alone

@@ -707,3 +763,75 @@ computeDiscount n_vals_wanted arg_discounts result_discount arg_infos
     mk_arg_discount discount is_evald | is_evald  = discount
                                      | otherwise = 0
 \end{code}
     mk_arg_discount discount is_evald | is_evald  = discount
                                      | otherwise = 0
 \end{code}

+
+%************************************************************************
+%*                                                                     *
+       The Very Simple Optimiser
+%*                                                                     *
+%************************************************************************
+
+
+\begin{code}
+simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
+-- Return an occur-analysed and slightly optimised expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once, 
+-- or wheere the RHS is trivial
+
+simpleOptExpr subst expr
+  = go subst (occurAnalyseExpr expr)
+  where
+    go subst (Var v)          = lookupIdSubst subst v
+    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
+    go subst (Type ty)        = Type (substTy subst ty)
+    go _     (Lit lit)        = Lit lit
+    go subst (Note note e)    = Note note (go subst e)
+    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
+    go subst (Let bind body)  = go_bind subst bind body
+    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
+                             where
+                               (subst', bndr') = substBndr subst bndr
+
+    go subst (Case e b ty as) = Case (go subst e) b' 
+                                    (substTy subst ty)
+                                    (map (go_alt subst') as)
+                             where
+                                (subst', b') = substBndr subst b
+
+
+    ----------------------
+    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+                                where
+                                  (subst', bndrs') = substBndrs subst bndrs
+
+    ----------------------
+    go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
+                                      (go subst' body)
+                           where
+                             (bndrs, rhss)    = unzip prs
+                             (subst', bndrs') = substRecBndrs subst bndrs
+                             rhss'            = map (go subst') rhss
+
+    go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
+
+    ----------------------
+    go_nonrec subst b (Type ty') body
+      | isTyVar b = go (extendTvSubst subst b ty') body
+       -- let a::* = TYPE ty in <body>
+    go_nonrec subst b r' body
+      | isId b -- let x = e in <body>
+      , exprIsTrivial r' || safe_to_inline (idOccInfo b)
+      = go (extendIdSubst subst b r') body
+    go_nonrec subst b r' body
+      = Let (NonRec b' r') (go subst' body)
+      where
+       (subst', b') = substBndr subst b
+
+    ----------------------
+       -- Unconditionally safe to inline
+    safe_to_inline :: OccInfo -> Bool
+    safe_to_inline IAmDead                  = True
+    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+    safe_to_inline (IAmALoopBreaker {})     = False
+    safe_to_inline NoOccInfo                = False
+\end{code}
\ No newline at end of file