{-
(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' CoreBind -> CoreProgram -> CoreProgram
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   = IdEnv LibCaseLevel
forall a. VarEnv a
emptyVarEnv
   , lc_rec_env :: IdEnv CoreBind
lc_rec_env   = IdEnv CoreBind
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], Id -> Expr Id -> CoreBind
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, [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
pairs')
  where
    binders :: [Id]
binders = ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
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
&& ((Id, Expr Id) -> Bool) -> [(Id, Expr Id)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Id, Expr Id) -> Bool
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 (Expr Id -> Bool) -> Expr Id -> Bool
forall a b. (a -> b) -> a -> b
$
                                   CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let ([(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
dup_pairs) (Id -> Expr Id
forall b. Id -> Expr b
Var Id
unitDataConId)

    ok_pair :: (Id, b) -> Bool
ok_pair (Id
id,b
_)
        =  Id -> LibCaseLevel
idArity Id
id LibCaseLevel -> LibCaseLevel -> Bool
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)           = Literal -> Expr Id
forall b. Literal -> Expr b
Lit Literal
lit
libCase LibCaseEnv
_   (Type Type
ty)           = Type -> Expr Id
forall b. Type -> Expr b
Type Type
ty
libCase LibCaseEnv
_   (Coercion Coercion
co)       = Coercion -> Expr Id
forall b. Coercion -> Expr b
Coercion Coercion
co
libCase LibCaseEnv
env e :: Expr Id
e@(App {})          | let (Expr Id
fun, [Expr Id]
args) = Expr Id -> (Expr Id, [Expr Id])
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)       = Expr Id -> Expr Id -> Expr Id
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) = CoreTickish -> Expr Id -> Expr Id
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)         = Expr Id -> Coercion -> Expr Id
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)
  = Id -> Expr Id -> Expr Id
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)
  = CoreBind -> Expr Id -> Expr Id
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)
  = Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
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 ((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
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) = AltCon -> [Id] -> Expr Id -> Alt Id
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
  , [Id] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Id]
free_scruts                 -- with free vars scrutinised in RHS
  = CoreBind -> Expr Id -> Expr Id
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'        = Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
v) ((Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
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 LibCaseLevel -> LibCaseLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LibCaseLevel
rec_bind_lvl
       , LibCaseLevel
scrut_at_lvl LibCaseLevel -> LibCaseLevel -> Bool
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' = IdEnv LibCaseLevel -> [(Id, LibCaseLevel)] -> IdEnv LibCaseLevel
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv LibCaseLevel
lvl_env ([Id]
binders [Id] -> [LibCaseLevel] -> [(Id, LibCaseLevel)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` LibCaseLevel -> [LibCaseLevel]
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 LibCaseLevel -> LibCaseLevel -> LibCaseLevel
forall a. Num a => a -> a -> a
+ LibCaseLevel
1
    lvl_env' :: IdEnv LibCaseLevel
lvl_env' = IdEnv LibCaseLevel -> [(Id, LibCaseLevel)] -> IdEnv LibCaseLevel
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' = IdEnv CoreBind -> [(Id, CoreBind)] -> IdEnv CoreBind
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv CoreBind
rec_env [(Id
binder, [(Id, Expr Id)] -> CoreBind
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 LibCaseLevel -> LibCaseLevel -> Bool
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) (Id, LibCaseLevel, LibCaseLevel)
-> [(Id, LibCaseLevel, LibCaseLevel)]
-> [(Id, LibCaseLevel, LibCaseLevel)]
forall a. a -> [a] -> [a]
: [(Id, LibCaseLevel, LibCaseLevel)]
scruts
    bind_lvl :: LibCaseLevel
bind_lvl = case IdEnv LibCaseLevel -> Id -> Maybe LibCaseLevel
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 = IdEnv CoreBind -> Id -> Maybe CoreBind
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 IdEnv LibCaseLevel -> Id -> Maybe LibCaseLevel
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 ...) .. }
        }