preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally env top_lvl bndr rhs
  | not active 		                     = False
  | isStableUnfolding (idUnfolding bndr)     = False    -- Note [InlineRule and preInlineUnconditionally]
  | isTopLevel top_lvl && isBottomingId bndr = False	-- Note [Top-level bottoming Ids]
  | opt_SimplNoPreInlining                   = False
  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
  | otherwise = case idOccInfo bndr of
		  IAmDead	     	     -> True	-- Happens in ((\x.1) v)
	  	  OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
		  _                          -> False
  where
    mode = getMode env
    active = isActive (sm_phase mode) act
             -- See Note [pre/postInlineUnconditionally in gentle mode]
    act = idInlineActivation bndr
    try_once in_lam int_cxt	-- There's one textual occurrence
	| not in_lam = isNotTopLevel top_lvl || early_phase
	| otherwise  = int_cxt && canInlineInLam rhs

-- Be very careful before inlining inside a lambda, because (a) we must not 
-- invalidate occurrence information, and (b) we want to avoid pushing a
-- single allocation (here) into multiple allocations (inside lambda).  
-- Inlining a *function* with a single *saturated* call would be ok, mind you.
--	|| (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
--	where 
--	 	is_cheap = exprIsCheap rhs
--		ok = is_cheap && int_cxt

	-- 	int_cxt		The context isn't totally boring
	-- E.g. let f = \ab.BIG in \y. map f xs
	-- 	Don't want to substitute for f, because then we allocate
	--	its closure every time the \y is called
        -- But: let f = \ab.BIG in \y. map (f y) xs
	--	Now we do want to substitute for f, even though it's not 
	--	saturated, because we're going to allocate a closure for 
	--	(f y) every time round the loop anyhow.

	-- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
	-- so substituting rhs inside a lambda doesn't change the occ info.
	-- Sadly, not quite the same as exprIsHNF.
    canInlineInLam (Lit _)		= True
    canInlineInLam (Lam b e)		= isRuntimeVar b || canInlineInLam e
    canInlineInLam _                    = False
      -- not ticks.  Counting ticks cannot be duplicated, and non-counting
      -- ticks around a Lam will disappear anyway.

    early_phase = case sm_phase mode of
                    Phase 0 -> False
                    _       -> True
-- If we don't have this early_phase test, consider
--	x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
-- top level, and preInlineUnconditionally floats them all back in.
-- Result is (a) static allocation replaced by dynamic allocation
--	     (b) many simplifier iterations because this tickles
--		 a related problem; only one inlining per pass
-- 
-- On the other hand, I have seen cases where top-level fusion is
-- lost if we don't inline top level thing (e.g. string constants)
-- Hence the test for phase zero (which is the phase for all the final
-- simplifications).  Until phase zero we take no special notice of
-- top level things, but then we become more leery about inlining
-- them.  

postInlineUnconditionally 
    :: SimplEnv -> TopLevelFlag
    -> OutId		-- The binder (an InId would be fine too)
       			--            (*not* a CoVar)
    -> OccInfo 		-- From the InId
    -> OutExpr
    -> Unfolding
    -> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
  | not active		        = False
  | isWeakLoopBreaker occ_info  = False	-- If it's a loop-breaker of any kind, don't inline
					-- because it might be referred to "earlier"
  | isExportedId bndr           = False
  | isStableUnfolding unfolding = False	-- Note [InlineRule and postInlineUnconditionally]
  | isTopLevel top_lvl          = False	-- Note [Top level and postInlineUnconditionally]
  | exprIsTrivial rhs 	        = True
  | otherwise
  = case occ_info of
	-- The point of examining occ_info here is that for *non-values* 
	-- that occur outside a lambda, the call-site inliner won't have
	-- a chance (becuase it doesn't know that the thing
	-- only occurs once).   The pre-inliner won't have gotten
	-- it either, if the thing occurs in more than one branch
	-- So the main target is things like
	--	let x = f y in
	--	case v of
	--	   True  -> case x of ...
	--	   False -> case x of ...
	-- This is very important in practice; e.g. wheel-seive1 doubles 
	-- in allocation if you miss this out
      OneOcc in_lam _one_br int_cxt	-- OneOcc => no code-duplication issue
	->     smallEnoughToInline unfolding	-- Small enough to dup
			-- ToDo: consider discount on smallEnoughToInline if int_cxt is true
			--
		 	-- NB: Do NOT inline arbitrarily big things, even if one_br is True
			-- Reason: doing so risks exponential behaviour.  We simplify a big
			--	   expression, inline it, and simplify it again.  But if the
			--	   very same thing happens in the big expression, we get 
			--	   exponential cost!
			-- PRINCIPLE: when we've already simplified an expression once, 
			-- make sure that we only inline it if it's reasonably small.

           && (not in_lam || 
			-- Outside a lambda, we want to be reasonably aggressive
			-- about inlining into multiple branches of case
			-- e.g. let x = <non-value> 
			--	in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } 
			-- Inlining can be a big win if C3 is the hot-spot, even if
			-- the uses in C1, C2 are not 'interesting'
			-- An example that gets worse if you add int_cxt here is 'clausify'

		(isCheapUnfolding unfolding && int_cxt))
			-- isCheap => acceptable work duplication; in_lam may be true
			-- int_cxt to prevent us inlining inside a lambda without some 
			-- good reason.  See the notes on int_cxt in preInlineUnconditionally

      IAmDead -> True	-- This happens; for example, the case_bndr during case of
			-- known constructor:  case (a,b) of x { (p,q) -> ... }
			-- Here x isn't mentioned in the RHS, so we don't want to
			-- create the (dead) let-binding  let x = (a,b) in ...

      _ -> False

-- Here's an example that we don't handle well:
--	let f = if b then Left (\x.BIG) else Right (\y.BIG)
--	in \y. ....case f of {...} ....
-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
-- But
--  - We can't preInlineUnconditionally because that woud invalidate
--    the occ info for b.
--  - We can't postInlineUnconditionally because the RHS is big, and
--    that risks exponential behaviour
--  - We can't call-site inline, because the rhs is big
-- Alas!

  where
    active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
        -- See Note [pre/postInlineUnconditionally in gentle mode]

mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
-- mkLam tries three things
--	a) eta reduction, if that gives a trivial expression
--	b) eta expansion [only if there are some value lambdas]

mkLam _b [] body 
  = return body
mkLam _env bndrs body
  = do	{ dflags <- getDynFlags
	; mkLam' dflags bndrs body }
  where
    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
    mkLam' dflags bndrs (Cast body co)
      | not (any bad bndrs)
	-- Note [Casts and lambdas]
      = do { lam <- mkLam' dflags bndrs body
           ; return (mkCast lam (mkPiCos bndrs co)) }
      where
        co_vars  = tyCoVarsOfCo co
	bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      

    mkLam' dflags bndrs body@(Lam {})
      = mkLam' dflags (bndrs ++ bndrs1) body1
      where
        (bndrs1, body1) = collectBinders body

    mkLam' dflags bndrs body
      | dopt Opt_DoEtaReduction dflags
      , Just etad_lam <- tryEtaReduce bndrs body
      = do { tick (EtaReduction (head bndrs))
	   ; return etad_lam }

      | otherwise
      = return (mkLams bndrs body)

tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
-- See Note [Eta-expanding at let bindings]
tryEtaExpand env bndr rhs
  = do { dflags <- getDynFlags
       ; (new_arity, new_rhs) <- try_expand dflags

       ; WARN( new_arity < old_arity || new_arity < _dmd_arity, 
               (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
		<+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
			-- Note [Arity decrease]
         return (new_arity, new_rhs) }
  where
    try_expand dflags
      | exprIsTrivial rhs
      = return (exprArity rhs, rhs)

      | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
      , let new_arity = findArity dflags bndr rhs old_arity
      , new_arity > manifest_arity  	-- And the curent manifest arity isn't enough
      		    			-- See Note [Eta expansion to manifes arity]
      = do { tick (EtaExpansion bndr)
           ; return (new_arity, etaExpand new_arity rhs) }
      | otherwise
      = return (manifest_arity, rhs)

    manifest_arity = manifestArity rhs
    old_arity  = idArity bndr
    _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr

findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
findArity dflags bndr rhs old_arity
  = go (exprEtaExpandArity dflags init_cheap_app rhs)
       -- We always call exprEtaExpandArity once, but usually 
       -- that produces a result equal to old_arity, and then
       -- we stop right away (since arities should not decrease)
       -- Result: the common case is that there is just one iteration
  where
    init_cheap_app :: CheapAppFun
    init_cheap_app fn n_val_args
      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
      | otherwise  = isCheapApp fn n_val_args

    go :: Arity -> Arity
    go cur_arity
      | cur_arity <= old_arity = cur_arity	
      | new_arity == cur_arity = cur_arity
      | otherwise = ASSERT( new_arity < cur_arity )
#ifdef DEBUG
                    pprTrace "Exciting arity" 
                       (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
                             , ppr rhs])
#endif
                    go new_arity
      where
        new_arity = exprEtaExpandArity dflags cheap_app rhs

        cheap_app :: CheapAppFun
        cheap_app fn n_val_args
          | fn == bndr = n_val_args < cur_arity
          | otherwise  = isCheapApp fn n_val_args

abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats main_tvs body_env body
  = ASSERT( notNull body_floats )
    do	{ (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
	; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
  where
    main_tv_set = mkVarSet main_tvs
    body_floats = getFloatBinds body_env
    empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)

    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
    abstract subst (NonRec id rhs)
      = do { (poly_id, poly_app) <- mk_poly tvs_here id
	   ; let poly_rhs = mkLams tvs_here rhs'
		 subst'   = CoreSubst.extendIdSubst subst id poly_app
	   ; return (subst', (NonRec poly_id poly_rhs)) }
      where
	rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
	tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
	
		-- Abstract only over the type variables free in the rhs
		-- wrt which the new binding is abstracted.  But the naive
		-- approach of abstract wrt the tyvars free in the Id's type
		-- fails. Consider:
		--	/\ a b -> let t :: (a,b) = (e1, e2)
		--		      x :: a     = fst t
		--		  in ...
		-- Here, b isn't free in x's type, but we must nevertheless
		-- abstract wrt b as well, because t's type mentions b.
		-- Since t is floated too, we'd end up with the bogus:
		--	poly_t = /\ a b -> (e1, e2)
		--	poly_x = /\ a   -> fst (poly_t a *b*)
		-- So for now we adopt the even more naive approach of
		-- abstracting wrt *all* the tyvars.  We'll see if that
		-- gives rise to problems.   SLPJ June 98

    abstract subst (Rec prs)
       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
	    ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
		  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs) 
                              | rhs <- rhss]
	    ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
       where
	 (ids,rhss) = unzip prs
	 	-- For a recursive group, it's a bit of a pain to work out the minimal
		-- set of tyvars over which to abstract:
		--	/\ a b c.  let x = ...a... in
		--	 	   letrec { p = ...x...q...
		--			    q = .....p...b... } in
		--		   ...
		-- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
		-- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.  
		-- Since it's a pain, we just use the whole set, which is always safe
		-- 
		-- If you ever want to be more selective, remember this bizarre case too:
		--	x::a = x
		-- Here, we must abstract 'x' over 'a'.
	 tvs_here = sortQuantVars main_tvs

    mk_poly tvs_here var
      = do { uniq <- getUniqueM
	   ; let  poly_name = setNameUnique (idName var) uniq		-- Keep same name
		  poly_ty   = mkForAllTys tvs_here (idType var)	-- But new type of course
		  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs
			      mkLocalId poly_name poly_ty 
	   ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
		-- In the olden days, it was crucial to copy the occInfo of the original var, 
		-- because we were looking at occurrence-analysed but as yet unsimplified code!
		-- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
		-- at already simplified code, so it doesn't matter
		-- 
		-- It's even right to retain single-occurrence or dead-var info:
		-- Suppose we started with  /\a -> let x = E in B
		-- where x occurs once in B. Then we transform to:
		--	let x' = /\a -> E in /\a -> let x* = x' a in B
		-- where x* has an INLINE prag on it.  Now, once x* is inlined,
		-- the occurrences of x' will be just the occurrences originally
		-- pinned on x.

prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-- The returned alternatives can be empty, none are possible
prepareAlts scrut case_bndr' alts = do
    us <- getUniquesM
    -- Case binder is needed just for its type. Note that as an
    --   OutId, it has maximum information; this is important.
    --   Test simpl013 is an example
    let (imposs_deflt_cons, refined_deflt, alts') = filterAlts us (varType case_bndr') imposs_cons alts
    when refined_deflt $ tick (FillInCaseDefault case_bndr')
    return (imposs_deflt_cons, alts')
  where
    imposs_cons = case scrut of
		    Var v -> otherCons (idUnfolding v)
		    _     -> []

mkCase, mkCase1, mkCase2 
   :: DynFlags 
   -> OutExpr -> OutId
   -> OutType -> [OutAlt]		-- Alternatives in standard (increasing) order
   -> SimplM OutExpr

--------------------------------------------------
--	1. Merge Nested Cases
--------------------------------------------------

mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
  | dopt Opt_CaseMerge dflags
  , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
  , inner_scrut_var == outer_bndr
  = do	{ tick (CaseMerge outer_bndr)

	; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )
                                          (con, args, wrap_rhs rhs)
		-- Simplifier's no-shadowing invariant should ensure
		-- that outer_bndr is not shadowed by the inner patterns
              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
		-- The let is OK even for unboxed binders, 

	      wrapped_alts | isDeadBinder inner_bndr = inner_alts
                           | otherwise               = map wrap_alt inner_alts

	      merged_alts = mergeAlts outer_alts wrapped_alts
		-- NB: mergeAlts gives priority to the left
		--	case x of 
		--	  A -> e1
		--	  DEFAULT -> case x of 
		--			A -> e2
		--			B -> e3
		-- When we merge, we must ensure that e1 takes 
		-- precedence over e2 as the value for A!  

	; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
	}
    	-- Warning: don't call mkCase recursively!
    	-- Firstly, there's no point, because inner alts have already had
    	-- mkCase applied to them, so they won't have a case in their default
    	-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
    	-- in munge_rhs may put a case into the DEFAULT branch!

mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts

--------------------------------------------------
--	2. Eliminate Identity Case
--------------------------------------------------

mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
  | all identity_alt alts
  = do { tick (CaseIdentity case_bndr)
       ; return (re_cast scrut rhs1) }
  where
    identity_alt (con, args, rhs) = check_eq rhs con args

    check_eq (Cast rhs co) con args         = not (any (`elemVarSet` tyCoVarsOfCo co) args)
        {- See Note [RHS casts] -}            && check_eq rhs con args
    check_eq (Lit lit) (LitAlt lit') _      = lit == lit'
    check_eq (Var v)   _ _ | v == case_bndr = True
    check_eq (Var v)   (DataAlt con) []     = v == dataConWorkId con   -- Optimisation only
    check_eq rhs       (DataAlt con) args   = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
    check_eq _ _ _ = False

    arg_tys = map Type (tyConAppArgs (idType case_bndr))

        -- Note [RHS casts]
        -- ~~~~~~~~~~~~~~~~
	-- We've seen this:
	--	case e of x { _ -> x `cast` c }
	-- And we definitely want to eliminate this case, to give
	--	e `cast` c
	-- So we throw away the cast from the RHS, and reconstruct
	-- it at the other end.  All the RHS casts must be the same
	-- if (all identity_alt alts) holds.
	-- 
	-- Don't worry about nested casts, because the simplifier combines them

    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
    re_cast scrut _             = scrut

--------------------------------------------------
--	3. Merge Identical Alternatives
--------------------------------------------------
mkCase1 dflags scrut case_bndr alts_ty ((_con1,bndrs1,rhs1) : con_alts)
  | all isDeadBinder bndrs1			-- Remember the default 
  , length filtered_alts < length con_alts	-- alternative comes first
	-- Also Note [Dead binders]
  = do	{ tick (AltMerge case_bndr)
	; mkCase2 dflags scrut case_bndr alts_ty alts' }
  where
    alts' = (DEFAULT, [], rhs1) : filtered_alts
    filtered_alts	  = filter keep con_alts
    keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)

mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts

--------------------------------------------------
--	Catch-all
--------------------------------------------------
mkCase2 _dflags scrut bndr alts_ty alts 
  = return (Case scrut bndr alts_ty alts)