preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally dflags 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]
  | not (gopt Opt_SimplPreInlining dflags)   = 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
    :: DynFlags -> SimplEnv -> TopLevelFlag
    -> OutId            -- The binder (an InId would be fine too)
                        --            (*not* a CoVar)
    -> OccInfo          -- From the InId
    -> OutExpr
    -> Unfolding
    -> Bool
postInlineUnconditionally dflags 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 (because 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 dflags 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 Representational 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
      | gopt 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]
-- and Note [Eta expansion to manifest arity]
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 manifest 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
           -- 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
  = do { us <- getUniquesM
       ; let (imposs_deflt_cons, refined_deflt, alts') 
                = filterAlts us (varType case_bndr') imposs_cons alts
       ; when refined_deflt $ tick (FillInCaseDefault case_bndr')
 
       ; alts'' <- combineIdenticalAlts case_bndr' alts'
       ; return (imposs_deflt_cons, alts'') }
  where
    imposs_cons = case scrut of
                    Var v -> otherCons (idUnfolding v)
                    _     -> []

combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
-- See Note [Combine identical alterantives]
combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
  | all isDeadBinder bndrs1                     -- Remember the default
  , length filtered_alts < length con_alts      -- alternative comes first
  = do  { tick (AltMerge case_bndr)
        ; return ((DEFAULT, [], rhs1) : filtered_alts) }
  where
    filtered_alts = filterOut identical_to_alt1 con_alts
    identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1

combineIdenticalAlts _ alts = return alts

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)
  | gopt 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

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)