    {-
    (c) The AQUA Project, Glasgow University, 1994-1998

    \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
    -}

    {-# LANGUAGE CPP #-}
    module GHC.Core.Opt.LiberateCase ( liberateCase ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Core
    import GHC.Core.Unfold
    import GHC.Builtin.Types ( unitDataConId )
    import GHC.Types.Id
    import GHC.Types.Var.Env
    import GHC.Utils.Misc    ( notNull )

    {-
    The liberate-case transformation
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    This module walks over @Core@, and looks for @case@ on free variables.
    The criterion is:
            if there is case on a free on the route to the recursive call,
            then the recursive call is replaced with an unfolding.

    Example

       f = \ t -> case v of
                     V a b -> a : f t

    => the inner f is replaced.

       f = \ t -> case v of
                     V a b -> a : (letrec
                                    f =  \ t -> case v of
                                                   V a b -> a : f t
                                   in f) t
    (note the NEED for shadowing)

    => Simplify

      f = \ t -> case v of
                     V a b -> a : (letrec
                                    f = \ t -> a : f t
                                   in f t)

    Better code, because 'a' is  free inside the inner letrec, rather
    than needing projection from v.

    Note that this deals with *free variables*.  SpecConstr deals with
    *arguments* that are of known form.  E.g.

            last []     = error
            last (x:[]) = x
            last (x:xs) = last xs

    Note [Scrutinee with cast]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider this:
        f = \ t -> case (v `cast` co) of
                     V a b -> a : f t

    Exactly the same optimisation (unrolling one call to f) will work here,
    despite the cast.  See mk_alt_env in the Case branch of libCase.

    To think about (Apr 94)
    ~~~~~~~~~~~~~~
    Main worry: duplicating code excessively.  At the moment we duplicate
    the entire binding group once at each recursive call.  But there may
    be a group of recursive calls which share a common set of evaluated
    free variables, in which case the duplication is a plain waste.

    Another thing we could consider adding is some unfold-threshold thing,
    so that we'll only duplicate if the size of the group rhss isn't too
    big.

    Data types
    ~~~~~~~~~~
    The ``level'' of a binder tells how many
    recursive defns lexically enclose the binding
    A recursive defn "encloses" its RHS, not its
    scope.  For example:
    \begin{verbatim}
            letrec f = let g = ... in ...
            in
            let h = ...
            in ...
    \end{verbatim}
    Here, the level of @f@ is zero, the level of @g@ is one,
    and the level of @h@ is zero (NB not one).

    ************************************************************************
    *                                                                      *
             Top-level code
    *                                                                      *
    ************************************************************************
    -}

    liberateCase :: DynFlags -> CoreProgram -> CoreProgram
    liberateCase :: DynFlags -> CoreProgram -> CoreProgram
    liberateCase DynFlags
    dflags CoreProgram
    binds = LibCaseEnv -> CoreProgram -> CoreProgram
    do_prog (DynFlags -> LibCaseEnv
    initLiberateCaseEnv DynFlags
    dflags) CoreProgram
    binds
      where
        do_prog :: LibCaseEnv -> CoreProgram -> CoreProgram
    do_prog LibCaseEnv
    _   [] = []
        do_prog LibCaseEnv
    env (CoreBind
    bind:CoreProgram
    binds) = CoreBind
    bind' forall a. a -> [a] -> [a]
    : LibCaseEnv -> CoreProgram -> CoreProgram
    do_prog LibCaseEnv
    env' CoreProgram
    binds
                                 where
                                   (LibCaseEnv
    env', CoreBind
    bind') = LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
    libCaseBind LibCaseEnv
    env CoreBind
    bind

    initLiberateCaseEnv :: DynFlags -> LibCaseEnv
    initLiberateCaseEnv :: DynFlags -> LibCaseEnv
    initLiberateCaseEnv DynFlags
    dflags = LibCaseEnv
       { lc_threshold :: Maybe LibCaseLevel
    lc_threshold = DynFlags -> Maybe LibCaseLevel
    liberateCaseThreshold DynFlags
    dflags
       , lc_uf_opts :: UnfoldingOpts
    lc_uf_opts   = DynFlags -> UnfoldingOpts
    unfoldingOpts DynFlags
    dflags
       , lc_lvl :: LibCaseLevel
    lc_lvl       = LibCaseLevel
    0
       , lc_lvl_env :: IdEnv LibCaseLevel
    lc_lvl_env   = forall a. VarEnv a
    emptyVarEnv
       , lc_rec_env :: IdEnv CoreBind
    lc_rec_env   = forall a. VarEnv a
    emptyVarEnv
       , lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
    lc_scruts    = []
       }

    {-
    ************************************************************************
    *                                                                      *
             Main payload
    *                                                                      *
    ************************************************************************

    Bindings
    ~~~~~~~~
    -}

    libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)

    libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
    libCaseBind LibCaseEnv
    env (NonRec Id
    binder Expr Id
    rhs)
      = (LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders LibCaseEnv
    env [Id
    binder], forall b. b -> Expr b -> Bind b
    NonRec Id
    binder (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    rhs))

    libCaseBind LibCaseEnv
    env (Rec [(Id, Expr Id)]
    pairs)
      = (LibCaseEnv
    env_body, forall b. [(b, Expr b)] -> Bind b
    Rec [(Id, Expr Id)]
    pairs')
      where
        binders :: [Id]
    binders = forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> a
    fst [(Id, Expr Id)]
    pairs

        env_body :: LibCaseEnv
    env_body = LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders LibCaseEnv
    env [Id]
    binders

        pairs' :: [(Id, Expr Id)]
    pairs' = [(Id
    binder, LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env_rhs Expr Id
    rhs) | (Id
    binder,Expr Id
    rhs) <- [(Id, Expr Id)]
    pairs]

            -- We extend the rec-env by binding each Id to its rhs, first
            -- processing the rhs with an *un-extended* environment, so
            -- that the same process doesn't occur for ever!
        env_rhs :: LibCaseEnv
    env_rhs | Bool
    is_dupable_bind = LibCaseEnv -> [(Id, Expr Id)] -> LibCaseEnv
    addRecBinds LibCaseEnv
    env [(Id, Expr Id)]
    dup_pairs
                | Bool
    otherwise       = LibCaseEnv
    env

        dup_pairs :: [(Id, Expr Id)]
    dup_pairs = [ (Id -> Id
    localiseId Id
    binder, LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env_body Expr Id
    rhs)
                    | (Id
    binder, Expr Id
    rhs) <- [(Id, Expr Id)]
    pairs ]
            -- localiseID : see Note [Need to localiseId in libCaseBind]

        is_dupable_bind :: Bool
    is_dupable_bind = Bool
    small_enough Bool -> Bool -> Bool
    && forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all forall {b}. (Id, b) -> Bool
    ok_pair [(Id, Expr Id)]
    pairs

        -- Size: we are going to duplicate dup_pairs; to find their
        --       size, build a fake binding (let { dup_pairs } in (),
        --       and find the size of that
        -- See Note [Small enough]
        small_enough :: Bool
    small_enough = case LibCaseEnv -> Maybe LibCaseLevel
    lc_threshold LibCaseEnv
    env of
                          Maybe LibCaseLevel
    Nothing   -> Bool
    True   -- Infinity
                          Just LibCaseLevel
    size -> UnfoldingOpts -> LibCaseLevel -> Expr Id -> Bool
    couldBeSmallEnoughToInline (LibCaseEnv -> UnfoldingOpts
    lc_uf_opts LibCaseEnv
    env) LibCaseLevel
    size forall a b. (a -> b) -> a -> b
    $
                                       forall b. Bind b -> Expr b -> Expr b
    Let (forall b. [(b, Expr b)] -> Bind b
    Rec [(Id, Expr Id)]
    dup_pairs) (forall b. Id -> Expr b
    Var Id
    unitDataConId)

        ok_pair :: (Id, b) -> Bool
    ok_pair (Id
    id,b
    _)
            =  Id -> LibCaseLevel
    idArity Id
    id forall a. Ord a => a -> a -> Bool
    > LibCaseLevel
    0       -- Note [Only functions!]
            Bool -> Bool -> Bool
    && Bool -> Bool
    not (Id -> Bool
    isDeadEndId Id
    id) -- Note [Not bottoming ids]

    {- Note [Not bottoming Ids]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Do not specialise error-functions (this is unusual, but I once saw it,
    (actually in Data.Typable.Internal)

    Note [Only functions!]
    ~~~~~~~~~~~~~~~~~~~~~~
    Consider the following code

           f = g (case v of V a b -> a : t f)

    where g is expensive. If we aren't careful, liberate case will turn this into

           f = g (case v of
                   V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
                                    in f)
                 )

    Yikes! We evaluate g twice. This leads to a O(2^n) explosion
    if g calls back to the same code recursively.

    Solution: make sure that we only do the liberate-case thing on *functions*

    Note [Small enough]
    ~~~~~~~~~~~~~~~~~~~
    Consider
      \fv. letrec
             f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
             g = \y. SMALL...f...

    Then we *can* in principle do liberate-case on 'g' (small RHS) but not
    for 'f' (too big).  But doing so is not profitable, because duplicating
    'g' at its call site in 'f' doesn't get rid of any cases.  So we just
    ask for the whole group to be small enough.

    Note [Need to localiseId in libCaseBind]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The call to localiseId is needed for two subtle reasons
    (a)  Reset the export flags on the binders so
            that we don't get name clashes on exported things if the
            local binding floats out to top level.  This is most unlikely
            to happen, since the whole point concerns free variables.
            But resetting the export flag is right regardless.

    (b)  Make the name an Internal one.  External Names should never be
            nested; if it were floated to the top level, we'd get a name
            clash at code generation time.

    Expressions
    ~~~~~~~~~~~
    -}

    libCase :: LibCaseEnv
            -> CoreExpr
            -> CoreExpr

    libCase :: LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env (Var Id
    v)             = LibCaseEnv -> Id -> [Expr Id] -> Expr Id
    libCaseApp LibCaseEnv
    env Id
    v []
    libCase LibCaseEnv
    _   (Lit Literal
    lit)           = forall b. Literal -> Expr b
    Lit Literal
    lit
    libCase LibCaseEnv
    _   (Type Type
    ty)           = forall b. Type -> Expr b
    Type Type
    ty
    libCase LibCaseEnv
    _   (Coercion Coercion
    co)       = forall b. Coercion -> Expr b
    Coercion Coercion
    co
    libCase LibCaseEnv
    env e :: Expr Id
    e@(App {})          | let (Expr Id
    fun, [Expr Id]
    args) = forall b. Expr b -> (Expr b, [Expr b])
    collectArgs Expr Id
    e
                                    , Var Id
    v <- Expr Id
    fun
                                    = LibCaseEnv -> Id -> [Expr Id] -> Expr Id
    libCaseApp LibCaseEnv
    env Id
    v [Expr Id]
    args
    libCase LibCaseEnv
    env (App Expr Id
    fun Expr Id
    arg)       = forall b. Expr b -> Expr b -> Expr b
    App (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    fun) (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    arg)
    libCase LibCaseEnv
    env (Tick CoreTickish
    tickish Expr Id
    body) = forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    tickish (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    body)
    libCase LibCaseEnv
    env (Cast Expr Id
    e Coercion
    co)         = forall b. Expr b -> Coercion -> Expr b
    Cast (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    e) Coercion
    co

    libCase LibCaseEnv
    env (Lam Id
    binder Expr Id
    body)
      = forall b. b -> Expr b -> Expr b
    Lam Id
    binder (LibCaseEnv -> Expr Id -> Expr Id
    libCase (LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders LibCaseEnv
    env [Id
    binder]) Expr Id
    body)

    libCase LibCaseEnv
    env (Let CoreBind
    bind Expr Id
    body)
      = forall b. Bind b -> Expr b -> Expr b
    Let CoreBind
    bind' (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env_body Expr Id
    body)
      where
        (LibCaseEnv
    env_body, CoreBind
    bind') = LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
    libCaseBind LibCaseEnv
    env CoreBind
    bind

    libCase LibCaseEnv
    env (Case Expr Id
    scrut Id
    bndr Type
    ty [Alt Id]
    alts)
      = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env Expr Id
    scrut) Id
    bndr Type
    ty (forall a b. (a -> b) -> [a] -> [b]
    map (LibCaseEnv -> Alt Id -> Alt Id
    libCaseAlt LibCaseEnv
    env_alts) [Alt Id]
    alts)
      where
        env_alts :: LibCaseEnv
    env_alts = LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders (Expr Id -> LibCaseEnv
    mk_alt_env Expr Id
    scrut) [Id
    bndr]
        mk_alt_env :: Expr Id -> LibCaseEnv
    mk_alt_env (Var Id
    scrut_var) = LibCaseEnv -> Id -> LibCaseEnv
    addScrutedVar LibCaseEnv
    env Id
    scrut_var
        mk_alt_env (Cast Expr Id
    scrut Coercion
    _)  = Expr Id -> LibCaseEnv
    mk_alt_env Expr Id
    scrut       -- Note [Scrutinee with cast]
        mk_alt_env Expr Id
    _               = LibCaseEnv
    env

    libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr
    libCaseAlt :: LibCaseEnv -> Alt Id -> Alt Id
    libCaseAlt LibCaseEnv
    env (Alt AltCon
    con [Id]
    args Expr Id
    rhs) = forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Id]
    args (LibCaseEnv -> Expr Id -> Expr Id
    libCase (LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders LibCaseEnv
    env [Id]
    args) Expr Id
    rhs)

    {-
    Ids
    ~~~

    To unfold, we can't just wrap the id itself in its binding if it's a join point:

      jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!

    Every jump must provide all arguments, so we have to be careful to wrap the
    whole jump instead:

      jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right

    -}

    libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr
    libCaseApp :: LibCaseEnv -> Id -> [Expr Id] -> Expr Id
    libCaseApp LibCaseEnv
    env Id
    v [Expr Id]
    args
      | Just CoreBind
    the_bind <- LibCaseEnv -> Id -> Maybe CoreBind
    lookupRecId LibCaseEnv
    env Id
    v  -- It's a use of a recursive thing
      , forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [Id]
    free_scruts                 -- with free vars scrutinised in RHS
      = forall b. Bind b -> Expr b -> Expr b
    Let CoreBind
    the_bind Expr Id
    expr'

      | Bool
    otherwise
      = Expr Id
    expr'

      where
        rec_id_level :: LibCaseLevel
    rec_id_level = LibCaseEnv -> Id -> LibCaseLevel
    lookupLevel LibCaseEnv
    env Id
    v
        free_scruts :: [Id]
    free_scruts  = LibCaseEnv -> LibCaseLevel -> [Id]
    freeScruts LibCaseEnv
    env LibCaseLevel
    rec_id_level
        expr' :: Expr Id
    expr'        = forall b. Expr b -> [Expr b] -> Expr b
    mkApps (forall b. Id -> Expr b
    Var Id
    v) (forall a b. (a -> b) -> [a] -> [b]
    map (LibCaseEnv -> Expr Id -> Expr Id
    libCase LibCaseEnv
    env) [Expr Id]
    args)

    freeScruts :: LibCaseEnv
               -> LibCaseLevel      -- Level of the recursive Id
               -> [Id]              -- Ids that are scrutinised between the binding
                                    -- of the recursive Id and here
    freeScruts :: LibCaseEnv -> LibCaseLevel -> [Id]
    freeScruts LibCaseEnv
    env LibCaseLevel
    rec_bind_lvl
      = [Id
    v | (Id
    v, LibCaseLevel
    scrut_bind_lvl, LibCaseLevel
    scrut_at_lvl) <- LibCaseEnv -> [(Id, LibCaseLevel, LibCaseLevel)]
    lc_scruts LibCaseEnv
    env
           , LibCaseLevel
    scrut_bind_lvl forall a. Ord a => a -> a -> Bool
    <= LibCaseLevel
    rec_bind_lvl
           , LibCaseLevel
    scrut_at_lvl forall a. Ord a => a -> a -> Bool
    > LibCaseLevel
    rec_bind_lvl]
            -- Note [When to specialise]
            -- Note [Avoiding fruitless liberate-case]

    {-
    Note [When to specialise]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      f = \x. letrec g = \y. case x of
                               True  -> ... (f a) ...
                               False -> ... (g b) ...

    We get the following levels
              f  0
              x  1
              g  1
              y  2

    Then 'x' is being scrutinised at a deeper level than its binding, so
    it's added to lc_sruts:  [(x,1)]

    We do *not* want to specialise the call to 'f', because 'x' is not free
    in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).

    We *do* want to specialise the call to 'g', because 'x' is free in g.
    Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).

    Note [Avoiding fruitless liberate-case]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider also:
      f = \x. case top_lvl_thing of
                    I# _ -> let g = \y. ... g ...
                            in ...

    Here, top_lvl_thing is scrutinised at a level (1) deeper than its
    binding site (0).  Nevertheless, we do NOT want to specialise the call
    to 'g' because all the structure in its free variables is already
    visible at the definition site for g.  Hence, when considering specialising
    an occurrence of 'g', we want to check that there's a scruted-var v st

       a) v's binding site is *outside* g
       b) v's scrutinisation site is *inside* g

    ************************************************************************
    *                                                                      *
            Utility functions
    *                                                                      *
    ************************************************************************
    -}

    addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
    addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv
    addBinders env :: LibCaseEnv
    env@(LibCaseEnv { lc_lvl :: LibCaseEnv -> LibCaseLevel
    lc_lvl = LibCaseLevel
    lvl, lc_lvl_env :: LibCaseEnv -> IdEnv LibCaseLevel
    lc_lvl_env = IdEnv LibCaseLevel
    lvl_env }) [Id]
    binders
      = LibCaseEnv
    env { lc_lvl_env :: IdEnv LibCaseLevel
    lc_lvl_env = IdEnv LibCaseLevel
    lvl_env' }
      where
        lvl_env' :: IdEnv LibCaseLevel
    lvl_env' = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
    extendVarEnvList IdEnv LibCaseLevel
    lvl_env ([Id]
    binders forall a b. [a] -> [b] -> [(a, b)]
    `zip` forall a. a -> [a]
    repeat LibCaseLevel
    lvl)

    addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
    addRecBinds :: LibCaseEnv -> [(Id, Expr Id)] -> LibCaseEnv
    addRecBinds env :: LibCaseEnv
    env@(LibCaseEnv {lc_lvl :: LibCaseEnv -> LibCaseLevel
    lc_lvl = LibCaseLevel
    lvl, lc_lvl_env :: LibCaseEnv -> IdEnv LibCaseLevel
    lc_lvl_env = IdEnv LibCaseLevel
    lvl_env,
                                 lc_rec_env :: LibCaseEnv -> IdEnv CoreBind
    lc_rec_env = IdEnv CoreBind
    rec_env}) [(Id, Expr Id)]
    pairs
      = LibCaseEnv
    env { lc_lvl :: LibCaseLevel
    lc_lvl = LibCaseLevel
    lvl', lc_lvl_env :: IdEnv LibCaseLevel
    lc_lvl_env = IdEnv LibCaseLevel
    lvl_env', lc_rec_env :: IdEnv CoreBind
    lc_rec_env = IdEnv CoreBind
    rec_env' }
      where
        lvl' :: LibCaseLevel
    lvl'     = LibCaseLevel
    lvl forall a. Num a => a -> a -> a
    + LibCaseLevel
    1
        lvl_env' :: IdEnv LibCaseLevel
    lvl_env' = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
    extendVarEnvList IdEnv LibCaseLevel
    lvl_env [(Id
    binder,LibCaseLevel
    lvl) | (Id
    binder,Expr Id
    _) <- [(Id, Expr Id)]
    pairs]
        rec_env' :: IdEnv CoreBind
    rec_env' = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
    extendVarEnvList IdEnv CoreBind
    rec_env [(Id
    binder, forall b. [(b, Expr b)] -> Bind b
    Rec [(Id, Expr Id)]
    pairs) | (Id
    binder,Expr Id
    _) <- [(Id, Expr Id)]
    pairs]

    addScrutedVar :: LibCaseEnv
                  -> Id             -- This Id is being scrutinised by a case expression
                  -> LibCaseEnv

    addScrutedVar :: LibCaseEnv -> Id -> LibCaseEnv
    addScrutedVar env :: LibCaseEnv
    env@(LibCaseEnv { lc_lvl :: LibCaseEnv -> LibCaseLevel
    lc_lvl = LibCaseLevel
    lvl, lc_lvl_env :: LibCaseEnv -> IdEnv LibCaseLevel
    lc_lvl_env = IdEnv LibCaseLevel
    lvl_env,
                                    lc_scruts :: LibCaseEnv -> [(Id, LibCaseLevel, LibCaseLevel)]
    lc_scruts = [(Id, LibCaseLevel, LibCaseLevel)]
    scruts }) Id
    scrut_var
      | LibCaseLevel
    bind_lvl forall a. Ord a => a -> a -> Bool
    < LibCaseLevel
    lvl
      = LibCaseEnv
    env { lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
    lc_scruts = [(Id, LibCaseLevel, LibCaseLevel)]
    scruts' }
            -- Add to scruts iff the scrut_var is being scrutinised at
            -- a deeper level than its defn

      | Bool
    otherwise = LibCaseEnv
    env
      where
        scruts' :: [(Id, LibCaseLevel, LibCaseLevel)]
    scruts'  = (Id
    scrut_var, LibCaseLevel
    bind_lvl, LibCaseLevel
    lvl) forall a. a -> [a] -> [a]
    : [(Id, LibCaseLevel, LibCaseLevel)]
    scruts
        bind_lvl :: LibCaseLevel
    bind_lvl = case forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv IdEnv LibCaseLevel
    lvl_env Id
    scrut_var of
                     Just LibCaseLevel
    lvl -> LibCaseLevel
    lvl
                     Maybe LibCaseLevel
    Nothing  -> LibCaseLevel
    topLevel

    lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
    lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
    lookupRecId LibCaseEnv
    env Id
    id = forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv (LibCaseEnv -> IdEnv CoreBind
    lc_rec_env LibCaseEnv
    env) Id
    id

    lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
    lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
    lookupLevel LibCaseEnv
    env Id
    id
      = case forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv (LibCaseEnv -> IdEnv LibCaseLevel
    lc_lvl_env LibCaseEnv
    env) Id
    id of
          Just LibCaseLevel
    lvl -> LibCaseLevel
    lvl
          Maybe LibCaseLevel
    Nothing  -> LibCaseLevel
    topLevel

    {-
    ************************************************************************
    *                                                                      *
             The environment
    *                                                                      *
    ************************************************************************
    -}

    type LibCaseLevel = Int

    topLevel :: LibCaseLevel
    topLevel :: LibCaseLevel
    topLevel = LibCaseLevel
    0

    data LibCaseEnv
      = LibCaseEnv {
            LibCaseEnv -> Maybe LibCaseLevel
    lc_threshold :: Maybe Int,
                    -- ^ Bomb-out size for deciding if potential liberatees are too
                    -- big.

            LibCaseEnv -> UnfoldingOpts
    lc_uf_opts :: UnfoldingOpts,
                    -- ^ Unfolding options

            LibCaseEnv -> LibCaseLevel
    lc_lvl :: LibCaseLevel, -- ^ Current level
                    -- The level is incremented when (and only when) going
                    -- inside the RHS of a (sufficiently small) recursive
                    -- function.

            LibCaseEnv -> IdEnv LibCaseLevel
    lc_lvl_env :: IdEnv LibCaseLevel,
                    -- ^ Binds all non-top-level in-scope Ids (top-level and
                    -- imported things have a level of zero)

            LibCaseEnv -> IdEnv CoreBind
    lc_rec_env :: IdEnv CoreBind,
                    -- ^ Binds *only* recursively defined ids, to their own
                    -- binding group, and *only* in their own RHSs

            LibCaseEnv -> [(Id, LibCaseLevel, LibCaseLevel)]
    lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
                    -- ^ Each of these Ids was scrutinised by an enclosing
                    -- case expression, at a level deeper than its binding
                    -- level.
                    --
                    -- The first LibCaseLevel is the *binding level* of
                    --   the scrutinised Id,
                    -- The second is the level *at which it was scrutinised*.
                    --   (see Note [Avoiding fruitless liberate-case])
                    -- The former is a bit redundant, since you could always
                    -- look it up in lc_lvl_env, but it's just cached here
                    --
                    -- The order is insignificant; it's a bag really
                    --
                    -- There's one element per scrutinisation;
                    --    in principle the same Id may appear multiple times,
                    --    although that'd be unusual:
                    --       case x of { (a,b) -> ....(case x of ...) .. }
            }