module CoreUnfold (
	Unfolding, UnfoldingGuidance,	-- Abstract types

	noUnfolding, mkImplicitUnfolding, 
        mkUnfolding, mkCoreUnfolding,
	mkTopUnfolding, mkSimpleUnfolding,
	mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
	mkCompulsoryUnfolding, mkDFunUnfolding,

	interestingArg, ArgSummary(..),

	couldBeSmallEnoughToInline, 
	certainlyWillInline, smallEnoughToInline,

	callSiteInline, CallCtxt(..), 

	exprIsConApp_maybe

    ) where

#include "HsVersions.h"

import StaticFlags
import DynFlags
import CoreSyn
import PprCore		()	-- Instances
import TcType	 	( tcSplitSigmaTy, tcSplitDFunHead )
import OccurAnal
import CoreSubst hiding( substTy )
import CoreFVs         ( exprFreeVars )
import CoreArity       ( manifestArity, exprBotStrictness_maybe )
import CoreUtils
import Id
import DataCon
import TyCon
import Literal
import PrimOp
import IdInfo
import BasicTypes	( Arity )
import TcType		( tcSplitDFunTy )
import Type 
import Coercion
import PrelNames
import VarEnv           ( mkInScopeSet )
import Bag
import Util
import FastTypes
import FastString
import Outputable
import Data.Maybe

mkTopUnfolding :: Bool -> CoreExpr -> Unfolding
mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -}

mkImplicitUnfolding :: CoreExpr -> Unfolding
-- For implicit Ids, do a tiny bit of optimising first
mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) 

-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Slight hack: note that mk_inline_rules conservatively sets the
-- top-level flag to True.  It gets set more accurately by the simplifier
-- Simplify.simplUnfolding.

mkSimpleUnfolding :: CoreExpr -> Unfolding
mkSimpleUnfolding = mkUnfolding InlineRhs False False

mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops 
  = DFunUnfolding dfun_nargs data_con ops
  where
    (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
    	  -- NB: tcSplitSigmaTy: do not look through a newtype
	  --     when the dictionary type is a newtype
    (cls, _)   = tcSplitDFunHead head_ty
    dfun_nargs = length tvs + length theta
    data_con   = classDataCon cls

mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule id expr arity
  = mkCoreUnfolding (InlineWrapper id) True
                   (simpleOptExpr expr) arity
                   (UnfWhen unSaturatedOk boringCxtNotOk)

mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolded
  = mkCoreUnfolding InlineCompulsory True
                    expr 0    -- Arity of unfolding doesn't matter
                    (UnfWhen unSaturatedOk boringCxtOk)

mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
mkInlineUnfolding mb_arity expr 
  = mkCoreUnfolding InlineStable
    		    True 	 -- Note [Top-level flag on inline rules]
                    expr' arity 
		    (UnfWhen unsat_ok boring_ok)
  where
    expr' = simpleOptExpr expr
    (unsat_ok, arity) = case mb_arity of
                          Nothing -> (unSaturatedOk, manifestArity expr')
                          Just ar -> (needSaturated, ar)
              
    boring_ok = case calcUnfoldingGuidance True    -- Treat as cheap
    	      	     			   False   -- But not bottoming
                                           (arity+1) expr' of
              	  (_, UnfWhen _ boring_ok) -> boring_ok
              	  _other                   -> boringCxtNotOk
     -- See Note [INLINE for small functions]

mkInlinableUnfolding :: CoreExpr -> Unfolding
mkInlinableUnfolding expr
  = mkUnfolding InlineStable True is_bot expr'
  where
    expr' = simpleOptExpr expr
    is_bot = isJust (exprBotStrictness_maybe expr')

mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                -> Arity -> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
mkCoreUnfolding src top_lvl expr arity guidance 
  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
    		    uf_src        = src,
    		    uf_arity      = arity,
		    uf_is_top 	  = top_lvl,
		    uf_is_value   = exprIsHNF        expr,
                    uf_is_conlike = exprIsConLike    expr,
		    uf_is_cheap   = exprIsCheap      expr,
		    uf_expandable = exprIsExpandable expr,
		    uf_guidance   = guidance }

mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
mkUnfolding src top_lvl is_bottoming expr
  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
    		    uf_src        = src,
    		    uf_arity      = arity,
		    uf_is_top 	  = top_lvl,
		    uf_is_value   = exprIsHNF        expr,
                    uf_is_conlike = exprIsConLike    expr,
		    uf_expandable = exprIsExpandable expr,
		    uf_is_cheap   = is_cheap,
		    uf_guidance   = guidance }
  where
    is_cheap = exprIsCheap expr
    (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) 
                                              opt_UF_CreationThreshold expr
	-- Sometimes during simplification, there's a large let-bound thing	
	-- which has been substituted, and so is now dead; so 'expr' contains
	-- two copies of the thing while the occurrence-analysed expression doesn't
	-- Nevertheless, we *don't* occ-analyse before computing the size because the
	-- size computation bales out after a while, whereas occurrence analysis does not.
	--
	-- This can occasionally mean that the guidance is very pessimistic;
	-- it gets fixed up next round.  And it should be rare, because large
	-- let-bound things that are dead are usually caught by preInlineUnconditionally

calcUnfoldingGuidance
	:: Bool		-- True <=> the rhs is cheap, or we want to treat it
	   		--          as cheap (INLINE things)	 
        -> Bool		-- True <=> this is a top-level unfolding for a
	                --          diverging function; don't inline this
        -> Int		-- Bomb out if size gets bigger than this
	-> CoreExpr    	-- Expression to look at
	-> (Arity, UnfoldingGuidance)
calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
  = case collectBinders expr of { (bndrs, body) ->
    let
        val_bndrs   = filter isId bndrs
	n_val_bndrs = length val_bndrs

    	guidance 
          = case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of
      	      TooBig -> UnfNever
      	      SizeIs size cased_bndrs scrut_discount
      	        | uncondInline n_val_bndrs (iBox size)
                , expr_is_cheap
      	        -> UnfWhen unSaturatedOk boringCxtOk   -- Note [INLINE for small functions]
		| top_bot  -- See Note [Do not inline top-level bottoming functions]
		-> UnfNever

	        | otherwise
      	        -> UnfIfGoodArgs { ug_args  = map (discount cased_bndrs) val_bndrs
      	                         , ug_size  = iBox size
      	        	  	 , ug_res   = iBox scrut_discount }

        discount cbs bndr
           = foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc) 
		      0 cbs
    in
    (n_val_bndrs, guidance) }

uncondInline :: Arity -> Int -> Bool
-- Inline unconditionally if there no size increase
-- Size of call is arity (+1 for the function)
-- See Note [INLINE for small functions]
uncondInline arity size 
  | arity == 0 = size == 0
  | otherwise  = size <= arity + 1

sizeExpr :: FastInt 	    -- Bomb out if it gets bigger than this
	 -> [Id]	    -- Arguments; we're interested in which of these
			    -- get case'd
	 -> CoreExpr
	 -> ExprSize

-- Note [Computing the size of an expression]

sizeExpr bOMB_OUT_SIZE top_args expr
  = size_up expr
  where
    size_up (Cast e _) = size_up e
    size_up (Note _ e) = size_up e
    size_up (Type _)   = sizeZero           -- Types cost nothing
    size_up (Lit lit)  = sizeN (litSize lit)
    size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
    	    	       	 	      	    -- discounts even on nullary constructors

    size_up (App fun (Type _)) = size_up fun
    size_up (App fun arg)      = size_up arg  `addSizeNSD`
                                 size_up_app fun [arg]

    size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 1)
		      | otherwise = size_up e

    size_up (Let (NonRec binder rhs) body)
      = size_up rhs		`addSizeNSD`
	size_up body		`addSizeN`
	(if isUnLiftedType (idType binder) then 0 else 1)
		-- For the allocation
		-- If the binder has an unlifted type there is no allocation

    size_up (Let (Rec pairs) body)
      = foldr (addSizeNSD . size_up . snd) 
              (size_up body `addSizeN` length pairs)	-- (length pairs) for the allocation
              pairs

    size_up (Case (Var v) _ _ alts) 
	| v `elem` top_args		-- We are scrutinising an argument variable
	= alts_size (foldr1 addAltSize alt_sizes)
		    (foldr1 maxSize alt_sizes)
		-- Good to inline if an arg is scrutinised, because
		-- that may eliminate allocation in the caller
		-- And it eliminates the case itself
	where
	  alt_sizes = map size_up_alt alts

		-- 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 _        _)          -- Size of biggest alternative
	 	= SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut
			-- If the variable is known, we produce a discount that
			-- will take us back to 'max', the size of the largest alternative
			-- The 1+ is a little discount for reduced allocation in the caller
			--
			-- Notice though, that we return tot_disc, the total discount from 
			-- all branches.  I think that's right.

	  alts_size tot_size _ = tot_size

    size_up (Case e _ _ alts) = size_up e  `addSizeNSD` 
                                foldr (addAltSize . size_up_alt) sizeZero alts
	  	-- We don't charge for the case itself
		-- It's a strict thing, and the price of the call
		-- is paid by scrut.  Also consider
		--	case f x of DEFAULT -> e
		-- This is just ';'!  Don't charge for it.
		--
		-- Moreover, we charge one per alternative.

    ------------ 
    -- size_up_app is used when there's ONE OR MORE value args
    size_up_app (App fun arg) args 
	| isTypeArg arg		   = size_up_app fun args
	| otherwise		   = size_up arg  `addSizeNSD`
                                     size_up_app fun (arg:args)
    size_up_app (Var fun)     args = size_up_call fun args
    size_up_app other         args = size_up other `addSizeN` length args

    ------------ 
    size_up_call :: Id -> [CoreExpr] -> ExprSize
    size_up_call fun val_args
       = case idDetails fun of
           FCallId _        -> sizeN opt_UF_DearOp
           DataConWorkId dc -> conSize    dc (length val_args)
           PrimOpId op      -> primOpSize op (length val_args)
	   ClassOpId _ 	    -> classOpSize top_args val_args
	   _     	    -> funSize top_args fun (length val_args)

    ------------ 
    size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1
 	-- Don't charge for args, so that wrappers look cheap
	-- (See comments about wrappers with Case)
	--
	-- IMPORATANT: *do* charge 1 for the alternative, else we 
	-- find that giant case nests are treated as practically free
	-- A good example is Foreign.C.Error.errrnoToIOError

    ------------
	-- These addSize things have to be here because
	-- I don't want to give them bOMB_OUT_SIZE as an argument
    addSizeN TooBig          _  = TooBig
    addSizeN (SizeIs n xs d) m 	= mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
    
        -- addAltSize is used to add the sizes of case alternatives
    addAltSize TooBig	         _	= TooBig
    addAltSize _		 TooBig	= TooBig
    addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) 
	= mkSizeIs bOMB_OUT_SIZE (n1 +# n2) 
                                 (xs `unionBags` ys) 
                                 (d1 +# d2)   -- Note [addAltSize result discounts]

        -- This variant ignores the result discount from its LEFT argument
	-- It's used when the second argument isn't part of the result
    addSizeNSD TooBig	         _	= TooBig
    addSizeNSD _		 TooBig	= TooBig
    addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) 
	= mkSizeIs bOMB_OUT_SIZE (n1 +# n2) 
                                 (xs `unionBags` ys) 
                                 d2  -- Ignore d1

-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
	-- If size could be 0 then @f "x"@ might be too small
	-- [Sept03: make literal strings a bit bigger to avoid fruitless 
	--  duplication of little strings]
litSize _other = 0    -- Must match size of nullary constructors
	       	      -- Key point: if  x |-> 4, then x must inline unconditionally
		      --     	    (eg via case binding)

classOpSize :: [Id] -> [CoreExpr] -> ExprSize
-- See Note [Conlike is interesting]
classOpSize _ [] 
  = sizeZero
classOpSize top_args (arg1 : other_args)
  = SizeIs (iUnbox size) arg_discount (_ILIT(0))
  where
    size = 2 + length other_args
    -- If the class op is scrutinising a lambda bound dictionary then
    -- give it a discount, to encourage the inlining of this function
    -- The actual discount is rather arbitrarily chosen
    arg_discount = case arg1 of
    		     Var dict | dict `elem` top_args 
		     	      -> unitBag (dict, opt_UF_DictDiscount)
		     _other   -> emptyBag
    		     
funSize :: [Id] -> Id -> Int -> ExprSize
-- Size for functions that are not constructors or primops
-- Note [Function applications]
funSize top_args fun n_val_args
  | fun `hasKey` buildIdKey   = buildSize
  | fun `hasKey` augmentIdKey = augmentSize
  | otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount)
  where
    some_val_args = n_val_args > 0

    arg_discount | some_val_args && fun `elem` top_args
    		 = unitBag (fun, opt_UF_FunAppDiscount)
		 | otherwise = emptyBag
	-- If the function is an argument and is applied
	-- to some values, give it an arg-discount

    res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
    		 | otherwise   	 	    = 0
        -- If the function is partially applied, show a result discount

    size | some_val_args = 1 + n_val_args
         | otherwise     = 0
	-- The 1+ is for the function itself
	-- Add 1 for each non-trivial arg;
	-- the allocation cost, as in let(rec)
  

conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args
  | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1))	-- Like variables

-- See Note [Constructor size]
  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))

-- See Note [Unboxed tuple result discount]
--  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))

-- See Note [Constructor size]
  | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))

primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
 | not (primOpIsDupable op) = sizeN opt_UF_DearOp
 | not (primOpOutOfLine op) = sizeN 1
	-- Be very keen to inline simple primops.
	-- We give a discount of 1 for each arg so that (op# x y z) costs 2.
	-- We can't make it cost 1, else we'll inline let v = (op# x y z) 
	-- at every use of v, which is excessive.
	--
	-- A good example is:
	--	let x = +# p q in C {x}
	-- Even though x get's an occurrence of 'many', its RHS looks cheap,
	-- and there's a good chance it'll get inlined back into C's RHS. Urgh!

 | otherwise = sizeN n_val_args


buildSize :: ExprSize
buildSize = SizeIs (_ILIT(0)) 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)
	-- Indeed, we should add a result_discount becuause build is 
	-- very like a constructor.  We don't bother to check that the
	-- build is saturated (it usually is).  The "-2" discounts for the \c n, 
	-- The "4" is rather arbitrary.

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

-- When we return a lambda, give a discount if it's used (applied)
lamScrutDiscount :: ExprSize -> ExprSize
lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount)
lamScrutDiscount TooBig          = TooBig

data ExprSize = TooBig
	      | SizeIs FastInt		-- Size found
		       (Bag (Id,Int))	-- Arguments cased herein, and discount for each such
		       FastInt		-- Size to subtract if result is scrutinised 
					-- by a case expression

instance Outputable ExprSize where
  ppr TooBig         = ptext (sLit "TooBig")
  ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox c))

-- subtract the discount before deciding whether to bale out. eg. we
-- want to inline a large constructor application into a selector:
--  	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
 
maxSize :: ExprSize -> ExprSize -> ExprSize
maxSize TooBig         _ 				  = TooBig
maxSize _              TooBig				  = TooBig
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
					      | otherwise = s2

sizeZero :: ExprSize
sizeN :: Int -> ExprSize

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

couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs 
  = case sizeExpr (iUnbox threshold) [] body of
       TooBig -> False
       _      -> True
  where
    (_, body) = collectBinders rhs

----------------
smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})
  = size <= opt_UF_UseThreshold
smallEnoughToInline _
  = False

----------------
certainlyWillInline :: Unfolding -> Bool
  -- Sees if the unfolding is pretty certain to inline	
certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
  = case guidance of
      UnfNever      -> False
      UnfWhen {}    -> True
      UnfIfGoodArgs { ug_size = size} 
                    -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold

certainlyWillInline _
  = False

callSiteInline :: DynFlags
	       -> Id			-- The Id
	       -> Bool			-- True <=> unfolding is active
	       -> Bool			-- True if there are are no arguments at all (incl type args)
	       -> [ArgSummary]		-- One for each value arg; True if it is interesting
	       -> CallCtxt		-- True <=> continuation is interesting
	       -> Maybe CoreExpr	-- Unfolding, if any

instance Outputable ArgSummary where
  ppr TrivArg    = ptext (sLit "TrivArg")
  ppr NonTrivArg = ptext (sLit "NonTrivArg")
  ppr ValueArg   = ptext (sLit "ValueArg")

data CallCtxt = 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)
				-- 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 rules) = ptext (sLit "ArgCtxt") <+> ppr rules
  ppr CaseCtxt 	      = ptext (sLit "CaseCtxt")
  ppr ValAppCtxt      = ptext (sLit "ValAppCtxt")

callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
  = case idUnfolding id of 
      -- idUnfolding checks for loop-breakers, returning NoUnfolding
      -- Things with an INLINE pragma may have an unfolding *and* 
      -- be a loop breaker  (maybe the knot is not yet untied)
	CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top 
		      , uf_is_cheap = is_cheap, uf_arity = uf_arity
                      , uf_guidance = guidance }
          | active_unfolding -> tryUnfolding dflags id lone_variable 
                                    arg_infos cont_info unf_template is_top 
                                    is_cheap uf_arity guidance
          | otherwise    -> Nothing
	NoUnfolding 	 -> Nothing 
	OtherCon {} 	 -> Nothing 
	DFunUnfolding {} -> Nothing 	-- Never unfold a DFun

tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
             -> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance
	     -> Maybe CoreExpr	
tryUnfolding dflags id lone_variable 
             arg_infos cont_info unf_template is_top 
             is_cheap uf_arity guidance
			-- uf_arity will typically be equal to (idArity id), 
			-- but may be less for InlineRules
 | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
 = pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
		 (vcat [text "arg infos" <+> ppr arg_infos,
			text "uf arity" <+> ppr uf_arity,
			text "interesting continuation" <+> ppr cont_info,
			text "some_benefit" <+> ppr some_benefit,
                        text "is cheap:" <+> ppr is_cheap,
			text "guidance" <+> ppr guidance,
			extra_doc,
			text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
	         result
  | otherwise  = result

  where
    n_val_args = length arg_infos
    saturated  = n_val_args >= uf_arity

    result | yes_or_no = Just unf_template
           | otherwise = Nothing

    interesting_args = any nonTriv arg_infos 
    	-- NB: (any nonTriv arg_infos) looks at the
    	-- over-saturated args too which is "wrong"; 
    	-- but if over-saturated we inline anyway.

           -- some_benefit is used when the RHS is small enough
           -- and the call has enough (or too many) value
           -- arguments (ie n_val_args >= arity). But there must
           -- be *something* interesting about some argument, or the
           -- result context, to make it worth inlining
    some_benefit 
       | not saturated = interesting_args	-- Under-saturated
    	   	      		     	-- Note [Unsaturated applications]
       | n_val_args > uf_arity = True	-- Over-saturated
       | otherwise = interesting_args	-- Saturated
                  || interesting_saturated_call 

    interesting_saturated_call 
      = case cont_info of
          BoringCtxt -> not is_top && uf_arity > 0	      -- Note [Nested functions]
          CaseCtxt   -> not (lone_variable && is_cheap)   -- Note [Lone variables]
          ArgCtxt {} -> uf_arity > 0     		      -- Note [Inlining in ArgCtxt]
          ValAppCtxt -> True			      -- Note [Cast then apply]

    (yes_or_no, extra_doc)
      = case guidance of
          UnfNever -> (False, empty)

          UnfWhen unsat_ok boring_ok 
             -> (enough_args && (boring_ok || some_benefit), empty )
             where      -- See Note [INLINE for small functions]
               enough_args = saturated || (unsat_ok && n_val_args > 0)

          UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
      	     -> ( is_cheap && some_benefit && small_enough
                , (text "discounted size =" <+> int discounted_size) )
    	     where
    	       discounted_size = size - discount
    	       small_enough = discounted_size <= opt_UF_UseThreshold
    	       discount = computeDiscount uf_arity arg_discounts 
    	         		          res_discount arg_infos cont_info

computeDiscount :: Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int
computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
 	-- We multiple the raw discounts (args_discount and result_discount)
	-- ty opt_UnfoldingKeenessFactor because the former have to do with
	--  *size* whereas the discounts imply that there's some extra 
	--  *efficiency* to be gained (e.g. beta reductions, case reductions) 
	-- by inlining.

  = 1 		-- Discount of 1 because the result replaces the call
		-- so we count 1 for the function itself

    + length (take n_vals_wanted arg_infos)
      	       -- Discount of (un-scaled) 1 for each arg supplied, 
   	       -- because the result replaces the call

    + round (opt_UF_KeenessFactor * 
	     fromIntegral (arg_discount + res_discount'))
  where
    arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)

    mk_arg_discount _ 	     TrivArg    = 0 
    mk_arg_discount _ 	     NonTrivArg = 1   
    mk_arg_discount discount ValueArg   = discount 

    res_discount' = case cont_info of
			BoringCtxt  -> 0
			CaseCtxt    -> res_discount
			_other      -> 4 `min` res_discount
		-- res_discount can be very large when a function returns
		-- constructors; but we only want to invoke that large discount
		-- when there's a case continuation.
		-- Otherwise we, rather arbitrarily, threshold it.  Yuk.
		-- But we want to aovid inlining large functions that return 
		-- constructors into contexts that are simply "interesting"

data ArgSummary = TrivArg	-- Nothing interesting
     		| NonTrivArg	-- Arg has structure
		| ValueArg	-- Arg is a con-app or PAP
		  		-- ..or con-like. Note [Conlike is interesting]

interestingArg :: CoreExpr -> ArgSummary
-- See Note [Interesting arguments]
interestingArg e = go e 0
  where
    -- n is # value args to which the expression is applied
    go (Lit {}) _   	   = ValueArg
    go (Var v)  n
       | isConLikeId v     = ValueArg	-- Experimenting with 'conlike' rather that
       	 	     	     		--    data constructors here
       | idArity v > n	   = ValueArg	-- Catches (eg) primops with arity but no unfolding
       | n > 0	           = NonTrivArg	-- Saturated or unknown call
       | conlike_unfolding = ValueArg	-- n==0; look for an interesting unfolding
                                        -- See Note [Conlike is interesting]
       | otherwise	   = TrivArg	-- n==0, no useful unfolding
       where
         conlike_unfolding = isConLikeUnfolding (idUnfolding v)

    go (Type _)          _ = TrivArg
    go (App fn (Type _)) n = go fn n    
    go (App fn _)        n = go fn (n+1)
    go (Note _ a) 	 n = go a n
    go (Cast e _) 	 n = go e n
    go (Lam v e)  	 n 
       | isTyCoVar v	   = go e n
       | n>0	 	   = go e (n-1)
       | otherwise	   = ValueArg
    go (Let _ e)  	 n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
    go (Case {})  	 _ = NonTrivArg

nonTriv ::  ArgSummary -> Bool
nonTriv TrivArg = False
nonTriv _       = True

-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is 
-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
-- where t1..tk are the *universally-qantified* type args of 'dc'
exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])

exprIsConApp_maybe id_unf (Note note expr)
  | notSccNote note
  = exprIsConApp_maybe id_unf expr
	-- We ignore all notes except SCCs.  For example,
	--  	case _scc_ "foo" (C a b) of
	--			C a b -> e
	-- should not be optimised away, because we'll lose the
	-- entry count on 'foo'; see Trac #4414

exprIsConApp_maybe id_unf (Cast expr co)
  =     -- Here we do the KPush reduction rule as described in the FC paper
	-- The transformation applies iff we have
	--	(C e1 ... en) `cast` co
	-- where co :: (T t1 .. tn) ~ to_ty
	-- The left-hand one must be a T, because exprIsConApp returned True
	-- but the right-hand one might not be.  (Though it usually will.)

    case exprIsConApp_maybe id_unf expr of {
	Nothing 	                 -> Nothing ;
	Just (dc, _dc_univ_args, dc_args) -> 

    let (_from_ty, to_ty) = coercionKind co
	dc_tc = dataConTyCon dc
    in
    case splitTyConApp_maybe to_ty of {
	Nothing -> Nothing ;
	Just (to_tc, to_tc_arg_tys) 
		| dc_tc /= to_tc -> Nothing
		-- These two Nothing cases are possible; we might see 
		--	(C x y) `cast` (g :: T a ~ S [a]),
		-- where S is a type function.  In fact, exprIsConApp
		-- will probably not be called in such circumstances,
		-- but there't nothing wrong with it 

	 	| otherwise  ->
    let
	tc_arity       = tyConArity dc_tc
	dc_univ_tyvars = dataConUnivTyVars dc
        dc_ex_tyvars   = dataConExTyVars dc
        arg_tys        = dataConRepArgTys dc

        dc_eqs :: [(Type,Type)]	  -- All equalities from the DataCon
        dc_eqs = [(mkTyVarTy tv, ty)   | (tv,ty) <- dataConEqSpec dc] ++
                 [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]

        (ex_args, rest1)    = splitAtList dc_ex_tyvars dc_args
	(co_args, val_args) = splitAtList dc_eqs rest1

	-- Make the "theta" from Fig 3 of the paper
        gammas = decomposeCo tc_arity co
        theta  = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
                                (gammas         ++ stripTypeArgs ex_args)

          -- Cast the existential coercion arguments
        cast_co (ty1, ty2) (Type co) 
          = Type $ mkSymCoercion (substTy theta ty1)
		   `mkTransCoercion` co
		   `mkTransCoercion` (substTy theta ty2)
        cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
        new_co_args = zipWith cast_co dc_eqs co_args
  
          -- Cast the value arguments (which include dictionaries)
	new_val_args = zipWith cast_arg arg_tys val_args
	cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
    in
#ifdef DEBUG
    let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                         ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
                         ppr ex_args, ppr val_args]
    in
    ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
    ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
    ASSERT2( equalLength val_args arg_tys, dump_doc )
#endif

    Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
    }}

exprIsConApp_maybe id_unf expr 
  = analyse expr [] 
  where
    analyse (App fun arg) args = analyse fun (arg:args)
    analyse fun@(Lam {})  args = beta fun [] args 

    analyse (Var fun) args
	| Just con <- isDataConWorkId_maybe fun
        , count isValArg args == idArity fun
	, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
	= Just (con, stripTypeArgs univ_ty_args, rest_args)

	-- Look through dictionary functions; see Note [Unfolding DFuns]
        | DFunUnfolding dfun_nargs con ops <- unfolding
        , let sat = length args == dfun_nargs    -- See Note [DFun arity check]
          in if sat then True else 
             pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
        , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
              subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
              mk_arg (DFunConstArg e) = e
              mk_arg (DFunLamArg i)   = args !! i
              mk_arg (DFunPolyArg e)  = mkApps e args
        = Just (con, substTys subst dfun_res_tys, map mk_arg ops)

	-- Look through unfoldings, but only cheap ones, because
	-- we are effectively duplicating the unfolding
	| Just rhs <- expandUnfolding_maybe unfolding
	= -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
          analyse rhs args
        where
	  unfolding = id_unf fun

    analyse _ _ = Nothing

    -----------
    beta (Lam v body) pairs (arg : args) 
        | isTypeArg arg
        = beta body ((v,arg):pairs) args 

    beta (Lam {}) _ _    -- Un-saturated, or not a type lambda
	= Nothing

    beta fun pairs args
        = analyse (substExpr (text "subst-expr-is-con-app") subst fun) args
        where
          subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
	  -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]


stripTypeArgs :: [CoreExpr] -> [Type]
stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
                     [ty | Type ty <- args]