module CoreUnfold (
	Unfolding, UnfoldingGuidance,	-- Abstract types

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

	interestingArg, ArgSummary(..),

	couldBeSmallEnoughToInline, inlineBoringOk,
	certainlyWillInline, smallEnoughToInline,

	callSiteInline, CallCtxt(..), 

	exprIsConApp_maybe

    ) where

#include "HsVersions.h"

import StaticFlags
import DynFlags
import CoreSyn
import PprCore		()	-- Instances
import TcType           ( tcSplitDFunTy )
import OccurAnal        ( occurAnalyseExpr )
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 Type
import Coercion
import PrelNames
import VarEnv           ( mkInScopeSet )
import Bag
import Util
import Pair
import FastTypes
import FastString
import Outputable
import ForeignCall

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 -> [CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops 
  = DFunUnfolding dfun_nargs data_con ops
  where
    (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
    dfun_nargs = length tvs + n_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
                    (simpleOptExpr 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 = inlineBoringOk expr'

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
  | top_lvl && is_bottoming
  , not (exprIsTrivial expr)
  = NoUnfolding    -- See Note [Do not inline top-level bottoming functions]
  | otherwise
  = 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
                                              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

inlineBoringOk :: CoreExpr -> Bool
-- See Note [INLINE for small functions]
-- True => the result of inlining the expression is 
--         no bigger than the expression itself
--     eg      (\x y -> f y x)
-- This is a quick and dirty version. It doesn't attempt
-- to deal with  (\x y z -> x (y z))
-- The really important one is (x `cast` c)
inlineBoringOk e
  = go 0 e
  where
    go :: Int -> CoreExpr -> Bool
    go credit (Lam x e) | isId x           = go (credit+1) e
                        | otherwise        = go credit e
    go credit (App f (Type {}))            = go credit f
    go credit (App f a) | credit > 0  
                        , exprIsTrivial a  = go (credit-1) f
    go credit (Note _ e) 		   = go credit e     
    go credit (Cast e _) 		   = go credit e
    go _      (Var {})         		   = boringCxtOk
    go _      _                		   = boringCxtNotOk

calcUnfoldingGuidance
	:: Bool		-- True <=> the rhs is cheap, or we want to treat it
	   		--          as cheap (INLINE things)	 
        -> Int		-- Bomb out if size gets bigger than this
	-> CoreExpr    	-- Expression to look at
	-> (Arity, UnfoldingGuidance)
calcUnfoldingGuidance expr_is_cheap 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]
	        | 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 <= 10 * (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 (Coercion _) = sizeZero
    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 (Coercion _)) = 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` 10)
		      | 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 10)
		-- 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` (10 * 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(20) +# 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) case_size alts
      where
          case_size
           | is_inline_scrut e, not (lengthExceeds alts 1)  = sizeN (-10)
           | otherwise = sizeZero
                -- Normally we don't charge for the case itself, but
                -- we charge one per alternative (see size_up_alt,
                -- below) to account for the cost of the info table
                -- and comparisons.
                --
                -- However, in certain cases (see is_inline_scrut
                -- below), no code is generated for the case unless
                -- there are multiple alts.  In these cases we
                -- subtract one, making the first alt free.
                -- e.g. case x# +# y# of _ -> ...   should cost 1
                --      case touch# x# of _ -> ...  should cost 0
                -- (see #4978)
                --
                -- I would like to not have the "not (lengthExceeds alts 1)"
                -- condition above, but without that some programs got worse
                -- (spectral/hartel/event and spectral/para).  I don't fully
                -- understand why. (SDM 24/5/11)

                -- unboxed variables, inline primops and unsafe foreign calls
                -- are all "inline" things:
          is_inline_scrut (Var v) = isUnLiftedType (idType v)
          is_inline_scrut scrut
              | (Var f, _) <- collectArgs scrut
                = case idDetails f of
                    FCallId fc  -> not (isSafeForeignCall fc)
                    PrimOpId op -> not (primOpOutOfLine op)
                    _other      -> False
              | otherwise
                = False

    ------------ 
    -- size_up_app is used when there's ONE OR MORE value args
    size_up_app (App fun arg) args 
	| isTyCoArg 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 (10 * (1 + length val_args))
           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` 10
 	-- 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) = 10 + 10 * ((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 = 20 + (10 * 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 = 10 * (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(10))    -- Like variables

-- See Note [Unboxed tuple result discount]
  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args)))

-- See Note [Constructor size]
  | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args)))
     -- discont was (10 * (1 + n_val_args)), but it turns out that
     -- adding a bigger constant here is an unambiguous win.  We
     -- REALLY like unfolding constructors that get scrutinised.
     -- [SDM, 25/5/11]

primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
 = if primOpOutOfLine op
      then sizeN (op_size + n_val_args)
      else sizeN op_size
 where
   op_size = primOpCodeSize op


buildSize :: ExprSize
buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
	-- 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(40))
	-- 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 - (10 * (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, uf_expandable = is_exp }
          | active_unfolding -> tryUnfolding dflags id lone_variable 
                                    arg_infos cont_info unf_template is_top 
                                    is_cheap is_exp uf_arity guidance
          | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
          -> pprTrace "Inactive unfolding:" (ppr id) Nothing
          | otherwise -> Nothing
	NoUnfolding 	 -> Nothing 
	OtherCon {} 	 -> Nothing 
	DFunUnfolding {} -> Nothing 	-- Never unfold a DFun

tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
             -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance
	     -> Maybe CoreExpr	
tryUnfolding dflags id lone_variable 
             arg_infos cont_info unf_template is_top 
             is_cheap is_exp 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 exp:" <+> ppr is_exp,
                        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.

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

    + 10 * 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 = 10
    mk_arg_discount discount ValueArg   = discount 

    res_discount' = case cont_info of
			BoringCtxt  -> 0
			CaseCtxt    -> res_discount
                        _other      -> 40 `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 (Coercion _)      _ = TrivArg
    go (App fn (Type _)) n = go fn n
    go (App fn (Coercion _)) 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 
       | isTyVar 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 Pair _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

        (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args

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

          -- Cast the value arguments (which include dictionaries)
	new_val_args = zipWith cast_arg arg_tys val_args
	cast_arg arg_ty arg = mkCoerce (liftCoSubst 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( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
    ASSERT2( all isTypeArg ex_args, dump_doc )
    ASSERT2( equalLength val_args arg_tys, dump_doc )
#endif

    Just (dc, to_tc_arg_tys, ex_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, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
              subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
              mk_arg 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) 
        | isTyCoArg 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]
  -- We really do want isTypeArg here, not isTyCoArg!