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

\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
-}



module GHC.Core.Opt.Simplify.Env (
        -- * The simplifier mode
        SimplMode(..), updMode,
        smPedanticBottoms, smPlatform,

        -- * Environments
        SimplEnv(..), pprSimplEnv,   -- Temp not abstract
        seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
        seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
        seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,
        seRuleOpts, seRules, seUnfoldingOpts,
        mkSimplEnv, extendIdSubst,
        extendTvSubst, extendCvSubst,
        zapSubstEnv, setSubstEnv, bumpCaseDepth,
        getInScope, setInScopeFromE, setInScopeFromF,
        setInScopeSet, modifyInScope, addNewInScopeIds,
        getSimplRules, enterRecGroupRHSs,

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

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

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

        -- * LetFloats
        LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,
        addLetFlts,  mapLetFloats,

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

import GHC.Prelude

import GHC.Core.Coercion.Opt ( OptCoercionOpts )
import GHC.Core.FamInstEnv ( FamInstEnv )
import GHC.Core.Opt.Arity ( ArityOpts(..) )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Rules.Config ( RuleOpts(..) )
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Multiplicity     ( scaleScaled )
import GHC.Core.Unfold
import GHC.Core.TyCo.Subst (emptyIdSubstEnv)
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Data.OrdList
import GHC.Data.Graph.UnVar
import GHC.Types.Id as Id
import GHC.Core.Make            ( mkWildValBinder, mkCoreLet )
import GHC.Builtin.Types
import qualified GHC.Core.Type as Type
import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, substCo
                                , extendTvSubst, extendCvSubst )
import qualified GHC.Core.Coercion as Coercion
import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
import GHC.Platform ( Platform )
import GHC.Types.Basic
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Types.Unique.FM      ( pprUniqFM )

import Data.List ( intersperse, mapAccumL )

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

{-
Note [The environments of the Simplify pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The functions of the Simplify pass draw their contextual data from two
environments: `SimplEnv`, which is passed to the functions as an argument, and
`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist
corresponding configuration records `SimplMode` and `TopEnvConfig` respectively.
A configuration record denotes a unary datatype bundeling the various options
and switches we provide to control the behaviour of the respective part of the
Simplify pass. The value is provided by the driver using the functions found in
the GHC.Driver.Config.Core.Opt.Simplify module.

These configuration records are part in the environment to avoid needless
copying of their values. This raises the question which data value goes in which
of the four datatypes. For each value needed by the pass we ask the following
two questions:

 * Does the value only make sense in a monadic environment?

 * Is it part of the configuration of the pass and provided by the user or is it
   it an internal value?

Examples of values that make only sense in conjunction with `SimplM` are the
logger and the values related to counting. As it does not make sense to use them
in a pure function (the logger needs IO and counting needs access to the
accumulated counts in the monad) we want these to live in `SimplTopEnv`.
Other values, like the switches controlling the behaviour of the pass (e.g.
whether to do case merging or not) are perfectly usable in a non-monadic setting.
Indeed many of those are used in guard expressions and it would be cumbersome to
query them from the monadic environment and feed them to the pure functions as
an argument. Hence we conveniently store them in the `SpecEnv` environment which
can be passed to pure functions as a whole.

Now that we know in which of the two environments a particular value lives we
turn to the second question to determine if the value is part of the
configuration record embedded in the environment or if it is stored in an own
field in the environment type. Some values like the tick factor must be provided
from outside as we can neither derive it from other values provided to us nor
does a constant value make sense. Other values like the maximal number of ticks
are computed on environment initialization and we wish not to expose the field
to the "user" or the pass -- it is an internal value. Therefore the distinction
here is between "freely set by the caller" and "internally managed by the pass".

Note that it doesn't matter for the decision procedure wheter a value is altered
throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline,
sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the
definitions of `updModeForStableUnfoldings` and `updModeForRules` in
GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the
caller of the Simplify pass needs to provide the initial values for those fields.

The decision which value goes into which datatype can be summarized by the
following table:
                                 |          Usable in a           |
                                 | pure setting | monadic setting |
    |----------------------------|--------------|-----------------|
    | Set by user                | SimplMode    | TopEnvConfig    |
    | Computed on initialization | SimplEnv     | SimplTopEnv     |

-}

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

        -- See Note [The environments of the Simplify pass]
        SimplEnv -> SimplMode
seMode      :: !SimplMode
      , SimplEnv -> (FamInstEnv, FamInstEnv)
seFamEnvs   :: !(FamInstEnv, FamInstEnv)

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

        -- | Fast OutVarSet tracking which recursive RHSs we are analysing.
        -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.
      , SimplEnv -> UnVarSet
seRecIds :: !UnVarSet

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

      , SimplEnv -> JoinArity
seCaseDepth :: !Int  -- Depth of multi-branch case alternatives
    }

seArityOpts :: SimplEnv -> ArityOpts
seArityOpts :: SimplEnv -> ArityOpts
seArityOpts SimplEnv
env = SimplMode -> ArityOpts
sm_arity_opts (SimplEnv -> SimplMode
seMode SimplEnv
env)

seCaseCase :: SimplEnv -> Bool
seCaseCase :: SimplEnv -> Bool
seCaseCase SimplEnv
env = SimplMode -> Bool
sm_case_case (SimplEnv -> SimplMode
seMode SimplEnv
env)

seCaseFolding :: SimplEnv -> Bool
seCaseFolding :: SimplEnv -> Bool
seCaseFolding SimplEnv
env = SimplMode -> Bool
sm_case_folding (SimplEnv -> SimplMode
seMode SimplEnv
env)

seCaseMerge :: SimplEnv -> Bool
seCaseMerge :: SimplEnv -> Bool
seCaseMerge SimplEnv
env = SimplMode -> Bool
sm_case_merge (SimplEnv -> SimplMode
seMode SimplEnv
env)

seCastSwizzle :: SimplEnv -> Bool
seCastSwizzle :: SimplEnv -> Bool
seCastSwizzle SimplEnv
env = SimplMode -> Bool
sm_cast_swizzle (SimplEnv -> SimplMode
seMode SimplEnv
env)

seDoEtaReduction :: SimplEnv -> Bool
seDoEtaReduction :: SimplEnv -> Bool
seDoEtaReduction SimplEnv
env = SimplMode -> Bool
sm_do_eta_reduction (SimplEnv -> SimplMode
seMode SimplEnv
env)

seEtaExpand :: SimplEnv -> Bool
seEtaExpand :: SimplEnv -> Bool
seEtaExpand SimplEnv
env = SimplMode -> Bool
sm_eta_expand (SimplEnv -> SimplMode
seMode SimplEnv
env)

seFloatEnable :: SimplEnv -> FloatEnable
seFloatEnable :: SimplEnv -> FloatEnable
seFloatEnable SimplEnv
env = SimplMode -> FloatEnable
sm_float_enable (SimplEnv -> SimplMode
seMode SimplEnv
env)

seInline :: SimplEnv -> Bool
seInline :: SimplEnv -> Bool
seInline SimplEnv
env = SimplMode -> Bool
sm_inline (SimplEnv -> SimplMode
seMode SimplEnv
env)

seNames :: SimplEnv -> [String]
seNames :: SimplEnv -> [String]
seNames SimplEnv
env = SimplMode -> [String]
sm_names (SimplEnv -> SimplMode
seMode SimplEnv
env)

seOptCoercionOpts :: SimplEnv -> OptCoercionOpts
seOptCoercionOpts :: SimplEnv -> OptCoercionOpts
seOptCoercionOpts SimplEnv
env = SimplMode -> OptCoercionOpts
sm_co_opt_opts (SimplEnv -> SimplMode
seMode SimplEnv
env)

sePedanticBottoms :: SimplEnv -> Bool
sePedanticBottoms :: SimplEnv -> Bool
sePedanticBottoms SimplEnv
env = SimplMode -> Bool
smPedanticBottoms (SimplEnv -> SimplMode
seMode SimplEnv
env)

sePhase :: SimplEnv -> CompilerPhase
sePhase :: SimplEnv -> CompilerPhase
sePhase SimplEnv
env = SimplMode -> CompilerPhase
sm_phase (SimplEnv -> SimplMode
seMode SimplEnv
env)

sePlatform :: SimplEnv -> Platform
sePlatform :: SimplEnv -> Platform
sePlatform SimplEnv
env = SimplMode -> Platform
smPlatform (SimplEnv -> SimplMode
seMode SimplEnv
env)

sePreInline :: SimplEnv -> Bool
sePreInline :: SimplEnv -> Bool
sePreInline SimplEnv
env = SimplMode -> Bool
sm_pre_inline (SimplEnv -> SimplMode
seMode SimplEnv
env)

seRuleOpts :: SimplEnv -> RuleOpts
seRuleOpts :: SimplEnv -> RuleOpts
seRuleOpts SimplEnv
env = SimplMode -> RuleOpts
sm_rule_opts (SimplEnv -> SimplMode
seMode SimplEnv
env)

seRules :: SimplEnv -> Bool
seRules :: SimplEnv -> Bool
seRules SimplEnv
env = SimplMode -> Bool
sm_rules (SimplEnv -> SimplMode
seMode SimplEnv
env)

seUnfoldingOpts :: SimplEnv -> UnfoldingOpts
seUnfoldingOpts :: SimplEnv -> UnfoldingOpts
seUnfoldingOpts SimplEnv
env = SimplMode -> UnfoldingOpts
sm_uf_opts (SimplEnv -> SimplMode
seMode SimplEnv
env)

-- See Note [The environments of the Simplify pass]
data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
  { SimplMode -> CompilerPhase
sm_phase        :: !CompilerPhase
  , SimplMode -> [String]
sm_names        :: ![String]      -- ^ Name(s) of the phase
  , SimplMode -> Bool
sm_rules        :: !Bool          -- ^ Whether RULES are enabled
  , SimplMode -> Bool
sm_inline       :: !Bool          -- ^ Whether inlining is enabled
  , SimplMode -> Bool
sm_eta_expand   :: !Bool          -- ^ Whether eta-expansion is enabled
  , SimplMode -> Bool
sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?
  , SimplMode -> UnfoldingOpts
sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options
  , SimplMode -> Bool
sm_case_case    :: !Bool          -- ^ Whether case-of-case is enabled
  , SimplMode -> Bool
sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled
  , SimplMode -> FloatEnable
sm_float_enable :: !FloatEnable   -- ^ Whether to enable floating out
  , SimplMode -> Bool
sm_do_eta_reduction :: !Bool
  , SimplMode -> ArityOpts
sm_arity_opts :: !ArityOpts
  , SimplMode -> RuleOpts
sm_rule_opts :: !RuleOpts
  , SimplMode -> Bool
sm_case_folding :: !Bool
  , SimplMode -> Bool
sm_case_merge :: !Bool
  , SimplMode -> OptCoercionOpts
sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
  }

instance Outputable SimplMode where
    ppr :: SimplMode -> SDoc
ppr (SimplMode { sm_phase :: SimplMode -> CompilerPhase
sm_phase = CompilerPhase
p , sm_names :: SimplMode -> [String]
sm_names = [String]
ss
                   , sm_rules :: SimplMode -> Bool
sm_rules = Bool
r, sm_inline :: SimplMode -> Bool
sm_inline = Bool
i
                   , sm_cast_swizzle :: SimplMode -> Bool
sm_cast_swizzle = Bool
cs
                   , sm_eta_expand :: SimplMode -> Bool
sm_eta_expand = Bool
eta, sm_case_case :: SimplMode -> Bool
sm_case_case = Bool
cc })
       = forall doc. IsLine doc => String -> doc
text String
"SimplMode" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
braces (
         forall doc. IsLine doc => [doc] -> doc
sep [ forall doc. IsLine doc => String -> doc
text String
"Phase =" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CompilerPhase
p forall doc. IsLine doc => doc -> doc -> doc
<+>
               forall doc. IsLine doc => doc -> doc
brackets (forall doc. IsLine doc => String -> doc
text (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
"," [String]
ss)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
             , forall {doc}. IsLine doc => Bool -> doc -> doc
pp_flag Bool
i   (forall doc. IsLine doc => String -> doc
text String
"inline") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
             , forall {doc}. IsLine doc => Bool -> doc -> doc
pp_flag Bool
r   (forall doc. IsLine doc => String -> doc
text String
"rules") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
             , forall {doc}. IsLine doc => Bool -> doc -> doc
pp_flag Bool
eta (forall doc. IsLine doc => String -> doc
text String
"eta-expand") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
             , forall {doc}. IsLine doc => Bool -> doc -> doc
pp_flag Bool
cs (forall doc. IsLine doc => String -> doc
text String
"cast-swizzle") forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
             , forall {doc}. IsLine doc => Bool -> doc -> doc
pp_flag Bool
cc  (forall doc. IsLine doc => String -> doc
text String
"case-of-case") ])
         where
           pp_flag :: Bool -> doc -> doc
pp_flag Bool
f doc
s = forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless Bool
f (forall doc. IsLine doc => String -> doc
text String
"no") forall doc. IsLine doc => doc -> doc -> doc
<+> doc
s

smPedanticBottoms :: SimplMode -> Bool
smPedanticBottoms :: SimplMode -> Bool
smPedanticBottoms SimplMode
opts = ArityOpts -> Bool
ao_ped_bot (SimplMode -> ArityOpts
sm_arity_opts SimplMode
opts)

smPlatform :: SimplMode -> Platform
smPlatform :: SimplMode -> Platform
smPlatform SimplMode
opts = RuleOpts -> Platform
roPlatform (SimplMode -> RuleOpts
sm_rule_opts SimplMode
opts)

data FloatEnable  -- Controls local let-floating
  = FloatDisabled      -- Do no local let-floating
  | FloatNestedOnly    -- Local let-floating for nested (NotTopLevel) bindings only
  | FloatEnabled       -- Do local let-floating on all bindings

{-
Note [Local floating]
~~~~~~~~~~~~~~~~~~~~~
The Simplifier can perform local let-floating: it floats let-bindings
out of the RHS of let-bindings.  See
  Let-floating: moving bindings to give faster programs (ICFP'96)
  https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/

Here's an example
   x = let y = v+1 in (y,true)

The RHS of x is a thunk.  Much better to float that y-binding out to give
   y = v+1
   x = (y,true)

Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in
the scope of the x-binding can now be simplified.

This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding,
controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs.

The `FloatEnable` data type controls where local let-floating takes place;
it allows you to specify that it should be done only for nested bindings;
or for top-level bindings as well; or not at all.

Note that all of this is quite separate from the global FloatOut pass;
see GHC.Core.Opt.FloatOut.

-}

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 })
    = forall doc. IsLine doc => String -> doc
text String
"SimplFloats"
      forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
braces (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"lets: " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LetFloats
lf
                       , forall doc. IsLine doc => String -> doc
text String
"joins:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr JoinFloats
jf
                       , forall doc. IsLine doc => String -> doc
text String
"in_scope:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr InScopeSet
is ])

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

isEmptyFloats :: SimplFloats -> Bool
-- Precondition: used only when sfJoinFloats is empty
isEmptyFloats :: SimplFloats -> Bool
isEmptyFloats (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats JoinFloats
fs FloatFlag
_
                           , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
js })
  = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall a. OrdList a -> Bool
isNilOL JoinFloats
js) (forall a. Outputable a => a -> SDoc
ppr JoinFloats
js ) forall a b. (a -> b) -> a -> b
$
    forall a. OrdList a -> Bool
isNilOL JoinFloats
fs

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

type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
        -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst

-- | 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 OutId
v)    = forall doc. IsLine doc => String -> doc
text String
"DoneId" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr OutId
v
  ppr (DoneEx OutExpr
e Maybe JoinArity
mj) = forall doc. IsLine doc => String -> doc
text String
"DoneEx" forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pp_mj forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr OutExpr
e
    where
      pp_mj :: SDoc
pp_mj = case Maybe JoinArity
mj of
                Maybe JoinArity
Nothing -> forall doc. IsOutput doc => doc
empty
                Just JoinArity
n  -> forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => JoinArity -> doc
int JoinArity
n)

  ppr (ContEx TvSubstEnv
_tv CvSubstEnv
_cv SimplIdSubst
_id OutExpr
e) = forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => String -> doc
text String
"ContEx" forall doc. IsLine doc => doc -> doc -> doc
<+> 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 synonyms, 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 -> (FamInstEnv, FamInstEnv) -> SimplEnv
mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv
mkSimplEnv SimplMode
mode (FamInstEnv, FamInstEnv)
fam_envs
  = SimplEnv { seMode :: SimplMode
seMode      = SimplMode
mode
             , seFamEnvs :: (FamInstEnv, FamInstEnv)
seFamEnvs   = (FamInstEnv, FamInstEnv)
fam_envs
             , seInScope :: InScopeSet
seInScope   = InScopeSet
init_in_scope
             , seTvSubst :: TvSubstEnv
seTvSubst   = forall a. VarEnv a
emptyVarEnv
             , seCvSubst :: CvSubstEnv
seCvSubst   = forall a. VarEnv a
emptyVarEnv
             , seIdSubst :: SimplIdSubst
seIdSubst   = forall a. VarEnv a
emptyVarEnv
             , seRecIds :: UnVarSet
seRecIds    = UnVarSet
emptyUnVarSet
             , seCaseDepth :: JoinArity
seCaseDepth = JoinArity
0 }
        -- The top level "enclosing CC" is "SUBSUMED".

init_in_scope :: InScopeSet
init_in_scope :: InScopeSet
init_in_scope = VarSet -> InScopeSet
mkInScopeSet (OutId -> VarSet
unitVarSet (Kind -> Kind -> OutId
mkWildValBinder Kind
ManyTy Kind
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,
GHC.Core.Make.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.
-}

updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
updMode SimplMode -> SimplMode
upd SimplEnv
env
  = -- Avoid keeping env alive in case inlining fails.
    let mode :: SimplMode
mode = SimplMode -> SimplMode
upd forall a b. (a -> b) -> a -> b
$! (SimplEnv -> SimplMode
seMode SimplEnv
env)
    in SimplEnv
env { seMode :: SimplMode
seMode = SimplMode
mode }

bumpCaseDepth :: SimplEnv -> SimplEnv
bumpCaseDepth :: SimplEnv -> SimplEnv
bumpCaseDepth SimplEnv
env = SimplEnv
env { seCaseDepth :: JoinArity
seCaseDepth = SimplEnv -> JoinArity
seCaseDepth SimplEnv
env forall a. Num a => a -> a -> a
+ JoinArity
1 }

---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst :: SimplEnv -> OutId -> SimplSR -> SimplEnv
extendIdSubst env :: SimplEnv
env@(SimplEnv {seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
subst}) OutId
var SimplSR
res
  = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (OutId -> Bool
isId OutId
var Bool -> Bool -> Bool
&& Bool -> Bool
not (OutId -> Bool
isCoVar OutId
var)) (forall a. Outputable a => a -> SDoc
ppr OutId
var) forall a b. (a -> b) -> a -> b
$
    SimplEnv
env { seIdSubst :: SimplIdSubst
seIdSubst = forall a. VarEnv a -> OutId -> a -> VarEnv a
extendVarEnv SimplIdSubst
subst OutId
var SimplSR
res }

extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst :: SimplEnv -> OutId -> Kind -> SimplEnv
extendTvSubst env :: SimplEnv
env@(SimplEnv {seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tsubst}) OutId
var Kind
res
  = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (OutId -> Bool
isTyVar OutId
var) (forall a. Outputable a => a -> SDoc
ppr OutId
var forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Kind
res) forall a b. (a -> b) -> a -> b
$
    SimplEnv
env {seTvSubst :: TvSubstEnv
seTvSubst = forall a. VarEnv a -> OutId -> a -> VarEnv a
extendVarEnv TvSubstEnv
tsubst OutId
var Kind
res}

extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
extendCvSubst :: SimplEnv -> OutId -> Coercion -> SimplEnv
extendCvSubst env :: SimplEnv
env@(SimplEnv {seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
csubst}) OutId
var Coercion
co
  = forall a. HasCallStack => Bool -> a -> a
assert (OutId -> Bool
isCoVar OutId
var) forall a b. (a -> b) -> a -> b
$
    SimplEnv
env {seCvSubst :: CvSubstEnv
seCvSubst = forall a. VarEnv a -> OutId -> a -> VarEnv a
extendVarEnv CvSubstEnv
csubst OutId
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 -> [OutId] -> SimplEnv
addNewInScopeIds env :: SimplEnv
env@(SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
id_subst }) [OutId]
vs
-- See Note [Bangs in the Simplifier]
  = let !in_scope1 :: InScopeSet
in_scope1 = InScopeSet
in_scope InScopeSet -> [OutId] -> InScopeSet
`extendInScopeSetList` [OutId]
vs
        !id_subst1 :: SimplIdSubst
id_subst1 = SimplIdSubst
id_subst forall a. VarEnv a -> [OutId] -> VarEnv a
`delVarEnvList` [OutId]
vs
    in
    SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope1,
          seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
id_subst1 }
        -- 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 -> OutId -> SimplEnv
modifyInScope env :: SimplEnv
env@(SimplEnv {seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope}) OutId
v
  = SimplEnv
env {seInScope :: InScopeSet
seInScope = InScopeSet -> OutId -> InScopeSet
extendInScopeSet InScopeSet
in_scope OutId
v}

enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))
                  -> SimplM (r, SimplEnv)
enterRecGroupRHSs :: forall r.
SimplEnv
-> [OutId]
-> (SimplEnv -> SimplM (r, SimplEnv))
-> SimplM (r, SimplEnv)
enterRecGroupRHSs SimplEnv
env [OutId]
bndrs SimplEnv -> SimplM (r, SimplEnv)
k = do
  --pprTraceM "enterRecGroupRHSs" (ppr bndrs)
  (r
r, SimplEnv
env'') <- SimplEnv -> SimplM (r, SimplEnv)
k SimplEnv
env{seRecIds :: UnVarSet
seRecIds = [OutId] -> UnVarSet -> UnVarSet
extendUnVarSetList [OutId]
bndrs (SimplEnv -> UnVarSet
seRecIds SimplEnv
env)}
  forall (m :: * -> *) a. Monad m => a -> m a
return (r
r, SimplEnv
env''{seRecIds :: UnVarSet
seRecIds = SimplEnv -> UnVarSet
seRecIds SimplEnv
env})

{- 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 binding 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 = forall a. VarEnv a
emptyVarEnv, seCvSubst :: CvSubstEnv
seCvSubst = forall a. VarEnv a
emptyVarEnv, seIdSubst :: SimplIdSubst
seIdSubst = 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.

The `FloatFlag` contains summary information about the bindings, see the data
type declaration of `FloatFlag`

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
  NonRec x# (a /# b)    FltCareful  -- Might fail; does not satisfy let-can-float invariant
  NonRec x# (f y)       FltCareful  -- Might diverge; does not satisfy let-can-float invariant
-}

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
                -- NB: consequence: all bindings satisfy let-can-float invariant

  | 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)
                -- NB: consequence: all bindings satisfy let-can-float invariant

  | FltCareful  -- At least one binding is strict (or unlifted)
                --      and not guaranteed cheap
                -- Do not float these bindings out of a lazy let!
                -- NB: some bindings may not satisfy let-can-float

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

instance Outputable FloatFlag where
  ppr :: FloatFlag -> SDoc
ppr FloatFlag
FltLifted  = forall doc. IsLine doc => String -> doc
text String
"FltLifted"
  ppr FloatFlag
FltOkSpec  = forall doc. IsLine doc => String -> doc
text String
"FltOkSpec"
  ppr FloatFlag
FltCareful = forall doc. IsLine doc => String -> doc
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 :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
-- If you change this function look also at FloatIn.noFloatIntoRhs
doFloatFromRhs :: FloatEnable
-> TopLevelFlag
-> RecFlag
-> Bool
-> SimplFloats
-> OutExpr
-> Bool
doFloatFromRhs FloatEnable
fe TopLevelFlag
lvl RecFlag
rec Bool
strict_bind (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats = LetFloats JoinFloats
fs FloatFlag
ff }) OutExpr
rhs
  = TopLevelFlag -> FloatEnable -> Bool
floatEnabled TopLevelFlag
lvl FloatEnable
fe
      Bool -> Bool -> Bool
&& Bool -> Bool
not (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
strict_bind

     -- Whether any floating is allowed by flags.
     floatEnabled :: TopLevelFlag -> FloatEnable -> Bool
     floatEnabled :: TopLevelFlag -> FloatEnable -> Bool
floatEnabled TopLevelFlag
_ FloatEnable
FloatDisabled = Bool
False
     floatEnabled TopLevelFlag
lvl FloatEnable
FloatNestedOnly = Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
lvl)
     floatEnabled TopLevelFlag
_ FloatEnable
FloatEnabled = Bool
True

{-
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 forall a. OrdList a
nilOL FloatFlag
FltLifted

isEmptyLetFloats :: LetFloats -> Bool
isEmptyLetFloats :: LetFloats -> Bool
isEmptyLetFloats (LetFloats JoinFloats
fs FloatFlag
_) = forall a. OrdList a -> Bool
isNilOL JoinFloats
fs

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

isEmptyJoinFloats :: JoinFloats -> Bool
isEmptyJoinFloats :: JoinFloats -> Bool
isEmptyJoinFloats = forall a. OrdList a -> Bool
isNilOL

unitLetFloat :: OutBind -> LetFloats
-- This key function constructs a singleton float with the right form
unitLetFloat :: Bind OutId -> LetFloats
unitLetFloat Bind OutId
bind = forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutId -> Bool
isJoinId) (forall b. Bind b -> [b]
bindersOf Bind OutId
bind)) forall a b. (a -> b) -> a -> b
$
                    JoinFloats -> FloatFlag -> LetFloats
LetFloats (forall a. a -> OrdList a
unitOL Bind OutId
bind) (Bind OutId -> FloatFlag
flag Bind OutId
bind)
  where
    flag :: Bind OutId -> FloatFlag
flag (Rec {})                = FloatFlag
FltLifted
    flag (NonRec OutId
bndr OutExpr
rhs)
      | Bool -> Bool
not (OutId -> Bool
isStrictId OutId
bndr)    = FloatFlag
FltLifted
      | OutExpr -> Bool
exprIsTickedString OutExpr
rhs   = FloatFlag
FltLifted
          -- String literals can be floated freely.
          -- See Note [Core top-level string literals] in GHC.Core.
      | OutExpr -> Bool
exprOkForSpeculation OutExpr
rhs = FloatFlag
FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
      | Bool
otherwise                = FloatFlag
FltCareful

unitJoinFloat :: OutBind -> JoinFloats
unitJoinFloat :: Bind OutId -> JoinFloats
unitJoinFloat Bind OutId
bind = forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all OutId -> Bool
isJoinId (forall b. Bind b -> [b]
bindersOf Bind OutId
bind)) forall a b. (a -> b) -> a -> b
$
                     forall a. a -> OrdList a
unitOL Bind OutId
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 -> Bind OutId -> (SimplFloats, SimplEnv)
mkFloatBind SimplEnv
env Bind OutId
bind
  = (SimplFloats
floats, SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope' })
  where
    floats :: SimplFloats
floats
      | Bind OutId -> Bool
isJoinBind Bind OutId
bind
      = SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
emptyLetFloats
                    , sfJoinFloats :: JoinFloats
sfJoinFloats = Bind OutId -> JoinFloats
unitJoinFloat Bind OutId
bind
                    , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope' }
      | Bool
otherwise
      = SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = Bind OutId -> LetFloats
unitLetFloat Bind OutId
bind
                    , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
emptyJoinFloats
                    , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope' }
    -- See Note [Bangs in the Simplifier]
    !in_scope' :: InScopeSet
in_scope' = SimplEnv -> InScopeSet
seInScope SimplEnv
env InScopeSet -> Bind OutId -> InScopeSet
`extendInScopeSetBind` Bind OutId
bind

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

extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet
extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet
extendInScopeFromLF InScopeSet
in_scope (LetFloats JoinFloats
binds FloatFlag
_)
  = forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL InScopeSet -> Bind OutId -> InScopeSet
extendInScopeSetBind InScopeSet
in_scope 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    = forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL InScopeSet -> Bind OutId -> InScopeSet
extendInScopeSetBind
                                    (SimplFloats -> InScopeSet
sfInScope SimplFloats
floats) JoinFloats
join_floats }

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 { 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 forall a. OrdList a -> OrdList a -> OrdList a
`appOL` JoinFloats
bs2) (FloatFlag
l1 FloatFlag -> FloatFlag -> FloatFlag
`andFF` FloatFlag
l2)

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

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

mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats 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 })
  = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall a. OrdList a -> Bool
isNilOL JoinFloats
bs Bool -> Bool -> Bool
|| forall a. OrdList a -> Bool
isNilOL JoinFloats
jbs) (forall a. Outputable a => a -> SDoc
ppr SimplFloats
floats) forall a b. (a -> b) -> a -> b
$
    SimplFloats { sfLetFloats :: LetFloats
sfLetFloats  = LetFloats
floats'
                , sfJoinFloats :: JoinFloats
sfJoinFloats = JoinFloats
jfloats'
                , sfInScope :: InScopeSet
sfInScope    = InScopeSet
in_scope }
  where
    -- See Note [Bangs in the Simplifier]
    !floats' :: LetFloats
floats'  | forall a. OrdList a -> Bool
isNilOL JoinFloats
bs  = LetFloats
emptyLetFloats
              | Bool
otherwise   = Bind OutId -> LetFloats
unitLetFloat (forall b. [(b, Expr b)] -> Bind b
Rec (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (forall a. OrdList a -> [a]
fromOL JoinFloats
bs)))
    !jfloats' :: JoinFloats
jfloats' | forall a. OrdList a -> Bool
isNilOL JoinFloats
jbs = JoinFloats
emptyJoinFloats
              | Bool
otherwise   = Bind OutId -> JoinFloats
unitJoinFloat (forall b. [(b, Expr b)] -> Bind b
Rec (forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (forall a. OrdList a -> [a]
fromOL JoinFloats
jbs)))

wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
wrapFloats (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats JoinFloats
bs FloatFlag
flag
                        , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jbs }) OutExpr
body
  = forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Bind OutId -> OutExpr -> OutExpr
mk_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
  where
    mk_let :: Bind OutId -> OutExpr -> OutExpr
mk_let | FloatFlag
FltCareful <- FloatFlag
flag = Bind OutId -> OutExpr -> OutExpr
mkCoreLet -- need to enforce let-can-float-invariant
           | Bool
otherwise          = forall b. Bind b -> Expr b -> Expr b
Let       -- let-can-float invariant hold

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
  = forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL forall b. Bind b -> Expr b -> Expr b
Let OutExpr
body JoinFloats
join_floats

getTopFloatBinds :: SimplFloats -> [CoreBind]
getTopFloatBinds :: SimplFloats -> [Bind OutId]
getTopFloatBinds (SimplFloats { sfLetFloats :: SimplFloats -> LetFloats
sfLetFloats  = LetFloats
lbs
                              , sfJoinFloats :: SimplFloats -> JoinFloats
sfJoinFloats = JoinFloats
jbs})
  = forall a. HasCallStack => Bool -> a -> a
assert (forall a. OrdList a -> Bool
isNilOL JoinFloats
jbs) forall a b. (a -> b) -> a -> b
$  -- Can't be any top-level join bindings
    LetFloats -> [Bind OutId]
letFloatBinds LetFloats
lbs

{-# INLINE mapLetFloats #-}
mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
mapLetFloats :: LetFloats -> ((OutId, OutExpr) -> (OutId, OutExpr)) -> LetFloats
mapLetFloats (LetFloats JoinFloats
fs FloatFlag
ff) (OutId, OutExpr) -> (OutId, OutExpr)
fun
   = JoinFloats -> FloatFlag -> LetFloats
LetFloats JoinFloats
fs1 FloatFlag
ff
   where
    app :: Bind OutId -> Bind OutId
app (NonRec OutId
b OutExpr
e) = case (OutId, OutExpr) -> (OutId, OutExpr)
fun (OutId
b,OutExpr
e) of (OutId
b',OutExpr
e') -> forall b. b -> Expr b -> Bind b
NonRec OutId
b' OutExpr
e'
    app (Rec [(OutId, OutExpr)]
bs)     = forall b. [(b, Expr b)] -> Bind b
Rec (forall a b. (a -> b) -> [a] -> [b]
strictMap (OutId, OutExpr) -> (OutId, OutExpr)
fun [(OutId, OutExpr)]
bs)
    !fs1 :: JoinFloats
fs1 = (forall a b. (a -> b) -> OrdList a -> OrdList b
mapOL' Bind OutId -> Bind OutId
app JoinFloats
fs) -- See Note [Bangs in the Simplifier]

{-
************************************************************************
*                                                                      *
                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 -> OutId -> SimplSR
substId (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
ids }) OutId
v
  = case forall a. VarEnv a -> OutId -> Maybe a
lookupVarEnv SimplIdSubst
ids OutId
v of  -- Note [Global Ids in the substitution]
        Maybe SimplSR
Nothing               -> OutId -> SimplSR
DoneId (InScopeSet -> OutId -> OutId
refineFromInScope InScopeSet
in_scope OutId
v)
        Just (DoneId OutId
v)       -> OutId -> SimplSR
DoneId (InScopeSet -> OutId -> OutId
refineFromInScope InScopeSet
in_scope OutId
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 GHC.Core.Opt.Simplify.

refineFromInScope :: InScopeSet -> Var -> Var
refineFromInScope :: InScopeSet -> OutId -> OutId
refineFromInScope InScopeSet
in_scope OutId
v
  | OutId -> Bool
isLocalId OutId
v = case InScopeSet -> OutId -> Maybe OutId
lookupInScope InScopeSet
in_scope OutId
v of
                  Just OutId
v' -> OutId
v'
                  Maybe OutId
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"refineFromInScope" (forall a. Outputable a => a -> SDoc
ppr InScopeSet
in_scope forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr OutId
v)
                             -- c.f #19074 for a subtle place where this went wrong
  | Bool
otherwise = OutId
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 -> OutId -> OutId
lookupRecBndr (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
ids }) OutId
v
  = case forall a. VarEnv a -> OutId -> Maybe a
lookupVarEnv SimplIdSubst
ids OutId
v of
        Just (DoneId OutId
v) -> OutId
v
        Just SimplSR
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupRecBndr" (forall a. Outputable a => a -> SDoc
ppr OutId
v)
        Maybe SimplSR
Nothing -> InScopeSet -> OutId -> OutId
refineFromInScope InScopeSet
in_scope OutId
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.

See also Note [Scaling join point arguments].
-}

simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders :: SimplEnv -> [OutId] -> SimplM (SimplEnv, [OutId])
simplBinders  !SimplEnv
env [OutId]
bndrs = forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM SimplEnv -> OutId -> SimplM (SimplEnv, OutId)
simplBinder  SimplEnv
env [OutId]
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 -> OutId -> SimplM (SimplEnv, OutId)
simplBinder !SimplEnv
env OutId
bndr
  | OutId -> Bool
isTyVar OutId
bndr  = do  { let (SimplEnv
env', OutId
tv) = SimplEnv -> OutId -> (SimplEnv, OutId)
substTyVarBndr SimplEnv
env OutId
bndr
                        ; OutId -> ()
seqTyVar OutId
tv seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env', OutId
tv) }
  | Bool
otherwise     = do  { let (SimplEnv
env', OutId
id) = SimplEnv -> OutId -> (SimplEnv, OutId)
substIdBndr SimplEnv
env OutId
bndr
                        ; OutId -> ()
seqId OutId
id seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env', OutId
id) }

---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
simplNonRecBndr :: SimplEnv -> OutId -> SimplM (SimplEnv, OutId)
simplNonRecBndr !SimplEnv
env OutId
id
  -- See Note [Bangs in the Simplifier]
  = do  { let (!SimplEnv
env1, OutId
id1) = SimplEnv -> OutId -> (SimplEnv, OutId)
substIdBndr SimplEnv
env OutId
id
        ; OutId -> ()
seqId OutId
id1 seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env1, OutId
id1) }

---------------
simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders
simplRecBndrs :: SimplEnv -> [OutId] -> SimplM SimplEnv
simplRecBndrs env :: SimplEnv
env@(SimplEnv {}) [OutId]
ids
  -- See Note [Bangs in the Simplifier]
  = forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutId -> Bool
isJoinId) [OutId]
ids) forall a b. (a -> b) -> a -> b
$
    do  { let (!SimplEnv
env1, [OutId]
ids1) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL SimplEnv -> OutId -> (SimplEnv, OutId)
substIdBndr SimplEnv
env [OutId]
ids
        ; [OutId] -> ()
seqIds [OutId]
ids1 seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return SimplEnv
env1 }

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

---------------
substNonCoVarIdBndr
   :: 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 GHC.Core.Subst.substIdBndr, except that
--      the type of id_subst differs
--      all fragile info is zapped
substNonCoVarIdBndr :: SimplEnv -> OutId -> (SimplEnv, OutId)
substNonCoVarIdBndr SimplEnv
env OutId
id = SimplEnv -> OutId -> (OutId -> OutId) -> (SimplEnv, OutId)
subst_id_bndr SimplEnv
env OutId
id (\OutId
x -> OutId
x)

-- Inline to make the (OutId -> OutId) function a known call.
-- This is especially important for `substNonCoVarIdBndr` which
-- passes an identity lambda.
{-# INLINE subst_id_bndr #-}
subst_id_bndr :: SimplEnv
              -> InBndr    -- Env and binder to transform
              -> (OutId -> OutId)  -- Adjust the type
              -> (SimplEnv, OutBndr)
subst_id_bndr :: SimplEnv -> OutId -> (OutId -> OutId) -> (SimplEnv, OutId)
subst_id_bndr env :: SimplEnv
env@(SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seIdSubst :: SimplEnv -> SimplIdSubst
seIdSubst = SimplIdSubst
id_subst })
              OutId
old_id OutId -> OutId
adjust_type
  = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (OutId -> Bool
isCoVar OutId
old_id)) (forall a. Outputable a => a -> SDoc
ppr OutId
old_id)
    (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
new_in_scope,
           seIdSubst :: SimplIdSubst
seIdSubst = SimplIdSubst
new_subst }, OutId
new_id)
    -- It's important that both seInScope and seIdSubst are updated with
    -- the new_id, /after/ applying adjust_type. That's why adjust_type
    -- is done here.  If we did adjust_type in simplJoinBndr (the only
    -- place that gives a non-identity adjust_type) we'd have to fiddle
    -- afresh with both seInScope and seIdSubst
  where
    -- See Note [Bangs in the Simplifier]
    !id1 :: OutId
id1  = InScopeSet -> OutId -> OutId
uniqAway InScopeSet
in_scope OutId
old_id
    !id2 :: OutId
id2  = SimplEnv -> OutId -> OutId
substIdType SimplEnv
env OutId
id1
    !id3 :: OutId
id3  = OutId -> OutId
zapFragileIdInfo OutId
id2      -- Zaps rules, worker-info, unfolding
                                      -- and fragile OccInfo
    !new_id :: OutId
new_id = OutId -> OutId
adjust_type OutId
id3

        -- 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 | OutId
new_id forall a. Eq a => a -> a -> Bool
/= OutId
old_id
              = forall a. VarEnv a -> OutId -> a -> VarEnv a
extendVarEnv SimplIdSubst
id_subst OutId
old_id (OutId -> SimplSR
DoneId OutId
new_id)
              | Bool
otherwise
              = forall a. VarEnv a -> OutId -> VarEnv a
delVarEnv SimplIdSubst
id_subst OutId
old_id

    !new_in_scope :: InScopeSet
new_in_scope = InScopeSet
in_scope InScopeSet -> OutId -> InScopeSet
`extendInScopeSet` OutId
new_id

------------------------------------
seqTyVar :: TyVar -> ()
seqTyVar :: OutId -> ()
seqTyVar OutId
b = OutId
b seq :: forall a b. a -> b -> b
`seq` ()

seqId :: Id -> ()
seqId :: OutId -> ()
seqId OutId
id = Kind -> ()
seqType (OutId -> Kind
idType OutId
id)  seq :: forall a b. a -> b -> b
`seq`
           HasDebugCallStack => OutId -> IdInfo
idInfo OutId
id            seq :: forall a b. a -> b -> b
`seq`
           ()

seqIds :: [Id] -> ()
seqIds :: [OutId] -> ()
seqIds []       = ()
seqIds (OutId
id:[OutId]
ids) = OutId -> ()
seqId OutId
id seq :: forall a b. a -> b -> b
`seq` [OutId] -> ()
seqIds [OutId]
ids

{-
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
We *do* transfer the arity from the in_id of a let binding to the
out_id so that its arity is visible in its RHS. Examples:

  * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)
    Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a
    hard time figuring that out when `f` only has arity 0 in its own RHS.
  * f = \x y. ....(f `seq` blah)....
    We want to drop the seq.
  * f = \x. g (\y. f y)
    You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.
    Unfortunately, it is not sound in general to eta-reduce in f's RHS.
    Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how
    we prevent 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.
-}


{- *********************************************************************
*                                                                      *
                Join points
*                                                                      *
********************************************************************* -}

simplNonRecJoinBndr :: SimplEnv -> InBndr
                    -> Mult -> OutType
                    -> 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 -> OutId -> Kind -> Kind -> SimplM (SimplEnv, OutId)
simplNonRecJoinBndr SimplEnv
env OutId
id Kind
mult Kind
res_ty
  = do { let (SimplEnv
env1, OutId
id1) = Kind -> Kind -> SimplEnv -> OutId -> (SimplEnv, OutId)
simplJoinBndr Kind
mult Kind
res_ty SimplEnv
env OutId
id
       ; OutId -> ()
seqId OutId
id1 seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (SimplEnv
env1, OutId
id1) }

simplRecJoinBndrs :: SimplEnv -> [InBndr]
                  -> Mult -> OutType
                  -> SimplM SimplEnv
-- Recursive let binders for join points;
-- context being pushed inward may change types
-- See Note [Return type for join points]
simplRecJoinBndrs :: SimplEnv -> [OutId] -> Kind -> Kind -> SimplM SimplEnv
simplRecJoinBndrs env :: SimplEnv
env@(SimplEnv {}) [OutId]
ids Kind
mult Kind
res_ty
  = forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all OutId -> Bool
isJoinId [OutId]
ids) forall a b. (a -> b) -> a -> b
$
    do  { let (SimplEnv
env1, [OutId]
ids1) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Kind -> Kind -> SimplEnv -> OutId -> (SimplEnv, OutId)
simplJoinBndr Kind
mult Kind
res_ty) SimplEnv
env [OutId]
ids
        ; [OutId] -> ()
seqIds [OutId]
ids1 seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return SimplEnv
env1 }

---------------
simplJoinBndr :: Mult -> OutType
              -> SimplEnv -> InBndr
              -> (SimplEnv, OutBndr)
simplJoinBndr :: Kind -> Kind -> SimplEnv -> OutId -> (SimplEnv, OutId)
simplJoinBndr Kind
mult Kind
res_ty SimplEnv
env OutId
id
  = SimplEnv -> OutId -> (OutId -> OutId) -> (SimplEnv, OutId)
subst_id_bndr SimplEnv
env OutId
id (Kind -> Kind -> OutId -> OutId
adjustJoinPointType Kind
mult Kind
res_ty)

---------------
adjustJoinPointType :: Mult
                    -> Type     -- New result type
                    -> Id       -- Old join-point Id
                    -> Id       -- Adjusted join-point Id
-- (adjustJoinPointType mult new_res_ty join_id) does two things:
--
--   1. Set the return type of the join_id to new_res_ty
--      See Note [Return type for join points]
--
--   2. Adjust the multiplicity of arrows in join_id's type, as
--      directed by 'mult'. See Note [Scaling join point arguments]
--
-- INVARIANT: If any of the first n binders are foralls, those tyvars
-- cannot appear in the original result type. See isValidJoinPointType.
adjustJoinPointType :: Kind -> Kind -> OutId -> OutId
adjustJoinPointType Kind
mult Kind
new_res_ty OutId
join_id
  = forall a. HasCallStack => Bool -> a -> a
assert (OutId -> Bool
isJoinId OutId
join_id) forall a b. (a -> b) -> a -> b
$
    OutId -> Kind -> OutId
setIdType OutId
join_id Kind
new_join_ty
  where
    orig_ar :: JoinArity
orig_ar = OutId -> JoinArity
idJoinArity OutId
join_id
    orig_ty :: Kind
orig_ty = OutId -> Kind
idType OutId
join_id

    new_join_ty :: Kind
new_join_ty = JoinArity -> Kind -> Kind
go JoinArity
orig_ar Kind
orig_ty :: Type

    go :: JoinArity -> Kind -> Kind
go JoinArity
0 Kind
_  = Kind
new_res_ty
    go JoinArity
n Kind
ty | Just (PiTyBinder
arg_bndr, Kind
res_ty) <- Kind -> Maybe (PiTyBinder, Kind)
splitPiTy_maybe Kind
ty
            = PiTyBinder -> Kind -> Kind
mkPiTy (PiTyBinder -> PiTyBinder
scale_bndr PiTyBinder
arg_bndr) forall a b. (a -> b) -> a -> b
$
              JoinArity -> Kind -> Kind
go (JoinArity
nforall a. Num a => a -> a -> a
-JoinArity
1) Kind
res_ty
            | Bool
otherwise
            = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"adjustJoinPointType" (forall a. Outputable a => a -> SDoc
ppr JoinArity
orig_ar forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
orig_ty)

    -- See Note [Bangs in the Simplifier]
    scale_bndr :: PiTyBinder -> PiTyBinder
scale_bndr (Anon Scaled Kind
t FunTyFlag
af) = (Scaled Kind -> FunTyFlag -> PiTyBinder
Anon forall a b. (a -> b) -> a -> b
$! (forall a. Kind -> Scaled a -> Scaled a
scaleScaled Kind
mult Scaled Kind
t)) FunTyFlag
af
    scale_bndr b :: PiTyBinder
b@(Named ForAllTyBinder
_) = PiTyBinder
b

{- Note [Scaling join point arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a join point which is linear in its variable, in some context E:

E[join j :: a %1 -> a
       j x = x
  in case v of
       A -> j 'x'
       B -> <blah>]

The simplifier changes to:

join j :: a %1 -> a
     j x = E[x]
in case v of
     A -> j 'x'
     B -> E[<blah>]

If E uses its argument in a nonlinear way (e.g. a case['Many]), then
this is wrong: the join point has to change its type to a -> a.
Otherwise, we'd get a linearity error.

See also Note [Return type for join points] and Note [Join points and case-of-case].
-}

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

getSubst :: SimplEnv -> Subst
getSubst :: SimplEnv -> Subst
getSubst (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 -> IdSubstEnv -> Subst
mkSubst InScopeSet
in_scope TvSubstEnv
tv_env CvSubstEnv
cv_env IdSubstEnv
emptyIdSubstEnv

substTy :: HasDebugCallStack => SimplEnv -> Type -> Type
substTy :: HasDebugCallStack => SimplEnv -> Kind -> Kind
substTy SimplEnv
env Kind
ty = HasDebugCallStack => Subst -> Kind -> Kind
Type.substTy (SimplEnv -> Subst
getSubst SimplEnv
env) Kind
ty

substTyVar :: SimplEnv -> TyVar -> Type
substTyVar :: SimplEnv -> OutId -> Kind
substTyVar SimplEnv
env OutId
tv = Subst -> OutId -> Kind
Type.substTyVar (SimplEnv -> Subst
getSubst SimplEnv
env) OutId
tv

substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
substTyVarBndr :: SimplEnv -> OutId -> (SimplEnv, OutId)
substTyVarBndr SimplEnv
env OutId
tv
  = case HasDebugCallStack => Subst -> OutId -> (Subst, OutId)
Type.substTyVarBndr (SimplEnv -> Subst
getSubst SimplEnv
env) OutId
tv of
        (Subst InScopeSet
in_scope' IdSubstEnv
_ TvSubstEnv
tv_env' CvSubstEnv
cv_env', OutId
tv')
           -> (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope', seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
tv_env', seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
cv_env' }, OutId
tv')

substCoVar :: SimplEnv -> CoVar -> Coercion
substCoVar :: SimplEnv -> OutId -> Coercion
substCoVar SimplEnv
env OutId
tv = Subst -> OutId -> Coercion
Coercion.substCoVar (SimplEnv -> Subst
getSubst SimplEnv
env) OutId
tv

substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
substCoVarBndr :: SimplEnv -> OutId -> (SimplEnv, OutId)
substCoVarBndr SimplEnv
env OutId
cv
  = case HasDebugCallStack => Subst -> OutId -> (Subst, OutId)
Coercion.substCoVarBndr (SimplEnv -> Subst
getSubst SimplEnv
env) OutId
cv of
        (Subst InScopeSet
in_scope' IdSubstEnv
_ TvSubstEnv
tv_env' CvSubstEnv
cv_env', OutId
cv')
           -> (SimplEnv
env { seInScope :: InScopeSet
seInScope = InScopeSet
in_scope', seTvSubst :: TvSubstEnv
seTvSubst = TvSubstEnv
tv_env', seCvSubst :: CvSubstEnv
seCvSubst = CvSubstEnv
cv_env' }, OutId
cv')

substCo :: SimplEnv -> Coercion -> Coercion
substCo :: SimplEnv -> Coercion -> Coercion
substCo SimplEnv
env Coercion
co = HasDebugCallStack => Subst -> Coercion -> Coercion
Coercion.substCo (SimplEnv -> Subst
getSubst SimplEnv
env) Coercion
co

------------------
substIdType :: SimplEnv -> Id -> Id
substIdType :: SimplEnv -> OutId -> OutId
substIdType (SimplEnv { seInScope :: SimplEnv -> InScopeSet
seInScope = InScopeSet
in_scope, seTvSubst :: SimplEnv -> TvSubstEnv
seTvSubst = TvSubstEnv
tv_env, seCvSubst :: SimplEnv -> CvSubstEnv
seCvSubst = CvSubstEnv
cv_env }) OutId
id
  | (forall a. VarEnv a -> Bool
isEmptyVarEnv TvSubstEnv
tv_env Bool -> Bool -> Bool
&& forall a. VarEnv a -> Bool
isEmptyVarEnv CvSubstEnv
cv_env)
    Bool -> Bool -> Bool
|| Bool
no_free_vars
  = OutId
id
  | Bool
otherwise = (Kind -> Kind) -> OutId -> OutId
Id.updateIdTypeAndMult (Subst -> Kind -> Kind
Type.substTyUnchecked Subst
subst) OutId
id
                -- 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
    no_free_vars :: Bool
no_free_vars = Kind -> Bool
noFreeVarsOfType Kind
old_ty Bool -> Bool -> Bool
&& Kind -> Bool
noFreeVarsOfType Kind
old_w
    subst :: Subst
subst = InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst
Subst InScopeSet
in_scope IdSubstEnv
emptyIdSubstEnv TvSubstEnv
tv_env CvSubstEnv
cv_env
    old_ty :: Kind
old_ty = OutId -> Kind
idType OutId
id
    old_w :: Kind
old_w  = OutId -> Kind
varMult OutId
id