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

\section[SimplMonad]{The simplifier Monad}
-}

{-# LANGUAGE CPP #-}

module SimplEnv (
        -- * The simplifier mode
        setMode, getMode, updMode, seDynFlags,

        -- * Environments
        SimplEnv(..), pprSimplEnv,   -- Temp not abstract
        mkSimplEnv, extendIdSubst,
        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
        zapSubstEnv, setSubstEnv,
        getInScope, setInScopeFromE, setInScopeFromF,
        setInScopeSet, modifyInScope, addNewInScopeIds,
        getSimplRules,

        -- * Substitution results
        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,

        -- * Simplifying 'Id' binders
        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
        simplBinder, simplBinders,
        substTy, substTyVar, getTCvSubst,
        substCo, substCoVar,

        -- * Floats
        SimplFloats(..), emptyFloats, mkRecFloats,
        mkFloatBind, addLetFloats, addJoinFloats, addFloats,
        extendFloats, wrapFloats,
        doFloatFromRhs, getTopFloatBinds,

        -- * LetFloats
        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
        addLetFlts,  mapLetFloats,

        -- * JoinFloats
        JoinFloat, JoinFloats, emptyJoinFloats,
        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
    ) where

#include "HsVersions.h"

import GhcPrelude

import SimplMonad
import CoreMonad                ( SimplMode(..) )
import CoreSyn
import CoreUtils
import Var
import VarEnv
import VarSet
import OrdList
import Id
import MkCore                   ( mkWildValBinder )
import DynFlags                 ( DynFlags )
import TysWiredIn
import qualified Type
import Type hiding              ( substTy, substTyVar, substTyVarBndr )
import qualified Coercion
import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )
import BasicTypes
import MonadUtils
import Outputable
import Util
import UniqFM                   ( pprUniqFM )

import Data.List (mapAccumL)

{-
************************************************************************
*                                                                      *
\subsubsection{The @SimplEnv@ type}
*                                                                      *
************************************************************************
-}

data SimplEnv
  = SimplEnv {
     ----------- Static part of the environment -----------
     -- Static in the sense of lexically scoped,
     -- wrt the original expression

        SimplEnv -> SimplMode
seMode      :: SimplMode

        -- The current substitution
      , SimplEnv -> TvSubstEnv
seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType
      , SimplEnv -> CvSubstEnv
seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion
      , SimplEnv -> SimplIdSubst
seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr

     ----------- Dynamic part of the environment -----------
     -- Dynamic in the sense of describing the setup where
     -- the expression finally ends up

        -- The current set of in-scope variables
        -- They are all OutVars, and all bound in this module
      , SimplEnv -> InScopeSet
seInScope   :: InScopeSet       -- OutVars only
    }

data SimplFloats
  = SimplFloats
      { -- Ordinary let bindings
        SimplFloats -> LetFloats
sfLetFloats  :: LetFloats
                -- See Note [LetFloats]

        -- Join points
      , SimplFloats -> JoinFloats
sfJoinFloats :: JoinFloats
                -- Handled separately; they don't go very far
                -- We consider these to be /inside/ sfLetFloats
                -- because join points can refer to ordinary bindings,
                -- but not vice versa

        -- Includes all variables bound by sfLetFloats and
        -- sfJoinFloats, plus at least whatever is in scope where
        -- these bindings land up.
      , SimplFloats -> InScopeSet
sfInScope :: InScopeSet  -- All OutVars
      }

instance Outputable SimplFloats where
  ppr :: SimplFloats -> SDoc
ppr (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats = LetFloats
lf, sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jf, sfInScope :: SimplFloats -> InScopeSet
sfInScope = InScopeSet
is })
    = String -> SDoc
text String
"SimplFloats"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"lets: " SDoc -> SDoc -> SDoc
<+> LetFloats -> SDoc
forall a. Outputable a => a -> SDoc
ppr LetFloats
lf
                       , String -> SDoc
text String
"joins:" SDoc -> SDoc -> SDoc
<+> JoinFloats -> SDoc
forall a. Outputable a => a -> SDoc
ppr JoinFloats
jf
                       , String -> SDoc
text String
"in_scope:" SDoc -> SDoc -> SDoc
<+> InScopeSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr InScopeSet
is ])

emptyFloats :: SimplEnv -> SimplFloats
emptyFloats :: SimplEnv -> SimplFloats
emptyFloats SimplEnv
env
  = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
emptyLetFloats
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
emptyJoinFloats
                , sfInScope :: InScopeSet
sfInScope    = SimplEnv -> InScopeSet
seInScope SimplEnv
env }

pprSimplEnv :: SimplEnv -> SDoc
-- Used for debugging; selective
pprSimplEnv :: SimplEnv -> SDoc
pprSimplEnv SimplEnv
env
  = [SDoc] -> SDoc
vcat [String -> SDoc
text String
"TvSubst:" SDoc -> SDoc -> SDoc
<+> TvSubstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimplEnv -> TvSubstEnv
seTvSubst SimplEnv
env),
          String -> SDoc
text String
"CvSubst:" SDoc -> SDoc -> SDoc
<+> CvSubstEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimplEnv -> CvSubstEnv
seCvSubst SimplEnv
env),
          String -> SDoc
text String
"IdSubst:" SDoc -> SDoc -> SDoc
<+> SDoc
id_subst_doc,
          String -> SDoc
text String
"InScope:" SDoc -> SDoc -> SDoc
<+> SDoc
in_scope_vars_doc
    ]
  where
   id_subst_doc :: SDoc
id_subst_doc = (SimplSR -> SDoc) -> SimplIdSubst -> SDoc
forall a. (a -> SDoc) -> UniqFM a -> SDoc
pprUniqFM SimplSR -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SimplEnv -> SimplIdSubst
seIdSubst SimplEnv
env)
   in_scope_vars_doc :: SDoc
in_scope_vars_doc = VarSet -> ([Var] -> SDoc) -> SDoc
pprVarSet (InScopeSet -> VarSet
getInScopeVars (SimplEnv -> InScopeSet
seInScope SimplEnv
env))
                                 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> ([Var] -> [SDoc]) -> [Var] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> SDoc
ppr_one)
   ppr_one :: Var -> SDoc
ppr_one Var
v | Var -> Bool
isId Var
v = Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<+> Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Unfolding
idUnfolding Var
v)
             | Bool
otherwise = Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v

type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
        -- See Note [Extending the Subst] in CoreSubst

-- | A substitution result.
data SimplSR
  = DoneEx OutExpr (Maybe JoinArity)
       -- If  x :-> DoneEx e ja   is in the SimplIdSubst
       -- then replace occurrences of x by e
       -- and  ja = Just a <=> x is a join-point of arity a
       -- See Note [Join arity in SimplIdSubst]


  | DoneId OutId
       -- If  x :-> DoneId v   is in the SimplIdSubst
       -- then replace occurrences of x by v
       -- and  v is a join-point of arity a
       --      <=> x is a join-point of arity a

  | ContEx TvSubstEnv                 -- A suspended substitution
           CvSubstEnv
           SimplIdSubst
           InExpr
      -- If   x :-> ContEx tv cv id e   is in the SimplISubst
      -- then replace occurrences of x by (subst (tv,cv,id) e)

instance Outputable SimplSR where
  ppr :: SimplSR -> SDoc
ppr (DoneId Var
v)    = String -> SDoc
text String
"DoneId" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v
  ppr (DoneEx OutExpr
e Maybe JoinArity
mj) = String -> SDoc
text String
"DoneEx" SDoc -> SDoc -> SDoc
<> SDoc
pp_mj SDoc -> SDoc -> SDoc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
e
    where
      pp_mj :: SDoc
pp_mj = case Maybe JoinArity
mj of
                Maybe JoinArity
Nothing -> SDoc
empty
                Just JoinArity
n  -> SDoc -> SDoc
parens (JoinArity -> SDoc
int JoinArity
n)

  ppr (ContEx TvSubstEnv
_tv CvSubstEnv
_cv SimplIdSubst
_id OutExpr
e) = [SDoc] -> SDoc
vcat [String -> SDoc
text String
"ContEx" SDoc -> SDoc -> SDoc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
e {-,
                                ppr (filter_env tv), ppr (filter_env id) -}]
        -- where
        -- fvs = exprFreeVars e
        -- filter_env env = filterVarEnv_Directly keep env
        -- keep uniq _ = uniq `elemUFM_Directly` fvs

{-
Note [SimplEnv invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
seInScope:
        The in-scope part of Subst includes *all* in-scope TyVars and Ids
        The elements of the set may have better IdInfo than the
        occurrences of in-scope Ids, and (more important) they will
        have a correctly-substituted type.  So we use a lookup in this
        set to replace occurrences

        The Ids in the InScopeSet are replete with their Rules,
        and as we gather info about the unfolding of an Id, we replace
        it in the in-scope set.

        The in-scope set is actually a mapping OutVar -> OutVar, and
        in case expressions we sometimes bind

seIdSubst:
        The substitution is *apply-once* only, because InIds and OutIds
        can overlap.
        For example, we generally omit mappings
                a77 -> a77
        from the substitution, when we decide not to clone a77, but it's quite
        legitimate to put the mapping in the substitution anyway.

        Furthermore, consider
                let x = case k of I# x77 -> ... in
                let y = case k of I# x77 -> ... in ...
        and suppose the body is strict in both x and y.  Then the simplifier
        will pull the first (case k) to the top; so the second (case k) will
        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
        other is an out-Id.

        Of course, the substitution *must* applied! Things in its domain
        simply aren't necessarily bound in the result.

* substId adds a binding (DoneId new_id) to the substitution if
        the Id's unique has changed

  Note, though that the substitution isn't necessarily extended
  if the type of the Id changes.  Why not?  Because of the next point:

* We *always, always* finish by looking up in the in-scope set
  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
  Reason: so that we never finish up with a "old" Id in the result.
  An old Id might point to an old unfolding and so on... which gives a space
  leak.

  [The DoneEx and DoneVar hits map to "new" stuff.]

* It follows that substExpr must not do a no-op if the substitution is empty.
  substType is free to do so, however.

* When we come to a let-binding (say) we generate new IdInfo, including an
  unfolding, attach it to the binder, and add this newly adorned binder to
  the in-scope set.  So all subsequent occurrences of the binder will get
  mapped to the full-adorned binder, which is also the one put in the
  binding site.

* The in-scope "set" usually maps x->x; we use it simply for its domain.
  But sometimes we have two in-scope Ids that are synomyms, and should
  map to the same target:  x->x, y->x.  Notably:
        case y of x { ... }
  That's why the "set" is actually a VarEnv Var

Note [Join arity in SimplIdSubst]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have to remember which incoming variables are join points: the occurrences
may not be marked correctly yet, and we're in change of propagating the change if
OccurAnal makes something a join point).

Normally the in-scope set is where we keep the latest information, but
the in-scope set tracks only OutVars; if a binding is unconditionally
inlined (via DoneEx), it never makes it into the in-scope set, and we
need to know at the occurrence site that the variable is a join point
so that we know to drop the context. Thus we remember which join
points we're substituting. -}

mkSimplEnv :: SimplMode -> SimplEnv
mkSimplEnv :: SimplMode -> SimplEnv
mkSimplEnv SimplMode
mode
  = SimplEnv :: SimplMode
-> TvSubstEnv
-> CvSubstEnv
-> SimplIdSubst
-> InScopeSet
-> SimplEnv
SimplEnv { seMode :: SimplMode
seMode = SimplMode
mode
             , seInScope :: InScopeSet
seInScope = InScopeSet
init_in_scope
             , seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
forall a. VarEnv a
emptyVarEnv
             , seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
forall a. VarEnv a
emptyVarEnv
             , seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
forall a. VarEnv a
emptyVarEnv }
        -- The top level "enclosing CC" is "SUBSUMED".

init_in_scope :: InScopeSet
init_in_scope :: InScopeSet
init_in_scope = VarSet -> InScopeSet
mkInScopeSet (Var -> VarSet
unitVarSet (Type -> Var
mkWildValBinder Type
unitTy))
              -- See Note [WildCard binders]

{-
Note [WildCard binders]
~~~~~~~~~~~~~~~~~~~~~~~
The program to be simplified may have wild binders
    case e of wild { p -> ... }
We want to *rename* them away, so that there are no
occurrences of 'wild-id' (with wildCardKey).  The easy
way to do that is to start of with a representative
Id in the in-scope set

There can be *occurrences* of wild-id.  For example,
MkCore.mkCoreApp transforms
   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
This is ok provided 'wild' isn't free in 'e', and that's the delicate
thing. Generally, you want to run the simplifier to get rid of the
wild-ids before doing much else.

It's a very dark corner of GHC.  Maybe it should be cleaned up.
-}

getMode :: SimplEnv -> SimplMode
getMode :: SimplEnv -> SimplMode
getMode SimplEnv
env = SimplEnv -> SimplMode
seMode SimplEnv
env

seDynFlags :: SimplEnv -> DynFlags
seDynFlags :: SimplEnv -> DynFlags
seDynFlags SimplEnv
env = SimplMode -> DynFlags
sm_dflags (SimplEnv -> SimplMode
seMode SimplEnv
env)

setMode :: SimplMode -> SimplEnv -> SimplEnv
setMode :: SimplMode -> SimplEnv -> SimplEnv
setMode SimplMode
mode SimplEnv
env = SimplEnv
env { seMode :: SimplMode
seMode = SimplMode
mode }

updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode SimplMode -> SimplMode
upd SimplEnv
env = SimplEnv
env { seMode :: SimplMode
seMode = SimplMode -> SimplMode
upd (SimplEnv -> SimplMode
seMode SimplEnv
env) }

---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst :: SimplEnv -> Var -> SimplSR -> SimplEnv
extendIdSubst env :: SimplEnv
env@(SimplEnv {seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
subst}) Var
var SimplSR
res
  = ASSERT2( isId var && not (isCoVar var), ppr var )
    SimplEnv
env { seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst -> Var -> SimplSR -> SimplIdSubst
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv SimplIdSubst
subst Var
var SimplSR
res }

extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst :: SimplEnv -> Var -> Type -> SimplEnv
extendTvSubst env :: SimplEnv
env@(SimplEnv {seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tsubst}) Var
var Type
res
  = ASSERT2( isTyVar var, ppr var $$ ppr res )
    SimplEnv
env {seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv -> Var -> Type -> TvSubstEnv
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv TvSubstEnv
tsubst Var
var Type
res}

extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
extendCvSubst :: SimplEnv -> Var -> Coercion -> SimplEnv
extendCvSubst env :: SimplEnv
env@(SimplEnv {seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
csubst}) Var
var Coercion
co
  = ASSERT( isCoVar var )
    SimplEnv
env {seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv -> Var -> Coercion -> CvSubstEnv
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv CvSubstEnv
csubst Var
var Coercion
co}

---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope :: SimplEnv -> InScopeSet
getInScope SimplEnv
env = SimplEnv -> InScopeSet
seInScope SimplEnv
env

setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet SimplEnv
env InScopeSet
in_scope = SimplEnv
env {seInScope :: InScopeSet
seInScope = InScopeSet
in_scope}

setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
-- See Note [Setting the right in-scope set]
setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
setInScopeFromE SimplEnv
rhs_env SimplEnv
here_env = SimplEnv
rhs_env { seInScope :: InScopeSet
seInScope = SimplEnv -> InScopeSet
seInScope SimplEnv
here_env }

setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF SimplEnv
env SimplFloats
floats = SimplEnv
env { seInScope :: InScopeSet
seInScope = SimplFloats -> InScopeSet
sfInScope SimplFloats
floats }

addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
        -- The new Ids are guaranteed to be freshly allocated
addNewInScopeIds :: SimplEnv -> [Var] -> SimplEnv
addNewInScopeIds env :: SimplEnv
env@(SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
id_subst }) [Var]
vs
  = SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope InScopeSet -> [Var] -> InScopeSet
`extendInScopeSetList` [Var]
vs,
          seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
id_subst SimplIdSubst -> [Var] -> SimplIdSubst
forall a. VarEnv a -> [Var] -> VarEnv a
`delVarEnvList` [Var]
vs }
        -- Why delete?  Consider
        --      let x = a*b in (x, \x -> x+3)
        -- We add [x |-> a*b] to the substitution, but we must
        -- _delete_ it from the substitution when going inside
        -- the (\x -> ...)!

modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
-- The variable should already be in scope, but
-- replace the existing version with this new one
-- which has more information
modifyInScope :: SimplEnv -> Var -> SimplEnv
modifyInScope env :: SimplEnv
env@(SimplEnv {seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope}) Var
v
  = SimplEnv
env {seInScope :: InScopeSet
seInScope = InScopeSet -> Var -> InScopeSet
extendInScopeSet InScopeSet
in_scope Var
v}

{- Note [Setting the right in-scope set]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  \x. (let x = e in b) arg[x]
where the let shadows the lambda.  Really this means something like
  \x1. (let x2 = e in b) arg[x1]

- When we capture the 'arg' in an ApplyToVal continuation, we capture
  the environment, which says what 'x' is bound to, namely x1

- Then that continuation gets pushed under the let

- Finally we simplify 'arg'.  We want
     - the static, lexical environment bindig x :-> x1
     - the in-scopeset from "here", under the 'let' which includes
       both x1 and x2

It's important to have the right in-scope set, else we may rename a
variable to one that is already in scope.  So we must pick up the
in-scope set from "here", but otherwise use the environment we
captured along with 'arg'.  This transfer of in-scope set is done by
setInScopeFromE.
-}

---------------------
zapSubstEnv :: SimplEnv -> SimplEnv
zapSubstEnv :: SimplEnv -> SimplEnv
zapSubstEnv SimplEnv
env = SimplEnv
env {seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
forall a. VarEnv a
emptyVarEnv, seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
forall a. VarEnv a
emptyVarEnv, seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
forall a. VarEnv a
emptyVarEnv}

setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
setSubstEnv SimplEnv
env TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids = SimplEnv
env { seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
tvs, seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
cvs, seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
ids }

mkContEx :: SimplEnv -> InExpr -> SimplSR
mkContEx :: SimplEnv -> OutExpr -> SimplSR
mkContEx (SimplEnv { seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tvs, seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
cvs, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
ids }) OutExpr
e = TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> OutExpr -> SimplSR
ContEx TvSubstEnv
tvs CvSubstEnv
cvs SimplIdSubst
ids OutExpr
e

{-
************************************************************************
*                                                                      *
\subsection{LetFloats}
*                                                                      *
************************************************************************

Note [LetFloats]
~~~~~~~~~~~~~~~~
The LetFloats is a bunch of bindings, classified by a FloatFlag.

* All of them satisfy the let/app invariant

Examples

  NonRec x (y:ys)       FltLifted
  Rec [(x,rhs)]         FltLifted

  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n

  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge

Can't happen:
  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
  NonRec x# (f y)       -- Might diverge; does not satisfy let/app
-}

data LetFloats = LetFloats (OrdList OutBind) FloatFlag
                 -- See Note [LetFloats]

type JoinFloat  = OutBind
type JoinFloats = OrdList JoinFloat

data FloatFlag
  = FltLifted   -- All bindings are lifted and lazy *or*
                --     consist of a single primitive string literal
                --  Hence ok to float to top level, or recursive

  | FltOkSpec   -- All bindings are FltLifted *or*
                --      strict (perhaps because unlifted,
                --      perhaps because of a strict binder),
                --        *and* ok-for-speculation
                --  Hence ok to float out of the RHS
                --  of a lazy non-recursive let binding
                --  (but not to top level, or into a rec group)

  | FltCareful  -- At least one binding is strict (or unlifted)
                --      and not guaranteed cheap
                --      Do not float these bindings out of a lazy let

instance Outputable LetFloats where
  ppr :: LetFloats -> SDoc
ppr (LetFloats JoinFloats
binds FloatFlag
ff) = FloatFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatFlag
ff SDoc -> SDoc -> SDoc
$$ [OutBind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (JoinFloats -> [OutBind]
forall a. OrdList a -> [a]
fromOL JoinFloats
binds)

instance Outputable FloatFlag where
  ppr :: FloatFlag -> SDoc
ppr FloatFlag
FltLifted  = String -> SDoc
text String
"FltLifted"
  ppr FloatFlag
FltOkSpec  = String -> SDoc
text String
"FltOkSpec"
  ppr FloatFlag
FltCareful = String -> SDoc
text String
"FltCareful"

andFF :: FloatFlag -> FloatFlag -> FloatFlag
andFF :: FloatFlag -> FloatFlag -> FloatFlag
andFF FloatFlag
FltCareful FloatFlag
_          = FloatFlag
FltCareful
andFF FloatFlag
FltOkSpec  FloatFlag
FltCareful = FloatFlag
FltCareful
andFF FloatFlag
FltOkSpec  FloatFlag
_          = FloatFlag
FltOkSpec
andFF FloatFlag
FltLifted  FloatFlag
flt        = FloatFlag
flt

doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
-- If you change this function look also at FloatIn.noFloatFromRhs
doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
doFloatFromRhs TopLevelFlag
lvl RecFlag
rec Bool
str (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats = LetFloats JoinFloats
fs FloatFlag
ff }) OutExpr
rhs
  =  Bool -> Bool
not (JoinFloats -> Bool
forall a. OrdList a -> Bool
isNilOL JoinFloats
fs) Bool -> Bool -> Bool
&& Bool
want_to_float Bool -> Bool -> Bool
&& Bool
can_float
  where
     want_to_float :: Bool
want_to_float = TopLevelFlag -> Bool
isTopLevel TopLevelFlag
lvl Bool -> Bool -> Bool
|| OutExpr -> Bool
exprIsCheap OutExpr
rhs Bool -> Bool -> Bool
|| OutExpr -> Bool
exprIsExpandable OutExpr
rhs
                     -- See Note [Float when cheap or expandable]
     can_float :: Bool
can_float = case FloatFlag
ff of
                   FloatFlag
FltLifted  -> Bool
True
                   FloatFlag
FltOkSpec  -> TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
lvl Bool -> Bool -> Bool
&& RecFlag -> Bool
isNonRec RecFlag
rec
                   FloatFlag
FltCareful -> TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
lvl Bool -> Bool -> Bool
&& RecFlag -> Bool
isNonRec RecFlag
rec Bool -> Bool -> Bool
&& Bool
str

{-
Note [Float when cheap or expandable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to float a let from a let if the residual RHS is
   a) cheap, such as (\x. blah)
   b) expandable, such as (f b) if f is CONLIKE
But there are
  - cheap things that are not expandable (eg \x. expensive)
  - expandable things that are not cheap (eg (f b) where b is CONLIKE)
so we must take the 'or' of the two.
-}

emptyLetFloats :: LetFloats
emptyLetFloats :: LetFloats
emptyLetFloats = JoinFloats -> FloatFlag -> LetFloats
LetFloats JoinFloats
forall a. OrdList a
nilOL FloatFlag
FltLifted

emptyJoinFloats :: JoinFloats
emptyJoinFloats :: JoinFloats
emptyJoinFloats = JoinFloats
forall a. OrdList a
nilOL

unitLetFloat :: OutBind -> LetFloats
-- This key function constructs a singleton float with the right form
unitLetFloat :: OutBind -> LetFloats
unitLetFloat OutBind
bind = ASSERT(all (not . isJoinId) (bindersOf bind))
                    JoinFloats -> FloatFlag -> LetFloats
LetFloats (OutBind -> JoinFloats
forall a. a -> OrdList a
unitOL OutBind
bind) (OutBind -> FloatFlag
flag OutBind
bind)
  where
    flag :: OutBind -> FloatFlag
flag (Rec {})                = FloatFlag
FltLifted
    flag (NonRec Var
bndr OutExpr
rhs)
      | Bool -> Bool
not (Var -> Bool
isStrictId Var
bndr)    = FloatFlag
FltLifted
      | OutExpr -> Bool
exprIsTickedString OutExpr
rhs   = FloatFlag
FltLifted
          -- String literals can be floated freely.
          -- See Note [CoreSyn top-level string literals] in CoreSyn.
      | OutExpr -> Bool
exprOkForSpeculation OutExpr
rhs = FloatFlag
FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
      | Bool
otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
                                   FloatFlag
FltCareful
      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds

unitJoinFloat :: OutBind -> JoinFloats
unitJoinFloat :: OutBind -> JoinFloats
unitJoinFloat OutBind
bind = ASSERT(all isJoinId (bindersOf bind))
                     OutBind -> JoinFloats
forall a. a -> OrdList a
unitOL OutBind
bind

mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
-- Make a singleton SimplFloats, and
-- extend the incoming SimplEnv's in-scope set with its binders
-- These binders may already be in the in-scope set,
-- but may have by now been augmented with more IdInfo
mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
mkFloatBind SimplEnv
env OutBind
bind
  = (SimplFloats
floats, SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope' })
  where
    floats :: SimplFloats
floats
      | OutBind -> Bool
isJoinBind OutBind
bind
      = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
emptyLetFloats
                    , sfJoinFloats :: JoinFloats
sfJoinFloats = OutBind -> JoinFloats
unitJoinFloat OutBind
bind
                    , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope' }
      | Bool
otherwise
      = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = OutBind -> LetFloats
unitLetFloat OutBind
bind
                    , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
emptyJoinFloats
                    , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope' }

    in_scope' :: InScopeSet
in_scope' = SimplEnv -> InScopeSet
seInScope SimplEnv
env InScopeSet -> OutBind -> InScopeSet
`extendInScopeSetBind` OutBind
bind

extendFloats :: SimplFloats -> OutBind -> SimplFloats
-- Add this binding to the floats, and extend the in-scope env too
extendFloats :: SimplFloats -> OutBind -> SimplFloats
extendFloats (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats
floats
                          , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jfloats
                          , sfInScope :: SimplFloats -> InScopeSet
sfInScope    = InScopeSet
in_scope })
             OutBind
bind
  | OutBind -> Bool
isJoinBind OutBind
bind
  = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope'
                , sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
floats
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
jfloats' }
  | Bool
otherwise
  = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope'
                , sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
floats'
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
jfloats }
  where
    in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> OutBind -> InScopeSet
`extendInScopeSetBind` OutBind
bind
    floats' :: LetFloats
floats'   = LetFloats
floats  LetFloats -> LetFloats -> LetFloats
`addLetFlts`  OutBind -> LetFloats
unitLetFloat OutBind
bind
    jfloats' :: JoinFloats
jfloats'  = JoinFloats
jfloats JoinFloats -> JoinFloats -> JoinFloats
`addJoinFlts` OutBind -> JoinFloats
unitJoinFloat OutBind
bind

addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
-- Add the let-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- than that for env1
addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
addLetFloats SimplFloats
floats let_floats :: LetFloats
let_floats@(LetFloats JoinFloats
binds FloatFlag
_)
  = SimplFloats
floats { sfLetFloats :: LetFloats
sfLetFloats = SimplFloats -> LetFloats
sfLetFloats SimplFloats
floats LetFloats -> LetFloats -> LetFloats
`addLetFlts` LetFloats
let_floats
           , sfInScope :: InScopeSet
sfInScope   = (InScopeSet -> OutBind -> InScopeSet)
-> InScopeSet -> JoinFloats -> InScopeSet
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL InScopeSet -> OutBind -> InScopeSet
extendInScopeSetBind
                                   (SimplFloats -> InScopeSet
sfInScope SimplFloats
floats) JoinFloats
binds }

addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
addJoinFloats SimplFloats
floats JoinFloats
join_floats
  = SimplFloats
floats { sfJoinFloats :: JoinFloats
sfJoinFloats = SimplFloats -> JoinFloats
sfJoinFloats SimplFloats
floats JoinFloats -> JoinFloats -> JoinFloats
`addJoinFlts` JoinFloats
join_floats
           , sfInScope :: InScopeSet
sfInScope    = (InScopeSet -> OutBind -> InScopeSet)
-> InScopeSet -> JoinFloats -> InScopeSet
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL InScopeSet -> OutBind -> InScopeSet
extendInScopeSetBind
                                    (SimplFloats -> InScopeSet
sfInScope SimplFloats
floats) JoinFloats
join_floats }

extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
extendInScopeSetBind :: InScopeSet -> OutBind -> InScopeSet
extendInScopeSetBind InScopeSet
in_scope OutBind
bind
  = InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList InScopeSet
in_scope (OutBind -> [Var]
forall b. Bind b -> [b]
bindersOf OutBind
bind)

addFloats :: SimplFloats -> SimplFloats -> SimplFloats
-- Add both let-floats and join-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- than that for env1
addFloats :: SimplFloats -> SimplFloats -> SimplFloats
addFloats (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats = LetFloats
lf1, sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jf1 })
          (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats = LetFloats
lf2, sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jf2, sfInScope :: SimplFloats -> InScopeSet
sfInScope = InScopeSet
in_scope })
  = SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
lf1 LetFloats -> LetFloats -> LetFloats
`addLetFlts` LetFloats
lf2
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
jf1 JoinFloats -> JoinFloats -> JoinFloats
`addJoinFlts` JoinFloats
jf2
                , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope }

addLetFlts :: LetFloats -> LetFloats -> LetFloats
addLetFlts :: LetFloats -> LetFloats -> LetFloats
addLetFlts (LetFloats JoinFloats
bs1 FloatFlag
l1) (LetFloats JoinFloats
bs2 FloatFlag
l2)
  = JoinFloats -> FloatFlag -> LetFloats
LetFloats (JoinFloats
bs1 JoinFloats -> JoinFloats -> JoinFloats
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` JoinFloats
bs2) (FloatFlag
l1 FloatFlag -> FloatFlag -> FloatFlag
`andFF` FloatFlag
l2)

letFloatBinds :: LetFloats -> [CoreBind]
letFloatBinds :: LetFloats -> [OutBind]
letFloatBinds (LetFloats JoinFloats
bs FloatFlag
_) = JoinFloats -> [OutBind]
forall a. OrdList a -> [a]
fromOL JoinFloats
bs

addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
addJoinFlts = JoinFloats -> JoinFloats -> JoinFloats
forall a. OrdList a -> OrdList a -> OrdList a
appOL

mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats from env2 into a single Rec group,
-- They must either all be lifted LetFloats or all JoinFloats
mkRecFloats :: SimplFloats -> SimplFloats
mkRecFloats floats :: SimplFloats
floats@(SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats JoinFloats
bs FloatFlag
ff
                                , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jbs
                                , sfInScope :: SimplFloats -> InScopeSet
sfInScope    = InScopeSet
in_scope })
  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
    SimplFloats :: LetFloats -> JoinFloats -> InScopeSet -> SimplFloats
SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
floats'
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
jfloats'
                , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope }
  where
    floats' :: LetFloats
floats'  | JoinFloats -> Bool
forall a. OrdList a -> Bool
isNilOL JoinFloats
bs  = LetFloats
emptyLetFloats
             | Bool
otherwise   = OutBind -> LetFloats
unitLetFloat ([(Var, OutExpr)] -> OutBind
forall b. [(b, Expr b)] -> Bind b
Rec ([OutBind] -> [(Var, OutExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (JoinFloats -> [OutBind]
forall a. OrdList a -> [a]
fromOL JoinFloats
bs)))
    jfloats' :: JoinFloats
jfloats' | JoinFloats -> Bool
forall a. OrdList a -> Bool
isNilOL JoinFloats
jbs = JoinFloats
emptyJoinFloats
             | Bool
otherwise   = OutBind -> JoinFloats
unitJoinFloat ([(Var, OutExpr)] -> OutBind
forall b. [(b, Expr b)] -> Bind b
Rec ([OutBind] -> [(Var, OutExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (JoinFloats -> [OutBind]
forall a. OrdList a -> [a]
fromOL JoinFloats
jbs)))

wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression; they should all
-- satisfy the let/app invariant, so mkLets should do the job just fine
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
wrapFloats (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats JoinFloats
bs FloatFlag
_
                        , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jbs }) OutExpr
body
  = (OutBind -> OutExpr -> OutExpr) -> OutExpr -> JoinFloats -> OutExpr
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL OutBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (JoinFloats -> OutExpr -> OutExpr
wrapJoinFloats JoinFloats
jbs OutExpr
body) JoinFloats
bs
     -- Note: Always safe to put the joins on the inside
     -- since the values can't refer to them

wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
-- Wrap the sfJoinFloats of the env around the expression,
-- and take them out of the SimplEnv
wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
wrapJoinFloatsX SimplFloats
floats OutExpr
body
  = ( SimplFloats
floats { sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
emptyJoinFloats }
    , JoinFloats -> OutExpr -> OutExpr
wrapJoinFloats (SimplFloats -> JoinFloats
sfJoinFloats SimplFloats
floats) OutExpr
body )

wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
-- Wrap the sfJoinFloats of the env around the expression,
-- and take them out of the SimplEnv
wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
wrapJoinFloats JoinFloats
join_floats OutExpr
body
  = (OutBind -> OutExpr -> OutExpr) -> OutExpr -> JoinFloats -> OutExpr
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL OutBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let OutExpr
body JoinFloats
join_floats

getTopFloatBinds :: SimplFloats -> [CoreBind]
getTopFloatBinds :: SimplFloats -> [OutBind]
getTopFloatBinds (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats
lbs
                              , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jbs})
  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
    LetFloats -> [OutBind]
letFloatBinds LetFloats
lbs

mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
mapLetFloats :: LetFloats -> ((Var, OutExpr) -> (Var, OutExpr)) -> LetFloats
mapLetFloats (LetFloats JoinFloats
fs FloatFlag
ff) (Var, OutExpr) -> (Var, OutExpr)
fun
   = JoinFloats -> FloatFlag -> LetFloats
LetFloats ((OutBind -> OutBind) -> JoinFloats -> JoinFloats
forall a b. (a -> b) -> OrdList a -> OrdList b
mapOL OutBind -> OutBind
app JoinFloats
fs) FloatFlag
ff
   where
    app :: OutBind -> OutBind
app (NonRec Var
b OutExpr
e) = case (Var, OutExpr) -> (Var, OutExpr)
fun (Var
b,OutExpr
e) of (Var
b',OutExpr
e') -> Var -> OutExpr -> OutBind
forall b. b -> Expr b -> Bind b
NonRec Var
b' OutExpr
e'
    app (Rec [(Var, OutExpr)]
bs)     = [(Var, OutExpr)] -> OutBind
forall b. [(b, Expr b)] -> Bind b
Rec (((Var, OutExpr) -> (Var, OutExpr))
-> [(Var, OutExpr)] -> [(Var, OutExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (Var, OutExpr) -> (Var, OutExpr)
fun [(Var, OutExpr)]
bs)

{-
************************************************************************
*                                                                      *
                Substitution of Vars
*                                                                      *
************************************************************************

Note [Global Ids in the substitution]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We look up even a global (eg imported) Id in the substitution. Consider
   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
The binder-swap in the occurrence analyser will add a binding
for a LocalId version of g (with the same unique though):
   case X.g_34 of b { (a,b) ->  let g_34 = b in
                                ... case X.g_34 of { (p,q) -> ...} ... }
So we want to look up the inner X.g_34 in the substitution, where we'll
find that it has been substituted by b.  (Or conceivably cloned.)
-}

substId :: SimplEnv -> InId -> SimplSR
-- Returns DoneEx only on a non-Var expression
substId :: SimplEnv -> Var -> SimplSR
substId (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
ids }) Var
v
  = case SimplIdSubst -> Var -> Maybe SimplSR
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv SimplIdSubst
ids Var
v of  -- Note [Global Ids in the substitution]
        Maybe SimplSR
Nothing               -> Var -> SimplSR
DoneId (InScopeSet -> Var -> Var
refineFromInScope InScopeSet
in_scope Var
v)
        Just (DoneId Var
v)       -> Var -> SimplSR
DoneId (InScopeSet -> Var -> Var
refineFromInScope InScopeSet
in_scope Var
v)
        Just SimplSR
res              -> SimplSR
res    -- DoneEx non-var, or ContEx

        -- Get the most up-to-date thing from the in-scope set
        -- Even though it isn't in the substitution, it may be in
        -- the in-scope set with better IdInfo.
        --
        -- See also Note [In-scope set as a substitution] in Simplify.

refineFromInScope :: InScopeSet -> Var -> Var
refineFromInScope :: InScopeSet -> Var -> Var
refineFromInScope InScopeSet
in_scope Var
v
  | Var -> Bool
isLocalId Var
v = case InScopeSet -> Var -> Maybe Var
lookupInScope InScopeSet
in_scope Var
v of
                  Just Var
v' -> Var
v'
                  Maybe Var
Nothing -> WARN( True, ppr v ) v  -- This is an error!
  | Bool
otherwise = Var
v

lookupRecBndr :: SimplEnv -> InId -> OutId
-- Look up an Id which has been put into the envt by simplRecBndrs,
-- but where we have not yet done its RHS
lookupRecBndr :: SimplEnv -> Var -> Var
lookupRecBndr (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
ids }) Var
v
  = case SimplIdSubst -> Var -> Maybe SimplSR
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv SimplIdSubst
ids Var
v of
        Just (DoneId Var
v) -> Var
v
        Just SimplSR
_ -> String -> SDoc -> Var
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupRecBndr" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v)
        Maybe SimplSR
Nothing -> InScopeSet -> Var -> Var
refineFromInScope InScopeSet
in_scope Var
v

{-
************************************************************************
*                                                                      *
\section{Substituting an Id binder}
*                                                                      *
************************************************************************


These functions are in the monad only so that they can be made strict via seq.

Note [Return type for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

   (join j :: Char -> Int -> Int) 77
   (     j x = \y. y + ord x    )
   (in case v of                )
   (     A -> j 'x'             )
   (     B -> j 'y'             )
   (     C -> <blah>            )

The simplifier pushes the "apply to 77" continuation inwards to give

   join j :: Char -> Int
        j x = (\y. y + ord x) 77
   in case v of
        A -> j 'x'
        B -> j 'y'
        C -> <blah> 77

Notice that the "apply to 77" continuation went into the RHS of the
join point.  And that meant that the return type of the join point
changed!!

That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr
takes a (Just res_ty) argument so that it knows to do the type-changing
thing.
-}

simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders :: SimplEnv -> [Var] -> SimplM (SimplEnv, [Var])
simplBinders  SimplEnv
env [Var]
bndrs = (SimplEnv -> Var -> SimplM (SimplEnv, Var))
-> SimplEnv -> [Var] -> SimplM (SimplEnv, [Var])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM SimplEnv -> Var -> SimplM (SimplEnv, Var)
simplBinder  SimplEnv
env [Var]
bndrs

-------------
simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- Used for lambda and case-bound variables
-- Clone Id if necessary, substitute type
-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBinder :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
simplBinder SimplEnv
env Var
bndr
  | Var -> Bool
isTyVar Var
bndr  = do  { let (SimplEnv
env', Var
tv) = SimplEnv -> Var -> (SimplEnv, Var)
substTyVarBndr SimplEnv
env Var
bndr
                        ; Var -> ()
seqTyVar Var
tv () -> SimplM (SimplEnv, Var) -> SimplM (SimplEnv, Var)
`seq` (SimplEnv, Var) -> SimplM (SimplEnv, Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env', Var
tv) }
  | Bool
otherwise     = do  { let (SimplEnv
env', Var
id) = Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr Maybe Type
forall a. Maybe a
Nothing SimplEnv
env Var
bndr
                        ; Var -> ()
seqId Var
id () -> SimplM (SimplEnv, Var) -> SimplM (SimplEnv, Var)
`seq` (SimplEnv, Var) -> SimplM (SimplEnv, Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env', Var
id) }

---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
simplNonRecBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
simplNonRecBndr SimplEnv
env Var
id
  = do  { let (SimplEnv
env1, Var
id1) = Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr Maybe Type
forall a. Maybe a
Nothing SimplEnv
env Var
id
        ; Var -> ()
seqId Var
id1 () -> SimplM (SimplEnv, Var) -> SimplM (SimplEnv, Var)
`seq` (SimplEnv, Var) -> SimplM (SimplEnv, Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env1, Var
id1) }

---------------
simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr
                    -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder for a join point;
-- context being pushed inward may change the type
-- See Note [Return type for join points]
simplNonRecJoinBndr :: SimplEnv -> Type -> Var -> SimplM (SimplEnv, Var)
simplNonRecJoinBndr SimplEnv
env Type
res_ty Var
id
  = do  { let (SimplEnv
env1, Var
id1) = Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
res_ty) SimplEnv
env Var
id
        ; Var -> ()
seqId Var
id1 () -> SimplM (SimplEnv, Var) -> SimplM (SimplEnv, Var)
`seq` (SimplEnv, Var) -> SimplM (SimplEnv, Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env1, Var
id1) }

---------------
simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders
simplRecBndrs :: SimplEnv -> [Var] -> SimplM SimplEnv
simplRecBndrs env :: SimplEnv
env@(SimplEnv {}) [Var]
ids
  = ASSERT(all (not . isJoinId) ids)
    do  { let (SimplEnv
env1, [Var]
ids1) = (SimplEnv -> Var -> (SimplEnv, Var))
-> SimplEnv -> [Var] -> (SimplEnv, [Var])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr Maybe Type
forall a. Maybe a
Nothing) SimplEnv
env [Var]
ids
        ; [Var] -> ()
seqIds [Var]
ids1 () -> SimplM SimplEnv -> SimplM SimplEnv
`seq` SimplEnv -> SimplM SimplEnv
forall (m :: * -> *) a. Monad m => a -> m a
return SimplEnv
env1 }

---------------
simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders for join points;
-- context being pushed inward may change types
-- See Note [Return type for join points]
simplRecJoinBndrs :: SimplEnv -> Type -> [Var] -> SimplM SimplEnv
simplRecJoinBndrs env :: SimplEnv
env@(SimplEnv {}) Type
res_ty [Var]
ids
  = ASSERT(all isJoinId ids)
    do  { let (SimplEnv
env1, [Var]
ids1) = (SimplEnv -> Var -> (SimplEnv, Var))
-> SimplEnv -> [Var] -> (SimplEnv, [Var])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
res_ty)) SimplEnv
env [Var]
ids
        ; [Var] -> ()
seqIds [Var]
ids1 () -> SimplM SimplEnv -> SimplM SimplEnv
`seq` SimplEnv -> SimplM SimplEnv
forall (m :: * -> *) a. Monad m => a -> m a
return SimplEnv
env1 }

---------------
substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)
-- Might be a coercion variable
substIdBndr :: Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substIdBndr Maybe Type
new_res_ty SimplEnv
env Var
bndr
  | Var -> Bool
isCoVar Var
bndr  = SimplEnv -> Var -> (SimplEnv, Var)
substCoVarBndr SimplEnv
env Var
bndr
  | Bool
otherwise     = Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substNonCoVarIdBndr Maybe Type
new_res_ty SimplEnv
env Var
bndr

---------------
substNonCoVarIdBndr
   :: Maybe OutType -- New result type, if a join binder
                    -- See Note [Return type for join points]
   -> SimplEnv
   -> InBndr    -- Env and binder to transform
   -> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
--      * Type substituted
--      * UnfoldingInfo, Rules, WorkerInfo zapped
--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
--      * Robust info, retained especially arity and demand info,
--         so that they are available to occurrences that occur in an
--         earlier binding of a letrec
--
-- For the robust info, see Note [Arity robustness]
--
-- Augment the substitution  if the unique changed
-- Extend the in-scope set with the new Id
--
-- Similar to CoreSubst.substIdBndr, except that
--      the type of id_subst differs
--      all fragile info is zapped
substNonCoVarIdBndr :: Maybe Type -> SimplEnv -> Var -> (SimplEnv, Var)
substNonCoVarIdBndr Maybe Type
new_res_ty
                    env :: SimplEnv
env@(SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope
                                  , seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
id_subst })
                    Var
old_id
  = ASSERT2( not (isCoVar old_id), ppr old_id )
    (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope InScopeSet -> Var -> InScopeSet
`extendInScopeSet` Var
new_id,
           seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
new_subst }, Var
new_id)
  where
    id1 :: Var
id1    = InScopeSet -> Var -> Var
uniqAway InScopeSet
in_scope Var
old_id
    id2 :: Var
id2    = SimplEnv -> Var -> Var
substIdType SimplEnv
env Var
id1

    id3 :: Var
id3    | Just Type
res_ty <- Maybe Type
new_res_ty
           = Var
id2 Var -> Type -> Var
`setIdType` JoinArity -> Type -> Type -> Type
setJoinResTy (Var -> JoinArity
idJoinArity Var
id2) Type
res_ty (Var -> Type
idType Var
id2)
                             -- See Note [Return type for join points]
           | Bool
otherwise
           = Var
id2

    new_id :: Var
new_id = Var -> Var
zapFragileIdInfo Var
id3       -- Zaps rules, worker-info, unfolding
                                        -- and fragile OccInfo

        -- Extend the substitution if the unique has changed,
        -- or there's some useful occurrence information
        -- See the notes with substTyVarBndr for the delSubstEnv
    new_subst :: SimplIdSubst
new_subst | Var
new_id Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
/= Var
old_id
              = SimplIdSubst -> Var -> SimplSR -> SimplIdSubst
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv SimplIdSubst
id_subst Var
old_id (Var -> SimplSR
DoneId Var
new_id)
              | Bool
otherwise
              = SimplIdSubst -> Var -> SimplIdSubst
forall a. VarEnv a -> Var -> VarEnv a
delVarEnv SimplIdSubst
id_subst Var
old_id

------------------------------------
seqTyVar :: TyVar -> ()
seqTyVar :: Var -> ()
seqTyVar Var
b = Var
b Var -> () -> ()
`seq` ()

seqId :: Id -> ()
seqId :: Var -> ()
seqId Var
id = Type -> ()
seqType (Var -> Type
idType Var
id)  () -> () -> ()
`seq`
           HasDebugCallStack => Var -> IdInfo
Var -> IdInfo
idInfo Var
id            IdInfo -> () -> ()
`seq`
           ()

seqIds :: [Id] -> ()
seqIds :: [Var] -> ()
seqIds []       = ()
seqIds (Var
id:[Var]
ids) = Var -> ()
seqId Var
id () -> () -> ()
`seq` [Var] -> ()
seqIds [Var]
ids

{-
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
We *do* transfer the arity from from the in_id of a let binding to the
out_id.  This is important, so that the arity of an Id is visible in
its own RHS.  For example:
        f = \x. ....g (\y. f y)....
We can eta-reduce the arg to g, because f is a value.  But that
needs to be visible.

This interacts with the 'state hack' too:
        f :: Bool -> IO Int
        f = \x. case x of
                  True  -> f y
                  False -> \s -> ...
Can we eta-expand f?  Only if we see that f has arity 1, and then we
take advantage of the 'state hack' on the result of
(f y) :: State# -> (State#, Int) to expand the arity one more.

There is a disadvantage though.  Making the arity visible in the RHS
allows us to eta-reduce
        f = \x -> f x
to
        f = f
which technically is not sound.   This is very much a corner case, so
I'm not worried about it.  Another idea is to ensure that f's arity
never decreases; its arity started as 1, and we should never eta-reduce
below that.


Note [Robust OccInfo]
~~~~~~~~~~~~~~~~~~~~~
It's important that we *do* retain the loop-breaker OccInfo, because
that's what stops the Id getting inlined infinitely, in the body of
the letrec.
-}


{-
************************************************************************
*                                                                      *
                Impedance matching to type substitution
*                                                                      *
************************************************************************
-}

getTCvSubst :: SimplEnv -> TCvSubst
getTCvSubst :: SimplEnv -> TCvSubst
getTCvSubst (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tv_env
                      , seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
cv_env })
  = InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst
mkTCvSubst InScopeSet
in_scope (TvSubstEnv
tv_env, CvSubstEnv
cv_env)

substTy :: SimplEnv -> Type -> Type
substTy :: SimplEnv -> Type -> Type
substTy SimplEnv
env Type
ty = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
Type.substTy (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Type
ty

substTyVar :: SimplEnv -> TyVar -> Type
substTyVar :: SimplEnv -> Var -> Type
substTyVar SimplEnv
env Var
tv = TCvSubst -> Var -> Type
Type.substTyVar (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Var
tv

substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr :: SimplEnv -> Var -> (SimplEnv, Var)
substTyVarBndr SimplEnv
env Var
tv
  = case HasCallStack => TCvSubst -> Var -> (TCvSubst, Var)
TCvSubst -> Var -> (TCvSubst, Var)
Type.substTyVarBndr (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Var
tv of
        (TCvSubst InScopeSet
in_scope' TvSubstEnv
tv_env' CvSubstEnv
cv_env', Var
tv')
           -> (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope', seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
tv_env', seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
cv_env' }, Var
tv')

substCoVar :: SimplEnv -> CoVar -> Coercion
substCoVar :: SimplEnv -> Var -> Coercion
substCoVar SimplEnv
env Var
tv = TCvSubst -> Var -> Coercion
Coercion.substCoVar (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Var
tv

substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
substCoVarBndr :: SimplEnv -> Var -> (SimplEnv, Var)
substCoVarBndr SimplEnv
env Var
cv
  = case HasCallStack => TCvSubst -> Var -> (TCvSubst, Var)
TCvSubst -> Var -> (TCvSubst, Var)
Coercion.substCoVarBndr (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Var
cv of
        (TCvSubst InScopeSet
in_scope' TvSubstEnv
tv_env' CvSubstEnv
cv_env', Var
cv')
           -> (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope', seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
tv_env', seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
cv_env' }, Var
cv')

substCo :: SimplEnv -> Coercion -> Coercion
substCo :: SimplEnv -> Coercion -> Coercion
substCo SimplEnv
env Coercion
co = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
Coercion.substCo (SimplEnv -> TCvSubst
getTCvSubst SimplEnv
env) Coercion
co

------------------
substIdType :: SimplEnv -> Id -> Id
substIdType :: SimplEnv -> Var -> Var
substIdType (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tv_env, seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
cv_env }) Var
id
  |  (TvSubstEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv TvSubstEnv
tv_env Bool -> Bool -> Bool
&& CvSubstEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv CvSubstEnv
cv_env)
  Bool -> Bool -> Bool
|| Type -> Bool
noFreeVarsOfType Type
old_ty
  = Var
id
  | Bool
otherwise = Var -> Type -> Var
Id.setIdType Var
id (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
Type.substTy (InScopeSet -> TvSubstEnv -> CvSubstEnv -> TCvSubst
TCvSubst InScopeSet
in_scope TvSubstEnv
tv_env CvSubstEnv
cv_env) Type
old_ty)
                -- The tyCoVarsOfType is cheaper than it looks
                -- because we cache the free tyvars of the type
                -- in a Note in the id's type itself
  where
    old_ty :: Type
old_ty = Var -> Type
idType Var
id