{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}


module GHC.Core.SimpleOpt (
        SimpleOpts (..), defaultSimpleOpts,

        -- ** Simple expression optimiser
        simpleOptPgm, simpleOptExpr, simpleOptExprWith,

        -- ** Join points
        joinPointBinding_maybe, joinPointBindings_maybe,

        -- ** Predicates on expressions
        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,

    ) where

import GHC.Prelude

import GHC.Core
import GHC.Core.Opt.Arity
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Make ( FloatBind(..), mkWildValBinder )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )
import GHC.Core.DataCon
import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )
import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                            , isInScope, substTyVarBndr, cloneTyVarBndr )
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )

import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info  ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import GHC.Types.Var      ( isNonCoVarId )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Demand( etaConvertDmdSig, topSubDmd )
import GHC.Types.Tickish
import GHC.Types.Basic

import GHC.Builtin.Types
import GHC.Builtin.Names

import GHC.Unit.Module ( Module )
import GHC.Utils.Encoding
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc

import GHC.Data.Maybe       ( orElse )
import GHC.Data.Graph.UnVar
import Data.List (mapAccumL)
import qualified Data.ByteString as BS

{-
************************************************************************
*                                                                      *
        The Simple Optimiser
*                                                                      *
************************************************************************

Note [The simple optimiser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The simple optimiser is a lightweight, pure (non-monadic) function
that rapidly does a lot of simple optimisations, including

  - inlining things that occur just once,
      or whose RHS turns out to be trivial
  - beta reduction
  - case of known constructor
  - dead code elimination

It does NOT do any call-site inlining; it only inlines a function if
it can do so unconditionally, dropping the binding.  It thereby
guarantees to leave no un-reduced beta-redexes.

It is careful to follow the guidance of "Secrets of the GHC inliner",
and in particular the pre-inline-unconditionally and
post-inline-unconditionally story, to do effective beta reduction on
functions called precisely once, without repeatedly optimising the same
expression.  In fact, the simple optimiser is a good example of this
little dance in action; the full Simplifier is a lot more complicated.

-}

-- | Simple optimiser options
data SimpleOpts = SimpleOpts
   { SimpleOpts -> UnfoldingOpts
so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options
   , SimpleOpts -> OptCoercionOpts
so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
   , SimpleOpts -> Bool
so_eta_red :: !Bool            -- ^ Eta reduction on?
   }

-- | Default options for the Simple optimiser.
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts = SimpleOpts
   { so_uf_opts :: UnfoldingOpts
so_uf_opts = UnfoldingOpts
defaultUnfoldingOpts
   , so_co_opts :: OptCoercionOpts
so_co_opts = OptCoercionOpts { optCoercionEnabled :: Bool
optCoercionEnabled = Bool
False }
   , so_eta_red :: Bool
so_eta_red = Bool
False
   }

simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
-- See Note [The simple optimiser]
-- Do simple optimisation on an expression
-- The optimisation is very straightforward: just
-- inline non-recursive bindings that are used only once,
-- or where the RHS is trivial
--
-- We also inline bindings that bind a Eq# box: see
-- See Note [Getting the map/coerce RULE to work].
--
-- Also we convert functions to join points where possible (as
-- the occurrence analyser does most of the work anyway).
--
-- The result is NOT guaranteed occurrence-analysed, because
-- in  (let x = y in ....) we substitute for x; so y's occ-info
-- may change radically
--
-- Note that simpleOptExpr is a pure function that we want to be able to call
-- from lots of places, including ones that don't have DynFlags (e.g to optimise
-- unfoldings of statically defined Ids via mkCompulsoryUnfolding). It used to
-- fetch its options directly from the DynFlags, however, so some callers had to
-- resort to using unsafeGlobalDynFlags (a global mutable variable containing
-- the DynFlags). It has been modified to take its own SimpleOpts that may be
-- created from DynFlags, but not necessarily.

simpleOptExpr :: HasDebugCallStack => SimpleOpts -> OutExpr -> OutExpr
simpleOptExpr SimpleOpts
opts OutExpr
expr
  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
    HasDebugCallStack => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
init_subst OutExpr
expr
  where
    init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (OutExpr -> VarSet
exprFreeVars OutExpr
expr))
        -- It's potentially important to make a proper in-scope set
        -- Consider  let x = ..y.. in \y. ...x...
        -- Then we should remember to clone y before substituting
        -- for x.  It's very unlikely to occur, because we probably
        -- won't *be* substituting for x if it occurs inside a
        -- lambda.
        --
        -- It's a bit painful to call exprFreeVars, because it makes
        -- three passes instead of two (occ-anal, and go)

simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
subst OutExpr
expr
  = HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
init_env (OutExpr -> OutExpr
occurAnalyseExpr OutExpr
expr)
  where
    init_env :: SimpleOptEnv
init_env = (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts) { soe_subst = subst }

----------------------
simpleOptPgm :: SimpleOpts
             -> Module
             -> CoreProgram
             -> [CoreRule]
             -> (CoreProgram, [CoreRule], CoreProgram)
-- See Note [The simple optimiser]
simpleOptPgm :: SimpleOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> (CoreProgram, [CoreRule], CoreProgram)
simpleOptPgm SimpleOpts
opts Module
this_mod CoreProgram
binds [CoreRule]
rules =
    (CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
binds', [CoreRule]
rules', CoreProgram
occ_anald_binds)
  where
    occ_anald_binds :: CoreProgram
occ_anald_binds  = Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod
                          (\Id
_ -> Bool
True)  {- All unfoldings active -}
                          (\Activation
_ -> Bool
False) {- No rules active -}
                          [CoreRule]
rules CoreProgram
binds

    (SimpleOptEnv
final_env, CoreProgram
binds') = ((SimpleOptEnv, CoreProgram)
 -> InBind -> (SimpleOptEnv, CoreProgram))
-> (SimpleOptEnv, CoreProgram)
-> CoreProgram
-> (SimpleOptEnv, CoreProgram)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts, []) CoreProgram
occ_anald_binds
    final_subst :: Subst
final_subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
final_env

    rules' :: [CoreRule]
rules' = Subst -> [CoreRule] -> [CoreRule]
substRulesForImportedIds Subst
final_subst [CoreRule]
rules
             -- We never unconditionally inline into rules,
             -- hence paying just a substitution

    do_one :: (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (SimpleOptEnv
env, CoreProgram
binds') InBind
bind
      = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
TopLevel of
          (SimpleOptEnv
env', Maybe InBind
Nothing)    -> (SimpleOptEnv
env', CoreProgram
binds')
          (SimpleOptEnv
env', Just InBind
bind') -> (SimpleOptEnv
env', InBind
bind'InBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
:CoreProgram
binds')

-- In these functions the substitution maps InVar -> OutExpr

----------------------
type SimpleClo = (SimpleOptEnv, InExpr)

data SimpleOptEnv
  = SOE { SimpleOptEnv -> SimpleOpts
soe_opts :: {-# UNPACK #-} !SimpleOpts
             -- ^ Simplifier options

        , SimpleOptEnv -> IdEnv SimpleClo
soe_inl :: IdEnv SimpleClo
             -- ^ Deals with preInlineUnconditionally; things
             -- that occur exactly once and are inlined
             -- without having first been simplified

        , SimpleOptEnv -> Subst
soe_subst :: Subst
             -- ^ Deals with cloning; includes the InScopeSet

        , SimpleOptEnv -> UnVarSet
soe_rec_ids :: !UnVarSet
             -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing.
             -- See Note [Eta reduction in recursive RHSs]
        }

instance Outputable SimpleOptEnv where
  ppr :: SimpleOptEnv -> SDoc
ppr (SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SOE {" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"soe_inl   =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IdEnv SimpleClo -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv SimpleClo
inl
                            , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"soe_subst =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst ]
                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"}"

emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts = SOE { soe_inl :: IdEnv SimpleClo
soe_inl     = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
                    , soe_subst :: Subst
soe_subst   = Subst
emptySubst
                    , soe_rec_ids :: UnVarSet
soe_rec_ids = UnVarSet
emptyUnVarSet
                    , soe_opts :: SimpleOpts
soe_opts    = SimpleOpts
opts  }

soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
  = SimpleOptEnv
env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst }

soeInScope :: SimpleOptEnv -> InScopeSet
soeInScope :: SimpleOptEnv -> InScopeSet
soeInScope (SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) = Subst -> InScopeSet
getSubstInScope Subst
subst

soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope InScopeSet
in_scope env2 :: SimpleOptEnv
env2@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst2 })
  = SimpleOptEnv
env2 { soe_subst = setInScope subst2 in_scope }

enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))
                  -> (SimpleOptEnv, r)
enterRecGroupRHSs :: forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env [Id]
bndrs SimpleOptEnv -> (SimpleOptEnv, r)
k
  = (SimpleOptEnv
env'{soe_rec_ids = soe_rec_ids env}, r
r)
  where
    (SimpleOptEnv
env', r
r) = SimpleOptEnv -> (SimpleOptEnv, r)
k SimpleOptEnv
env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}

---------------
simple_opt_clo :: HasDebugCallStack
               => InScopeSet
               -> SimpleClo
               -> OutExpr
simple_opt_clo :: HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr
simple_opt_clo InScopeSet
in_scope (SimpleOptEnv
e_env, OutExpr
e)
  = HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr (InScopeSet -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope InScopeSet
in_scope SimpleOptEnv
e_env) OutExpr
e

simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
expr
  = OutExpr -> OutExpr
go OutExpr
expr
  where
    rec_ids :: UnVarSet
rec_ids      = SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env
    subst :: Subst
subst        = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
    in_scope :: InScopeSet
in_scope     = Subst -> InScopeSet
getSubstInScope Subst
subst
    in_scope_env :: InScopeEnv
in_scope_env = InScopeSet -> IdUnfoldingFun -> InScopeEnv
ISE InScopeSet
in_scope IdUnfoldingFun
alwaysActiveUnfoldingFun

    ---------------
    go :: OutExpr -> OutExpr
go (Var Id
v)
       | Just SimpleClo
clo <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
       = HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr
InScopeSet -> SimpleClo -> OutExpr
simple_opt_clo InScopeSet
in_scope SimpleClo
clo
       | Bool
otherwise
       = HasDebugCallStack => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v

    go (App OutExpr
e1 OutExpr
e2)      = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 [(SimpleOptEnv
env,OutExpr
e2)]
    go (Type Type
ty)        = Type -> OutExpr
forall b. Type -> Expr b
Type     (Subst -> Type -> Type
substTyUnchecked Subst
subst Type
ty)
    go (Coercion Coercion
co)    = Coercion -> OutExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion
go_co Coercion
co)
    go (Lit Literal
lit)        = Literal -> OutExpr
forall b. Literal -> Expr b
Lit Literal
lit
    go (Tick CoreTickish
tickish OutExpr
e) = CoreTickish -> OutExpr -> OutExpr
mkTick (Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
tickish) (OutExpr -> OutExpr
go OutExpr
e)
    go (Cast OutExpr
e Coercion
co)      = OutExpr -> Coercion -> OutExpr
mk_cast (OutExpr -> OutExpr
go OutExpr
e) (Coercion -> Coercion
go_co Coercion
co)
    go (Let InBind
bind OutExpr
body)  = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
                             (SimpleOptEnv
env', Maybe InBind
Nothing)   -> HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body
                             (SimpleOptEnv
env', Just InBind
bind) -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)

    go lam :: OutExpr
lam@(Lam {})     = SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [] OutExpr
lam
    go (Case OutExpr
e Id
b Type
ty [Alt Id]
as)
      | Id -> Bool
isDeadBinder Id
b
      , Just (InScopeSet
_, [], DataCon
con, [Type]
_tys, [OutExpr]
es) <- HasDebugCallStack =>
InScopeEnv
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
InScopeEnv
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe InScopeEnv
in_scope_env OutExpr
e'
        -- We don't need to be concerned about floats when looking for coerce.
      , Just (Alt AltCon
altcon [Id]
bs OutExpr
rhs) <- AltCon -> [Alt Id] -> Maybe (Alt Id)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt (DataCon -> AltCon
DataAlt DataCon
con) [Alt Id]
as
      = case AltCon
altcon of
          AltCon
DEFAULT -> OutExpr -> OutExpr
go OutExpr
rhs
          AltCon
_       -> (Maybe (Id, OutExpr) -> OutExpr -> OutExpr)
-> OutExpr -> [Maybe (Id, OutExpr)] -> OutExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs) [Maybe (Id, OutExpr)]
mb_prs
            where
              (SimpleOptEnv
env', [Maybe (Id, OutExpr)]
mb_prs) = (SimpleOptEnv
 -> (Id, OutExpr) -> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> SimpleOptEnv
-> [(Id, OutExpr)]
-> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (TopLevelFlag
-> SimpleOptEnv
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
NotTopLevel) SimpleOptEnv
env ([(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)]))
-> [(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$
                               String -> [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"simpleOptExpr" [Id]
bs [OutExpr]
es

         -- See Note [Getting the map/coerce RULE to work]
      | Id -> Bool
isDeadBinder Id
b
      , [Alt AltCon
DEFAULT [Id]
_ OutExpr
rhs] <- [Alt Id]
as
      , Type -> Bool
isCoVarType (Id -> Type
varType Id
b)
      , (Var Id
fun, [OutExpr]
_args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
e
      , Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleSCSelIdKey
         -- without this last check, we get #11230
      = OutExpr -> OutExpr
go OutExpr
rhs

      | Bool
otherwise
      = OutExpr -> Id -> Type -> [Alt Id] -> OutExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case OutExpr
e' Id
b' (Subst -> Type -> Type
substTyUnchecked Subst
subst Type
ty)
                   ((Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (SimpleOptEnv -> Alt Id -> Alt Id
go_alt SimpleOptEnv
env') [Alt Id]
as)
      where
        e' :: OutExpr
e' = OutExpr -> OutExpr
go OutExpr
e
        (SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b

    ----------------------
    go_co :: Coercion -> Coercion
go_co Coercion
co = OptCoercionOpts -> Subst -> Coercion -> Coercion
optCoercion (SimpleOpts -> OptCoercionOpts
so_co_opts (SimpleOptEnv -> SimpleOpts
soe_opts SimpleOptEnv
env)) Subst
subst Coercion
co

    ----------------------
    go_alt :: SimpleOptEnv -> Alt Id -> Alt Id
go_alt SimpleOptEnv
env (Alt AltCon
con [Id]
bndrs OutExpr
rhs)
      = AltCon -> [Id] -> OutExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs' (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs)
      where
        (SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs

    ----------------------
    -- go_lam tries eta reduction
    -- It is quite important that it does so. I tried removing this code and
    -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many
    -- run/alloc increases. Presumably RULEs are affected.
    go_lam :: SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [Id]
bs' (Lam Id
b OutExpr
e)
       = SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env' (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs') OutExpr
e
       where
         (SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
    go_lam SimpleOptEnv
env [Id]
bs' OutExpr
e
       | SimpleOpts -> Bool
so_eta_red (SimpleOptEnv -> SimpleOpts
soe_opts SimpleOptEnv
env)
       , Just OutExpr
etad_e <- UnVarSet -> [Id] -> OutExpr -> SubDemand -> Maybe OutExpr
tryEtaReduce UnVarSet
rec_ids [Id]
bs OutExpr
e' SubDemand
topSubDmd = OutExpr
etad_e
       | Bool
otherwise                                           = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bs OutExpr
e'
       where
         bs :: [Id]
bs = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs'
         e' :: OutExpr
e' = HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e

mk_cast :: CoreExpr -> CoercionR -> CoreExpr
-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check.
-- mkCast doesn't do that because the Simplifier does (in simplCast)
-- But in SimpleOpt it's nice to kill those nested casts (#18112)
mk_cast :: OutExpr -> Coercion -> OutExpr
mk_cast (Cast OutExpr
e Coercion
co1) Coercion
co2        = OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
mk_cast (Tick CoreTickish
t OutExpr
e)   Coercion
co         = CoreTickish -> OutExpr -> OutExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e Coercion
co)
mk_cast OutExpr
e Coercion
co | Coercion -> Bool
isReflexiveCo Coercion
co = OutExpr
e
             | Bool
otherwise        = OutExpr -> Coercion -> OutExpr
forall b. Expr b -> Coercion -> Expr b
Cast OutExpr
e Coercion
co

----------------------
-- simple_app collects arguments for beta reduction
simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr

simple_app :: HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env (Var Id
v) [SimpleClo]
as
  | Just (SimpleOptEnv
env', OutExpr
e) <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (InScopeSet -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope (SimpleOptEnv -> InScopeSet
soeInScope SimpleOptEnv
env) SimpleOptEnv
env') OutExpr
e [SimpleClo]
as

  | let unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
v
  , Unfolding -> Bool
isCompulsoryUnfolding (IdUnfoldingFun
idUnfolding Id
v)
  , Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
v)
    -- See Note [Unfold compulsory unfoldings in RULE LHSs]
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv
soeZapSubst SimpleOptEnv
env) (Unfolding -> OutExpr
unfoldingTemplate Unfolding
unf) [SimpleClo]
as

  | Bool
otherwise
  , let out_fn :: OutExpr
out_fn = HasDebugCallStack => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
out_fn [SimpleClo]
as

simple_app SimpleOptEnv
env (App OutExpr
e1 OutExpr
e2) [SimpleClo]
as
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 ((SimpleOptEnv
env, OutExpr
e2) SimpleClo -> [SimpleClo] -> [SimpleClo]
forall a. a -> [a] -> [a]
: [SimpleClo]
as)

simple_app SimpleOptEnv
env e :: OutExpr
e@(Lam {}) as :: [SimpleClo]
as@(SimpleClo
_:[SimpleClo]
_)
  = SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (OutExpr -> BranchCount -> OutExpr
zapLambdaBndrs OutExpr
e BranchCount
n_args) [SimpleClo]
as
    -- Be careful to zap the lambda binders if necessary
    -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify
    -- Lacking this zap caused #19347, when we had a redex
    --   (\ a b. K a b) e1 e2
    -- where (as it happens) the eta-expanded K is produced by
    -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head
  where
    n_args :: BranchCount
n_args = [SimpleClo] -> BranchCount
forall a. [a] -> BranchCount
forall (t :: * -> *) a. Foldable t => t a -> BranchCount
length [SimpleClo]
as

    do_beta :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (Lam Id
b OutExpr
body) (SimpleClo
a:[SimpleClo]
as)
      | -- simpl binder before looking at its type
        -- See Note [Dark corner with representation polymorphism]
        HasDebugCallStack => Type -> OutExpr -> Bool
Type -> OutExpr -> Bool
needsCaseBinding (Id -> Type
idType Id
b') (SimpleClo -> OutExpr
forall a b. (a, b) -> b
snd SimpleClo
a)
        -- This arg must not be inlined (side-effects) and cannot be let-bound,
        -- due to the let-can-float invariant. So simply case-bind it here.
      , let a' :: OutExpr
a' = HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr
InScopeSet -> SimpleClo -> OutExpr
simple_opt_clo (SimpleOptEnv -> InScopeSet
soeInScope SimpleOptEnv
env) SimpleClo
a
      = OutExpr -> Id -> OutExpr -> OutExpr
mkDefaultCase OutExpr
a' Id
b' (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env' OutExpr
body [SimpleClo]
as

      | (SimpleOptEnv
env'', Maybe (Id, OutExpr)
mb_pr) <- SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env' Id
b (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
b') SimpleClo
a TopLevelFlag
NotTopLevel
      = Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
mb_pr (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env'' OutExpr
body [SimpleClo]
as

      where (SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b

    do_beta SimpleOptEnv
env OutExpr
body [SimpleClo]
as
      = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
body [SimpleClo]
as

simple_app SimpleOptEnv
env (Tick CoreTickish
t OutExpr
e) [SimpleClo]
as
  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
  | CoreTickish
t CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
  = CoreTickish -> OutExpr -> OutExpr
mkTick CoreTickish
t (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as

-- (let x = e in b) a1 .. an  =>  let x = e in (b a1 .. an)
-- The let might appear there as a result of inlining
-- e.g.   let f = let x = e in b
--        in f a1 a2
--   (#13208)
-- However, do /not/ do this transformation for join points
--    See Note [simple_app and join points]
simple_app SimpleOptEnv
env (Let InBind
bind OutExpr
body) [SimpleClo]
args
  = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
      (SimpleOptEnv
env', Maybe InBind
Nothing)   -> HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args
      (SimpleOptEnv
env', Just InBind
bind')
        | InBind -> Bool
isJoinBind InBind
bind' -> HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
expr' [SimpleClo]
args
        | Bool
otherwise        -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args)
        where
          expr' :: OutExpr
expr' = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)

simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e) [SimpleClo]
as

finish_app :: HasDebugCallStack
           => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
-- See Note [Eliminate casts in function position]
finish_app :: HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (Cast (Lam Id
x OutExpr
e) Coercion
co) as :: [SimpleClo]
as@(SimpleClo
_:[SimpleClo]
_)
  | Bool -> Bool
not (Id -> Bool
isTyVar Id
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isCoVar Id
x)
  , Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id
x Id -> VarSet -> Bool
`elemVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co) Bool
True
  , Just (Id
x',OutExpr
e') <- HasDebugCallStack =>
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
pushCoercionIntoLambda (SimpleOptEnv -> InScopeSet
soeInScope SimpleOptEnv
env) Id
x OutExpr
e Coercion
co
  = HasDebugCallStack =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv
soeZapSubst SimpleOptEnv
env) (Id -> OutExpr -> OutExpr
forall b. b -> Expr b -> Expr b
Lam Id
x' OutExpr
e') [SimpleClo]
as

finish_app SimpleOptEnv
env OutExpr
fun [SimpleClo]
args
  = (OutExpr -> SimpleClo -> OutExpr)
-> OutExpr -> [SimpleClo] -> OutExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OutExpr -> SimpleClo -> OutExpr
mk_app OutExpr
fun [SimpleClo]
args
  where
    in_scope :: InScopeSet
in_scope = SimpleOptEnv -> InScopeSet
soeInScope SimpleOptEnv
env
    mk_app :: OutExpr -> SimpleClo -> OutExpr
mk_app OutExpr
fun SimpleClo
arg = OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App OutExpr
fun (HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr
InScopeSet -> SimpleClo -> OutExpr
simple_opt_clo InScopeSet
in_scope SimpleClo
arg)

----------------------
simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag
                -> (SimpleOptEnv, Maybe OutBind)
simple_opt_bind :: SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env (NonRec Id
b OutExpr
r) TopLevelFlag
top_level
  = (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
            Maybe (Id, OutExpr)
Nothing    -> Maybe InBind
forall a. Maybe a
Nothing
            Just (Id
b,OutExpr
r) -> InBind -> Maybe InBind
forall a. a -> Maybe a
Just (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r))
  where
    (Id
b', OutExpr
r') = Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
b OutExpr
r Maybe (Id, OutExpr) -> (Id, OutExpr) -> (Id, OutExpr)
forall a. Maybe a -> a -> a
`orElse` (Id
b, OutExpr
r)
    (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b' Maybe Id
forall a. Maybe a
Nothing (SimpleOptEnv
env,OutExpr
r') TopLevelFlag
top_level

simple_opt_bind SimpleOptEnv
env (Rec [(Id, OutExpr)]
prs) TopLevelFlag
top_level
  = (SimpleOptEnv
env2, Maybe InBind
res_bind)
  where
    res_bind :: Maybe InBind
res_bind          = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a]
reverse [(Id, OutExpr)]
rev_prs'))
    prs' :: [(Id, OutExpr)]
prs'              = [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
prs Maybe [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. Maybe a -> a -> a
`orElse` [(Id, OutExpr)]
prs
    (SimpleOptEnv
env1, [Id]
bndrs')    = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env (((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
prs')
    (SimpleOptEnv
env2, [(Id, OutExpr)]
rev_prs')  = SimpleOptEnv
-> [Id]
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env1 [Id]
bndrs' ((SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
 -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$ \SimpleOptEnv
env ->
                          ((SimpleOptEnv, [(Id, OutExpr)])
 -> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
-> [((Id, OutExpr), Id)]
-> (SimpleOptEnv, [(Id, OutExpr)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, []) ([(Id, OutExpr)]
prs' [(Id, OutExpr)] -> [Id] -> [((Id, OutExpr), Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs')
    do_pr :: (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, [(Id, OutExpr)]
prs) ((Id
b,OutExpr
r), Id
b')
       = (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
                  Just (Id, OutExpr)
pr -> (Id, OutExpr)
pr (Id, OutExpr) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. a -> [a] -> [a]
: [(Id, OutExpr)]
prs
                  Maybe (Id, OutExpr)
Nothing -> [(Id, OutExpr)]
prs)
       where
         (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
b') (SimpleOptEnv
env,OutExpr
r) TopLevelFlag
top_level

----------------------
simple_bind_pair :: SimpleOptEnv
                 -> InVar -> Maybe OutVar
                 -> SimpleClo
                 -> TopLevelFlag
                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
    -- (simple_bind_pair subst in_var out_rhs)
    --   either extends subst with (in_var -> out_rhs)
    --   or     returns Nothing
simple_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair env :: SimpleOptEnv
env@(SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl_env, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
                 Id
in_bndr Maybe Id
mb_out_bndr clo :: SimpleClo
clo@(SimpleOptEnv
rhs_env, OutExpr
in_rhs)
                 TopLevelFlag
top_level
  | Type Type
ty <- OutExpr
in_rhs        -- let a::* = TYPE ty in <body>
  , let out_ty :: Type
out_ty = Subst -> Type -> Type
substTyUnchecked (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env) Type
ty
  = Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
in_rhs) ((SimpleOptEnv, Maybe (Id, OutExpr))
 -> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a b. (a -> b) -> a -> b
$
    (SimpleOptEnv
env { soe_subst = extendTvSubst subst in_bndr out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Coercion Coercion
co <- OutExpr
in_rhs
  , let out_co :: Coercion
out_co = OptCoercionOpts -> Subst -> Coercion -> Coercion
optCoercion (SimpleOpts -> OptCoercionOpts
so_co_opts (SimpleOptEnv -> SimpleOpts
soe_opts SimpleOptEnv
env)) (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env) Coercion
co
  = Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
    (SimpleOptEnv
env { soe_subst = extendCvSubst subst in_bndr out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
    -- The previous two guards got rid of tyvars and coercions
    -- See Note [Core type and coercion invariant] in GHC.Core
    Bool
pre_inline_unconditionally
  = (SimpleOptEnv
env { soe_inl = extendVarEnv inl_env in_bndr clo }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Bool
otherwise
  = SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
                         OccInfo
occ Bool
active Bool
stable_unf TopLevelFlag
top_level
  where
    stable_unf :: Bool
stable_unf = Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding Id
in_bndr)
    active :: Bool
active     = Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
in_bndr)
    occ :: OccInfo
occ        = Id -> OccInfo
idOccInfo Id
in_bndr
    in_scope :: InScopeSet
in_scope   = Subst -> InScopeSet
getSubstInScope Subst
subst

    out_rhs :: OutExpr
out_rhs | JoinPoint BranchCount
join_arity <- Id -> JoinPointHood
idJoinPointHood Id
in_bndr
            = BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity
            | Bool
otherwise
            = HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr
InScopeSet -> SimpleClo -> OutExpr
simple_opt_clo InScopeSet
in_scope SimpleClo
clo

    simple_join_rhs :: BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity -- See Note [Preserve join-binding arity]
      = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
join_bndrs' (HasDebugCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env_body OutExpr
join_body)
      where
        env0 :: SimpleOptEnv
env0 = InScopeSet -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope InScopeSet
in_scope SimpleOptEnv
rhs_env
        ([Id]
join_bndrs, OutExpr
join_body) = BranchCount -> OutExpr -> ([Id], OutExpr)
forall b. BranchCount -> Expr b -> ([b], Expr b)
collectNBinders BranchCount
join_arity OutExpr
in_rhs
        (SimpleOptEnv
env_body, [Id]
join_bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env0 [Id]
join_bndrs

    pre_inline_unconditionally :: Bool
    pre_inline_unconditionally :: Bool
pre_inline_unconditionally
       | Id -> Bool
isExportedId Id
in_bndr     = Bool
False
       | Bool
stable_unf               = Bool
False
       | Bool -> Bool
not Bool
active               = Bool
False    -- Note [Inline prag in simplOpt]
       | Bool -> Bool
not (OccInfo -> Bool
safe_to_inline OccInfo
occ) = Bool
False
       | Bool
otherwise                = Bool
True

        -- Unconditionally safe to inline
safe_to_inline :: OccInfo -> Bool
safe_to_inline :: OccInfo -> Bool
safe_to_inline IAmALoopBreaker{}                  = Bool
False
safe_to_inline OccInfo
IAmDead                            = Bool
True
safe_to_inline OneOcc{ occ_in_lam :: OccInfo -> InsideLam
occ_in_lam = InsideLam
NotInsideLam
                     , occ_n_br :: OccInfo -> BranchCount
occ_n_br = BranchCount
1 }             = Bool
True
safe_to_inline OneOcc{}                           = Bool
False
safe_to_inline ManyOccs{}                         = Bool
False

do_beta_by_substitution :: Id -> CoreExpr -> Bool
-- True <=> you can inline (bndr = rhs) by substitution
-- See Note [Exploit occ-info in exprIsConApp_maybe]
do_beta_by_substitution :: Id -> OutExpr -> Bool
do_beta_by_substitution Id
bndr OutExpr
rhs
  = OutExpr -> Bool
exprIsTrivial OutExpr
rhs                   -- Can duplicate
    Bool -> Bool -> Bool
|| OccInfo -> Bool
safe_to_inline (Id -> OccInfo
idOccInfo Id
bndr)  -- Occurs at most once

do_case_elim :: CoreExpr -> Id -> [Id] -> Bool
do_case_elim :: OutExpr -> Id -> [Id] -> Bool
do_case_elim OutExpr
scrut Id
case_bndr [Id]
alt_bndrs
  =  OutExpr -> Bool
exprIsHNF OutExpr
scrut
  Bool -> Bool -> Bool
&& OccInfo -> Bool
safe_to_inline (Id -> OccInfo
idOccInfo Id
case_bndr)
  Bool -> Bool -> Bool
&& (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
alt_bndrs

-------------------
simple_out_bind :: TopLevelFlag
                -> SimpleOptEnv
                -> (InVar, OutExpr)
                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind :: TopLevelFlag
-> SimpleOptEnv
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Id
in_bndr, OutExpr
out_rhs)
  | Type Type
out_ty <- OutExpr
out_rhs
  = Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
out_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
out_rhs)
    (SimpleOptEnv
env { soe_subst = extendTvSubst subst in_bndr out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Coercion Coercion
out_co <- OutExpr
out_rhs
  = Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
    (SimpleOptEnv
env { soe_subst = extendCvSubst subst in_bndr out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Bool
otherwise
  = SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
forall a. Maybe a
Nothing OutExpr
out_rhs
                         (Id -> OccInfo
idOccInfo Id
in_bndr) Bool
True Bool
False TopLevelFlag
top_level

-------------------
simple_out_bind_pair :: SimpleOptEnv
                     -> InId -> Maybe OutId -> OutExpr
                     -> OccInfo -> Bool -> Bool -> TopLevelFlag
                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
                     OccInfo
occ_info Bool
active Bool
stable_unf TopLevelFlag
top_level
  | Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
    -- Type and coercion bindings are caught earlier
    -- See Note [Core type and coercion invariant]
    Bool
post_inline_unconditionally
  = ( SimpleOptEnv
env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
    , Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)

  | Bool
otherwise
  = ( SimpleOptEnv
env', (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
out_bndr, OutExpr
out_rhs) )
  where
    (SimpleOptEnv
env', Id
bndr1) = case Maybe Id
mb_out_bndr of
                      Just Id
out_bndr -> (SimpleOptEnv
env, Id
out_bndr)
                      Maybe Id
Nothing       -> SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
in_bndr
    out_bndr :: Id
out_bndr = SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env' Id
in_bndr TopLevelFlag
top_level OutExpr
out_rhs Id
bndr1

    post_inline_unconditionally :: Bool
    post_inline_unconditionally :: Bool
post_inline_unconditionally
       | Id -> Bool
isExportedId Id
in_bndr  = Bool
False -- Note [Exported Ids and trivial RHSs]
       | Bool
stable_unf            = Bool
False -- Note [Stable unfoldings and postInlineUnconditionally]
       | Bool -> Bool
not Bool
active            = Bool
False --     in GHC.Core.Opt.Simplify.Utils
       | Bool
is_loop_breaker       = Bool
False -- If it's a loop-breaker of any kind, don't inline
                                       -- because it might be referred to "earlier"
       | OutExpr -> Bool
exprIsTrivial OutExpr
out_rhs = Bool
True
       | Bool
coercible_hack        = Bool
True
       | Bool
otherwise             = Bool
False

    is_loop_breaker :: Bool
is_loop_breaker = OccInfo -> Bool
isWeakLoopBreaker OccInfo
occ_info

    -- See Note [Getting the map/coerce RULE to work]
    coercible_hack :: Bool
coercible_hack | (Var Id
fun, [OutExpr]
args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
out_rhs
                   , Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
                   , DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqDataConKey Bool -> Bool -> Bool
|| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleDataConKey
                   = (OutExpr -> Bool) -> [OutExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all OutExpr -> Bool
exprIsTrivial [OutExpr]
args
                   | Bool
otherwise
                   = Bool
False

{- Note [Exported Ids and trivial RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We obviously do not want to unconditionally inline an Id that is exported.
In GHC.Core.Opt.Simplify.Utils, Note [Top level and postInlineUnconditionally], we
explain why we don't inline /any/ top-level things unconditionally, even
trivial ones.  But we do here!  Why?  In the simple optimiser

  * We do no rule rewrites
  * We do no call-site inlining

Those differences obviate the reasons for not inlining a trivial rhs,
and increase the benefit for doing so.  So we unconditionally inline trivial
rhss here.

Note [Eliminate casts in function position]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following program:

  type R :: Type -> RuntimeRep
  type family R a where { R Float = FloatRep; R Double = DoubleRep }
  type F :: forall (a :: Type) -> TYPE (R a)
  type family F a where { F Float = Float#  ; F Double = Double# }

  type N :: forall (a :: Type) -> TYPE (R a)
  newtype N a = MkN (F a)

As MkN is a newtype, its unfolding is a lambda which wraps its argument
in a cast:

  MkN :: forall (a :: Type). F a -> N a
  MkN = /\a \(x::F a). x |> co_ax
    -- recall that F a :: TYPE (R a)

This is a representation-polymorphic lambda, in which the binder has an unknown
representation (R a). We can't compile such a lambda on its own, but we can
compile instantiations, such as `MkN @Float` or `MkN @Double`.

Our strategy to avoid running afoul of the representation-polymorphism
invariants of Note [Representation polymorphism invariants] in GHC.Core is thus:

  1. Give the newtype a compulsory unfolding (it has no binding, as we can't
     define lambdas with representation-polymorphic value binders in source Haskell).
  2. Rely on the optimiser to beta-reduce away any representation-polymorphic
     value binders.

For example, consider the application

    MkN @Float 34.0#

After inlining MkN we'll get

   ((/\a \(x:F a). x |> co_ax) @Float) |> co 34#

where co :: (F Float -> N Float) ~ (Float# ~ N Float)

But to actually beta-reduce that lambda, we need to push the 'co'
inside the `\x` with pushCoecionIntoLambda.  Hence the extra
equation for Cast-of-Lam in finish_app.

This is regrettably delicate.

Note [Preserve join-binding arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful /not/ to eta-reduce the RHS of a join point, lest we lose
the join-point arity invariant.  #15108 was caused by simplifying
the RHS with simple_opt_expr, which does eta-reduction.  Solution:
simplify the RHS of a join point by simplifying under the lambdas
(which of course should be there).

Note [simple_app and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general for let-bindings we can do this:
   (let { x = e } in b) a  ==>  let { x = e } in b a

But not for join points!  For two reasons:

- We would need to push the continuation into the RHS:
   (join { j = e } in b) a  ==>  let { j' = e a } in b[j'/j] a
                                      NB ----^^
  and also change the type of j, hence j'.
  That's a bit sophisticated for the very simple optimiser.

- We might end up with something like
    join { j' = e a } in
    (case blah of        )
    (  True  -> j' void# ) a
    (  False -> blah     )
  and now the call to j' doesn't look like a tail call, and
  Lint may reject.  I say "may" because this is /explicitly/
  allowed in the "Compiling without Continuations" paper
  (Section 3, "Managing \Delta").  But GHC currently does not
  allow this slightly-more-flexible form.  See GHC.Core
  Note [Join points are less general than the paper].

The simple thing to do is to disable this transformation
for join points in the simple optimiser

Note [The Let-Unfoldings Invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A program has the Let-Unfoldings property iff:

- For every let-bound variable f, whether top-level or nested, whether
  recursive or not:
  - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding.
  - For non-INLINE things, that unfolding will be f's right hand sids
  - For INLINE things (which have a "stable" unfolding) that unfolding is
    semantically equivalent to f's RHS, but derived from the original RHS of f
    rather that its current RHS.

Informally, we can say that in a program that has the Let-Unfoldings property,
all let-bound Id's have an explicit unfolding attached to them.

Currently, the simplifier guarantees the Let-Unfoldings invariant for anything
it outputs.

-}

----------------------
subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
subst_opt_bndrs :: SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs = (SimpleOptEnv -> Id -> (SimpleOptEnv, Id))
-> SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env [Id]
bndrs

subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
subst_opt_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
bndr
  | Id -> Bool
isTyVar Id
bndr  = (SimpleOptEnv
env { soe_subst = subst_tv }, Id
tv')
  | Id -> Bool
isCoVar Id
bndr  = (SimpleOptEnv
env { soe_subst = subst_cv }, Id
cv')
  | Bool
otherwise     = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_id_bndr SimpleOptEnv
env Id
bndr
  where
    subst :: Subst
subst           = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
    (Subst
subst_tv, Id
tv') = HasDebugCallStack => Subst -> Id -> (Subst, Id)
Subst -> Id -> (Subst, Id)
substTyVarBndr Subst
subst Id
bndr
    (Subst
subst_cv, Id
cv') = HasDebugCallStack => Subst -> Id -> (Subst, Id)
Subst -> Id -> (Subst, Id)
substCoVarBndr Subst
subst Id
bndr

subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by
-- add_info.
--
-- Rather like SimplEnv.substIdBndr
--
-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr
-- carefully does not do) because simplOptExpr invalidates it

subst_opt_id_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_id_bndr env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst, soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl }) Id
old_id
  = (SimpleOptEnv
env { soe_subst = new_subst, soe_inl = new_inl }, Id
new_id)
  where
    Subst InScopeSet
in_scope IdSubstEnv
id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst = Subst
subst

    id1 :: Id
id1    = InScopeSet -> Id -> Id
uniqAway InScopeSet
in_scope Id
old_id
    id2 :: Id
id2    = (Type -> Type) -> Id -> Id
updateIdTypeAndMult (Subst -> Type -> Type
substTyUnchecked Subst
subst) Id
id1
    new_id :: Id
new_id = Id -> Id
zapFragileIdInfo Id
id2
             -- Zaps rules, unfolding, and fragile OccInfo
             -- The unfolding and rules will get added back later, by add_info

    new_in_scope :: InScopeSet
new_in_scope = InScopeSet
in_scope InScopeSet -> Id -> InScopeSet
`extendInScopeSet` Id
new_id

    no_change :: Bool
no_change = Id
new_id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
old_id

        -- Extend the substitution if the unique has changed,
        -- See the notes with substTyVarBndr for the delSubstEnv
    new_id_subst :: IdSubstEnv
new_id_subst
      | Bool
no_change = IdSubstEnv -> Id -> IdSubstEnv
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdSubstEnv
id_subst Id
old_id
      | Bool
otherwise = IdSubstEnv -> Id -> OutExpr -> IdSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdSubstEnv
id_subst Id
old_id (Id -> OutExpr
forall b. Id -> Expr b
Var Id
new_id)

    new_subst :: Subst
new_subst = InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst
Subst InScopeSet
new_in_scope IdSubstEnv
new_id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst
    new_inl :: IdEnv SimpleClo
new_inl   = IdEnv SimpleClo -> Id -> IdEnv SimpleClo
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdEnv SimpleClo
inl Id
old_id

----------------------
add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env Id
old_bndr TopLevelFlag
top_level OutExpr
new_rhs Id
new_bndr
 | Id -> Bool
isTyVar Id
old_bndr = Id
new_bndr
 | Bool
otherwise        = Id -> IdInfo -> Id
lazySetIdInfo Id
new_bndr IdInfo
new_info
 where
   subst :: Subst
subst    = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
   uf_opts :: UnfoldingOpts
uf_opts  = SimpleOpts -> UnfoldingOpts
so_uf_opts (SimpleOptEnv -> SimpleOpts
soe_opts SimpleOptEnv
env)
   old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr

   -- Add back in the rules and unfolding which were
   -- removed by zapFragileIdInfo in subst_opt_id_bndr.
   --
   -- See Note [The Let-Unfoldings Invariant]
   new_info :: IdInfo
new_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
new_bndr IdInfo -> RuleInfo -> IdInfo
`setRuleInfo`      RuleInfo
new_rules
                              IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unfolding

   old_rules :: RuleInfo
old_rules = IdInfo -> RuleInfo
ruleInfo IdInfo
old_info
   new_rules :: RuleInfo
new_rules = Subst -> Id -> RuleInfo -> RuleInfo
substRuleInfo Subst
subst Id
new_bndr RuleInfo
old_rules

   old_unfolding :: Unfolding
old_unfolding = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
   new_unfolding :: Unfolding
new_unfolding | Unfolding -> Bool
isStableUnfolding Unfolding
old_unfolding
                 = Subst -> Unfolding -> Unfolding
substUnfolding Subst
subst Unfolding
old_unfolding
                 | Bool
otherwise
                 = Unfolding
unfolding_from_rhs

   unfolding_from_rhs :: Unfolding
unfolding_from_rhs = UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> Bool
-> OutExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
VanillaSrc
                                    (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
                                    Bool
False -- may be bottom or not
                                    Bool
False -- Not a join point
                                    OutExpr
new_rhs Maybe UnfoldingCache
forall a. Maybe a
Nothing

wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet :: Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
Nothing      OutExpr
body = OutExpr
body
wrapLet (Just (Id
b,OutExpr
r)) OutExpr
body = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r) OutExpr
body

{-
Note [Inline prag in simplOpt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If there's an INLINE/NOINLINE pragma that restricts the phase in
which the binder can be inlined, we don't inline here; after all,
we don't know what phase we're in.  Here's an example

  foo :: Int -> Int -> Int
  {-# INLINE foo #-}
  foo m n = inner m
     where
       {-# INLINE [1] inner #-}
       inner m = m+n

  bar :: Int -> Int
  bar n = foo n 1

When inlining 'foo' in 'bar' we want the let-binding for 'inner'
to remain visible until Phase 1

Note [Unfold compulsory unfoldings in RULE LHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the user writes `RULES map coerce = coerce` as a rule, the rule
will only ever match if simpleOptExpr replaces coerce by its unfolding
on the LHS, because that is the core that the rule matching engine
will find. So do that for everything that has a compulsory
unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore.

However, we don't want to inline 'seq', which happens to also have a
compulsory unfolding, so we only do this unfolding only for things
that are always-active.  See Note [User-defined RULES for seq] in GHC.Types.Id.Make.

Note [Getting the map/coerce RULE to work]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We wish to allow the "map/coerce" RULE to fire:

  {-# RULES "map/coerce" map coerce = coerce #-}

The naive core produced for this is

  forall a b (dict :: Coercible * a b).
    map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'

  where dict' :: Coercible [a] [b]
        dict' = ...

This matches literal uses of `map coerce` in code, but that's not what we
want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
too.  Achieving all this is surprisingly tricky:

(MC1) We must compulsorily unfold MkAge to a cast.
      See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make

(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding
        forall a b (dict :: Coercible * a b).
          map @a @b (\(x :: a) -> case dict of
            MkCoercible (co :: a ~R# b) -> x |> co) = ...

  Getting better. But this isn't exactly what gets produced. This is because
  Coercible essentially has ~R# as a superclass, and superclasses get eagerly
  extracted during solving. So we get this:

    forall a b (dict :: Coercible * a b).
      case Coercible_SCSel @* @a @b dict of
        _ [Dead] -> map @a @b (\(x :: a) -> case dict of
                                 MkCoercible (co :: a ~R# b) -> x |> co) = ...

  Unfortunately, this still abstracts over a Coercible dictionary. We really
  want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
  which transforms the above to
  Desugar)

    forall a b (co :: a ~R# b).
      let dict = MkCoercible @* @a @b co in
      case Coercible_SCSel @* @a @b dict of
        _ [Dead] -> map @a @b (\(x :: a) -> case dict of
           MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...

  See Note [Desugaring coerce as cast] in GHC.HsToCore

(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three
  separate actions:
  1. Inline certain non-recursive bindings. The choice whether to inline
     is made in simple_bind_pair. Note the rather specific check for
     MkCoercible in there.

  2. Stripping case expressions like the Coercible_SCSel one.
     See the `Case` case of simple_opt_expr's `go` function.

  3. Look for case expressions that unpack something that was
     just packed and inline them. This is also done in simple_opt_expr's
     `go` function.

(MC4) The map/coerce rule is the only compelling reason for having a RULE that
  quantifies over a coercion variable, something that is otherwise Very Deeply
  Suspicous.  See Note [Casts in the template] in GHC.Core.Rules. Ugh!

This is all a fair amount of special-purpose hackery, but it's for
a good cause. And it won't hurt other RULES and such that it comes across.


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

{- Note [Strictness and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have

   let f = \x.  if x>200 then e1 else e1

and we know that f is strict in x.  Then if we subsequently
discover that f is an arity-2 join point, we'll eta-expand it to

   let f = \x y.  if x>200 then e1 else e1

and now it's only strict if applied to two arguments.  So we should
adjust the strictness info.

A more common case is when

   f = \x. error ".."

and again its arity increases (#15517)
-}


-- | Returns Just (bndr,rhs) if the binding is a join point:
-- If it's a JoinId, just return it
-- If it's not yet a JoinId but is always tail-called,
--    make it into a JoinId and return it.
-- In the latter case, eta-expand the RHS if necessary, to make the
-- lambdas explicit, as is required for join points
--
-- Precondition: the InBndr has been occurrence-analysed,
--               so its OccInfo is valid
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe :: Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
bndr OutExpr
rhs
  | Bool -> Bool
not (Id -> Bool
isId Id
bndr)
  = Maybe (Id, OutExpr)
forall a. Maybe a
Nothing

  | Id -> Bool
isJoinId Id
bndr
  = (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
bndr, OutExpr
rhs)

  | AlwaysTailCalled BranchCount
join_arity <- OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
  , ([Id]
bndrs, OutExpr
body) <- BranchCount -> OutExpr -> ([Id], OutExpr)
etaExpandToJoinPoint BranchCount
join_arity OutExpr
rhs
  , let str_sig :: DmdSig
str_sig   = Id -> DmdSig
idDmdSig Id
bndr
        str_arity :: BranchCount
str_arity = (Id -> Bool) -> [Id] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count Id -> Bool
isId [Id]
bndrs  -- Strictness demands are for Ids only
        join_bndr :: Id
join_bndr = Id
bndr Id -> BranchCount -> Id
`asJoinId`        BranchCount
join_arity
                         Id -> DmdSig -> Id
`setIdDmdSig` BranchCount -> DmdSig -> DmdSig
etaConvertDmdSig BranchCount
str_arity DmdSig
str_sig
  = (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
join_bndr, [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs OutExpr
body)

  | Bool
otherwise
  = Maybe (Id, OutExpr)
forall a. Maybe a
Nothing

joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe :: [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
bndrs
  = ((Id, OutExpr) -> Maybe (Id, OutExpr))
-> [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Id -> OutExpr -> Maybe (Id, OutExpr))
-> (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe) [(Id, OutExpr)]
bndrs


{- *********************************************************************
*                                                                      *
         exprIsConApp_maybe
*                                                                      *
************************************************************************

Note [exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~
exprIsConApp_maybe is a very important function.  There are two principal
uses:
  * case e of { .... }
  * cls_op e, where cls_op is a class operation

In both cases you want to know if e is of form (C e1..en) where C is
a data constructor.

However e might not *look* as if


Note [exprIsConApp_maybe on literal strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #9400 and #13317.

Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or
unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.

For optimizations we want to be able to treat it as a list, so they can be
decomposed when used in a case-statement. exprIsConApp_maybe detects those
calls to unpackCString# and returns:

Just (':', [Char], ['a', unpackCString# "bc"]).

We need to be careful about UTF8 strings here. ""# contains an encoded ByteString, so
we call utf8UnconsByteString to correctly deal with the encoding and splitting.

We must also be careful about
   lvl = "foo"#
   ...(unpackCString# lvl)...
to ensure that we see through the let-binding for 'lvl'.  Hence the
(exprIsLiteral_maybe .. arg) in the guard before the call to
dealWithStringLiteral.

The tests for this function are in T9400.

Note [Push coercions in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In #13025 I found a case where we had
    op (df @t1 @t2)     -- op is a ClassOp
where
    df = (/\a b. K e1 e2) |> g

To get this to come out we need to simplify on the fly
   ((/\a b. K e1 e2) |> g) @t1 @t2

Hence the use of pushCoArgs.

Note [exprIsConApp_maybe on data constructors with wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Problem:
- some data constructors have wrappers
- these wrappers inline late (see MkId Note [Activation for data constructor wrappers])
- but we still want case-of-known-constructor to fire early.

Example:
   data T = MkT !Int
   $WMkT n = case n of n' -> MkT n'   -- Wrapper for MkT
   foo x = case $WMkT e of MkT y -> blah

Here we want the case-of-known-constructor transformation to fire, giving
   foo x = case e of x' -> let y = x' in blah

Here's how exprIsConApp_maybe achieves this:

0.  Start with scrutinee = $WMkT e

1.  Inline $WMkT on-the-fly.  That's why data-constructor wrappers are marked
    as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have
      scrutinee = (\n. case n of n' -> MkT n') e

2.  Beta-reduce the application, generating a floated 'let'.
    See Note [beta-reduction in exprIsConApp_maybe] below.  Now we have
      scrutinee = case n of n' -> MkT n'
      with floats {Let n = e}

3.  Float the "case x of x' ->" binding out.  Now we have
      scrutinee = MkT n'
      with floats {Let n = e; case n of n' ->}

And now we have a known-constructor MkT that we can return.

Notice that both (2) and (3) require exprIsConApp_maybe to gather and return
a bunch of floats, both let and case bindings.

Note that this strategy introduces some subtle scenarios where a data-con
wrapper can be replaced by a data-con worker earlier than we’d like, see
Note [exprIsConApp_maybe for data-con wrappers: tricky corner].

Note [beta-reduction in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is
typically a function. For instance, take the wrapper for MkT in Note
[exprIsConApp_maybe on data constructors with wrappers]:

    $WMkT n = case n of { n' -> T n' }

If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT,
it will see

   (\n -> case n of { n' -> T n' }) arg

In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction.

We don't want to blindly substitute `arg` in the body of the function, because
it duplicates work. We can (and, in fact, used to) substitute `arg` in the body,
but only when `arg` is a variable (or something equally work-free).

But, because of Note [exprIsConApp_maybe on data constructors with wrappers],
'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce
_always_:

    (\x -> body) arg

Is transformed into

   let x = arg in body

Which, effectively, means emitting a float `let x = arg` and recursively
analysing the body.

For newtypes, this strategy requires that their wrappers have compulsory unfoldings.
Suppose we have
   newtype T a b where
     MkT :: a -> T b a   -- Note args swapped

This defines a worker function MkT, a wrapper function $WMkT, and an axT:
   $WMkT :: forall a b. a -> T b a
   $WMkT = /\b a. \(x:a). MkT a b x    -- A real binding

   MkT :: forall a b. a -> T a b
   MkT = /\a b. \(x:a). x |> (ax a b)  -- A compulsory unfolding

   axiom axT :: a ~R# T a b

Now we are optimising
   case $WMkT (I# 3) |> sym axT of I# y -> ...
we clearly want to simplify this. If $WMkT did not have a compulsory
unfolding, we would end up with
   let a = I# 3 in case a of I# y -> ...
because in general, we do this on-the-fly beta-reduction
   (\x. e) blah  -->  let x = blah in e
and then float the let.  (Substitution would risk duplicating 'blah'.)

But if the case-of-known-constructor doesn't actually fire (i.e.
exprIsConApp_maybe does not return Just) then nothing happens, and nothing
will happen the next time either.

See test T16254, which checks the behavior of newtypes.

Note [Exploit occ-info in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (#23159) we have a simple data constructor wrapper like this (this one
might have come from a data family instance):
   $WK x y = K x y |> co
Now suppose the simplifier sees
   case ($WK e1 e2) |> co2 of
      K p q ->  case q of ...

`exprIsConApp_maybe` expands the wrapper on the fly
(see Note [beta-reduction in exprIsConApp_maybe]). It effectively expands
that ($WK e1 e2) to
   let x = e1; y = e2 in K x y |> co

So the Simplifier might end up producing this:
   let x = e1; y = e2
   in case x of ...

But suppose `q` was used just once in the body of the `K p q` alternative; we
don't want to wait a whole Simplifier iteration to inline that `x`.  (e1 might
be another constructor for example.)  This would happen if `exprIsConApp_maybe`
we created a let for every (non-trivial) argument.  So let's not do that when
the binder is used just once!

Instead, take advantage of the occurrence-info on `x` and `y` in the unfolding
of `$WK`.  Since in `$WK` both `x` and `y` occur once, we want to effectively
expand `($WK e1 e2)` to `(K e1 e2 |> co)`.  Hence in
`do_beta_by_substitution` we say "yes" if

  (a) the RHS is trivial (so we can duplicate it);
      see call to `exprIsTrivial`
or
  (b) the binder occurs at most once (so there is no worry about duplication);
      see call to `safe_to_inline`.

To see this in action, look at testsuite/tests/perf/compiler/T15703.  The
initial Simlifier run takes 5 iterations without (b), but only 3 when we add
(b).

Note [Don't float join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
exprIsConApp_maybe should succeed on
   let v = e in Just v
returning [x=e] as one of the [FloatBind].  But it must
NOT succeed on
   join j x = rhs in Just v
because join-points can't be gaily floated.  Consider
   case (join j x = rhs in Just) of
     K p q -> blah
We absolutely must not "simplify" this to
   join j x = rhs
   in blah
because j's return type is (Maybe t), quite different to blah's.

You might think this could never happen, because j can't be
tail-called in the body if the body returns a constructor.  But
in !3113 we had a /dead/ join point (which is not illegal),
and its return type was wonky.

The simple thing is not to float a join point.  The next iteration
of the simplifier will sort everything out.  And it there is
a join point, the chances are that the body is not a constructor
application, so failing faster is good.

Note [exprIsConApp_maybe for data-con wrappers: tricky corner]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking

  * exprIsConApp_maybe honours the inline phase; that is, it does not look
    inside the unfolding for an Id unless its unfolding is active in this phase.
    That phase-sensitivity is expressed in the InScopeEnv (specifically, the
    IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe.

  * Data-constructor wrappers are active only in phase 0 (the last phase);
    see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make.

On the face of it that means that exprIsConApp_maybe won't look inside data
constructor wrappers until phase 0. But that seems pretty Bad. So we cheat.
For data con wrappers we unconditionally look inside its unfolding, regardless
of phase, so that we get case-of-known-constructor to fire in every phase.

Perhaps unsurprisingly, this cheating can backfire. An example:

    data T = C !A B
    foo p q = let x = C e1 e2 in seq x $ f x
    {-# RULE "wurble" f (C a b) = b #-}

In Core, the RHS of foo is

    let x = $WC e1 e2 in case x of y { C _ _ -> f x }

and after doing a binder swap and inlining x, we have:

    case $WC e1 e2 of y { C _ _ -> f y }

Case-of-known-constructor fires, but now we have to reconstruct a binding for
`y` (which was dead before the binder swap) on the RHS of the case alternative.
Naturally, we’ll use the worker:

    case e1 of a { DEFAULT -> let y = C a e2 in f y }

and after inlining `y`, we have:

    case e1 of a { DEFAULT -> f (C a e2) }

Now we might hope the "wurble" rule would fire, but alas, it will not: we have
replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t
supposed to inline $WC yet for precisely that reason (see Note [Activation for
data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to
bite us.

This is rather unfortunate, especially since this can happen inside stable
unfoldings as well as ordinary code (which really happened, see !3041). But
there is no obvious solution except to delay case-of-known-constructor on
data-con wrappers, and that cure would be worse than the disease.

This Note exists solely to document the problem.
-}

data ConCont = CC [CoreExpr] MCoercion
                  -- Substitution already applied

-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument
-- expression is a *saturated* constructor application of the form @let b1 in
-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the
-- *universally-quantified* type args of 'dc'. Floats can also be (and most
-- likely are) single-alternative case expressions. Why does
-- 'exprIsConApp_maybe' return floats? We may have to look through lets and
-- cases to detect that we are in the presence of a data constructor wrapper. In
-- this case, we need to return the lets and cases that we traversed. See Note
-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers
-- are unfolded late, but we really want to trigger case-of-known-constructor as
-- early as possible. See also Note [Activation for data constructor wrappers]
-- in "GHC.Types.Id.Make".
--
-- We also return the incoming InScopeSet, augmented with
-- the binders from any [FloatBind] that we return
exprIsConApp_maybe :: HasDebugCallStack
                   => InScopeEnv -> CoreExpr
                   -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: HasDebugCallStack =>
InScopeEnv
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe ise :: InScopeEnv
ise@(ISE InScopeSet
in_scope IdUnfoldingFun
id_unf) OutExpr
expr
  = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [] OutExpr
expr ([OutExpr] -> MCoercion -> ConCont
CC [] MCoercion
MRefl)
  where
    go :: Either InScopeSet Subst
             -- Left in-scope  means "empty substitution"
             -- Right subst    means "apply this substitution to the CoreExpr"
             -- NB: in the call (go subst floats expr cont)
             --     the substitution applies to 'expr', but /not/ to 'floats' or 'cont'
       -> [FloatBind] -> CoreExpr -> ConCont
             -- Notice that the floats here are in reverse order
       -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    go :: Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick CoreTickish
t OutExpr
expr) ConCont
cont
       | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ConCont
cont

    go Either InScopeSet Subst
subst [FloatBind]
floats (Cast OutExpr
expr Coercion
co1) (CC [OutExpr]
args MCoercion
m_co2)
       | Just ([OutExpr]
args', MCoercion
m_co1') <- Coercion -> [OutExpr] -> Maybe ([OutExpr], MCoercion)
pushCoArgs (Either InScopeSet Subst -> Coercion -> Coercion
forall {a}. Either a Subst -> Coercion -> Coercion
subst_co Either InScopeSet Subst
subst Coercion
co1) [OutExpr]
args
            -- See Note [Push coercions in exprIsConApp_maybe]
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ([OutExpr] -> MCoercion -> ConCont
CC [OutExpr]
args' (MCoercion
m_co1' MCoercion -> MCoercion -> MCoercion
`mkTransMCo` MCoercion
m_co2))

    go Either InScopeSet Subst
subst [FloatBind]
floats (App OutExpr
fun OutExpr
arg) (CC [OutExpr]
args MCoercion
mco)
       | let arg_type :: Type
arg_type = HasDebugCallStack => OutExpr -> Type
OutExpr -> Type
exprType OutExpr
arg
       , Bool -> Bool
not (OutExpr -> Bool
forall b. Expr b -> Bool
isTypeArg OutExpr
arg) Bool -> Bool -> Bool
&& HasDebugCallStack => Type -> OutExpr -> Bool
Type -> OutExpr -> Bool
needsCaseBinding Type
arg_type OutExpr
arg
       -- An unlifted argument that’s not ok for speculation must not simply be
       -- put into the args, as these are going to be substituted into the case
       -- alternatives, and possibly lost on the way.
       --
       -- Instead, we need need to
       -- make sure they are evaluated right here (using a case float), and
       -- the case binder can then be substituted into the case alternaties.
       --
       -- Example:
       -- Simplifying  case Mk# exp of Mk# a → rhs
       -- will use     exprIsConApp_maybe (Mk# exp)
       --
       -- Bad:  returning (Mk#, [exp]) with no floats
       --       simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec
       -- Good: returning (Mk#, [x]) with a float of  case exp of x { DEFAULT -> [] }
       --       simplifier produces case exp of a { DEFAULT -> exp[x/a] }
       = let arg' :: OutExpr
arg' = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
arg
             bndr :: Id
bndr = InScopeSet -> Id -> Id
uniqAway (Either InScopeSet Subst -> InScopeSet
subst_in_scope Either InScopeSet Subst
subst) (Type -> Type -> Id
mkWildValBinder Type
ManyTy Type
arg_type)
             float :: FloatBind
float = OutExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase OutExpr
arg' Id
bndr AltCon
DEFAULT []
             subst' :: Either InScopeSet Subst
subst' = Either InScopeSet Subst -> Id -> Either InScopeSet Subst
subst_extend_in_scope Either InScopeSet Subst
subst Id
bndr
         in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
fun ([OutExpr] -> MCoercion -> ConCont
CC (Id -> OutExpr
forall b. Id -> Expr b
Var Id
bndr OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [OutExpr]
args) MCoercion
mco)
       | Bool
otherwise
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
fun ([OutExpr] -> MCoercion -> ConCont
CC (Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
arg OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [OutExpr]
args) MCoercion
mco)

    go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Id
bndr OutExpr
body) (CC (OutExpr
arg:[OutExpr]
args) MCoercion
mco)
       | Id -> OutExpr -> Bool
do_beta_by_substitution Id
bndr OutExpr
arg
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (Either InScopeSet Subst -> Id -> OutExpr -> Either InScopeSet Subst
forall {a}.
Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
bndr OutExpr
arg) [FloatBind]
floats OutExpr
body ([OutExpr] -> MCoercion -> ConCont
CC [OutExpr]
args MCoercion
mco)
       | Bool
otherwise
       = let (Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
             float :: FloatBind
float           = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
arg)
         in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
body ([OutExpr] -> MCoercion -> ConCont
CC [OutExpr]
args MCoercion
mco)

    go Either InScopeSet Subst
subst [FloatBind]
floats (Let (NonRec Id
bndr OutExpr
rhs) OutExpr
expr) ConCont
cont
       | Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
         -- Crucial guard! See Note [Don't float join points]
       = let rhs' :: OutExpr
rhs'            = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
rhs
             (Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
             float :: FloatBind
float           = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
rhs')
         in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont

    go Either InScopeSet Subst
subst [FloatBind]
floats (Case OutExpr
scrut Id
b Type
_ [Alt AltCon
con [Id]
vars OutExpr
expr]) ConCont
cont
       | OutExpr -> Id -> [Id] -> Bool
do_case_elim OutExpr
scrut' Id
b [Id]
vars  -- See Note [Case elim in exprIsConApp_maybe]
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (Either InScopeSet Subst -> Id -> OutExpr -> Either InScopeSet Subst
forall {a}.
Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
b OutExpr
scrut') [FloatBind]
floats OutExpr
expr ConCont
cont
       | Bool
otherwise
       = let
          (Either InScopeSet Subst
subst', Id
b')     = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
b
          (Either InScopeSet Subst
subst'', [Id]
vars') = Either InScopeSet Subst -> [Id] -> (Either InScopeSet Subst, [Id])
forall {t :: * -> *}.
Traversable t =>
Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst' [Id]
vars
          float :: FloatBind
float            = OutExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase OutExpr
scrut' Id
b' AltCon
con [Id]
vars'
         in
           Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont
       where
          scrut' :: OutExpr
scrut'           = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
scrut

    go (Right Subst
sub) [FloatBind]
floats (Var Id
v) ConCont
cont
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
getSubstInScope Subst
sub))
            [FloatBind]
floats
            (HasDebugCallStack => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst Subst
sub Id
v)
            ConCont
cont

    go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Id
fun) cont :: ConCont
cont@(CC [OutExpr]
args MCoercion
mco)

        | Just DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
        , (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
args BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> BranchCount
idArity Id
fun
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          DataCon
-> [OutExpr] -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con [OutExpr]
args MCoercion
mco

        -- Look through data constructor wrappers: they inline late (See Note
        -- [Activation for data constructor wrappers]) but we want to do
        -- case-of-known-constructor optimisation eagerly (see Note
        -- [exprIsConApp_maybe on data constructors with wrappers]).
        | Id -> Bool
isDataConWrapId Id
fun
        , let rhs :: OutExpr
rhs = Unfolding -> OutExpr
uf_tmpl (IdUnfoldingFun
realIdUnfolding Id
fun)
        = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats OutExpr
rhs ConCont
cont

        -- Look through dictionary functions; see Note [Unfolding DFuns]
        | DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [OutExpr]
df_args = [OutExpr]
dfun_args } <- Unfolding
unfolding
        , [Id]
bndrs [Id] -> [OutExpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [OutExpr]
args    -- See Note [DFun arity check]
        , let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope ([OutExpr] -> VarSet
exprsFreeVars [OutExpr]
dfun_args)
              subst :: Subst
subst = InScopeSet -> [(Id, OutExpr)] -> Subst
mkOpenSubst InScopeSet
in_scope' ([Id]
bndrs [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
args)
              -- We extend the in-scope set here to silence warnings from
              -- substExpr when it finds not-in-scope Ids in dfun_args.
              -- simplOptExpr initialises the in-scope set with exprFreeVars,
              -- but that doesn't account for DFun unfoldings
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          DataCon
-> [OutExpr] -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con ((OutExpr -> OutExpr) -> [OutExpr] -> [OutExpr]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
subst) [OutExpr]
dfun_args) MCoercion
mco

        -- Look through unfoldings, but only arity-zero one;
        -- if arity > 0 we are effectively inlining a function call,
        -- and that is the business of callSiteInline.
        -- In practice, without this test, most of the "hits" were
        -- CPR'd workers getting inlined back into their wrappers,
        | Id -> BranchCount
idArity Id
fun BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== BranchCount
0
        , Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe Unfolding
unfolding
        , let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope (OutExpr -> VarSet
exprFreeVars OutExpr
rhs)
        = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats OutExpr
rhs ConCont
cont

        -- See Note [exprIsConApp_maybe on literal strings]
        | (Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey) Bool -> Bool -> Bool
||
          (Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringUtf8IdKey)
        , [OutExpr
arg]              <- [OutExpr]
args
        , Just (LitString ByteString
str) <- InScopeEnv -> OutExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
ise OutExpr
arg
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          Id -> ByteString -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str MCoercion
mco
        where
          unfolding :: Unfolding
unfolding = IdUnfoldingFun
id_unf Id
fun
          extend_in_scope :: VarSet -> InScopeSet
extend_in_scope VarSet
unf_fvs
            | Id -> Bool
isLocalId Id
fun = InScopeSet
in_scope InScopeSet -> VarSet -> InScopeSet
`extendInScopeSetSet` VarSet
unf_fvs
            | Bool
otherwise     = InScopeSet
in_scope
            -- A GlobalId has no (LocalId) free variables; and the
            -- in-scope set tracks only LocalIds

    go Either InScopeSet Subst
_ [FloatBind]
_ OutExpr
_ ConCont
_ = Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a. Maybe a
Nothing

    succeedWith :: InScopeSet -> [FloatBind]
                -> Maybe (DataCon, [Type], [CoreExpr])
                -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    succeedWith :: InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
rev_floats Maybe (DataCon, [Type], [OutExpr])
x
      = do { (con, tys, args) <- Maybe (DataCon, [Type], [OutExpr])
x
           ; let floats = [FloatBind] -> [FloatBind]
forall a. [a] -> [a]
reverse [FloatBind]
rev_floats
           ; return (in_scope, floats, con, tys, args) }

    ----------------------------
    -- Operations on the (Either InScopeSet GHC.Core.Subst)
    -- The Left case is wildly dominant

    subst_in_scope :: Either InScopeSet Subst -> InScopeSet
subst_in_scope (Left InScopeSet
in_scope) = InScopeSet
in_scope
    subst_in_scope (Right Subst
s) = Subst -> InScopeSet
getSubstInScope Subst
s

    subst_extend_in_scope :: Either InScopeSet Subst -> Id -> Either InScopeSet Subst
subst_extend_in_scope (Left InScopeSet
in_scope) Id
v = InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (InScopeSet
in_scope InScopeSet -> Id -> InScopeSet
`extendInScopeSet` Id
v)
    subst_extend_in_scope (Right Subst
s) Id
v = Subst -> Either InScopeSet Subst
forall a b. b -> Either a b
Right (Subst
s Subst -> Id -> Subst
`extendSubstInScope` Id
v)

    subst_co :: Either a Subst -> Coercion -> Coercion
subst_co (Left {}) Coercion
co = Coercion
co
    subst_co (Right Subst
s) Coercion
co = HasDebugCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
GHC.Core.Subst.substCo Subst
s Coercion
co

    subst_expr :: Either a Subst -> OutExpr -> OutExpr
subst_expr (Left {}) OutExpr
e = OutExpr
e
    subst_expr (Right Subst
s) OutExpr
e = HasDebugCallStack => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
s OutExpr
e

    subst_bndr :: Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
msubst Id
bndr
      = (Subst -> Either a Subst
forall a b. b -> Either a b
Right Subst
subst', Id
bndr')
      where
        (Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr Subst
subst Id
bndr
        subst :: Subst
subst = case Either InScopeSet Subst
msubst of
                  Left InScopeSet
in_scope -> InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
                  Right Subst
subst   -> Subst
subst

    subst_bndrs :: Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst t Id
bs = (Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id))
-> Either InScopeSet Subst
-> t Id
-> (Either InScopeSet Subst, t Id)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst t Id
bs

    extend :: Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend (Left InScopeSet
in_scope) Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Id
v OutExpr
e)
    extend (Right Subst
s)       Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst Subst
s Id
v OutExpr
e)


-- See Note [exprIsConApp_maybe on literal strings]
dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion
                      -> Maybe (DataCon, [Type], [CoreExpr])

-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS
-- turns those into [] automatically, but just in case something else in GHC
-- generates a string literal directly.
dealWithStringLiteral :: Id -> ByteString -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str MCoercion
mco =
  case ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString ByteString
str of
    Maybe (Char, ByteString)
Nothing -> DataCon
-> [OutExpr] -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy] MCoercion
mco
    Just (Char
char, ByteString
charTail) ->
      let char_expr :: OutExpr
char_expr = DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> OutExpr
forall b. Char -> Expr b
mkCharLit Char
char]
          -- In singleton strings, just add [] instead of unpackCstring# ""#.
          rest :: OutExpr
rest = if ByteString -> Bool
BS.null ByteString
charTail
                   then DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy]
                   else OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> OutExpr
forall b. Id -> Expr b
Var Id
fun)
                            (Literal -> OutExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))

      in DataCon
-> [OutExpr] -> MCoercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
consDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy, OutExpr
char_expr, OutExpr
rest] MCoercion
mco

{-
Note [Case elim in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
   data K a = MkK !a

   $WMkK x = case x of y -> K y   -- Wrapper for MkK

   ...case $WMkK v of K w -> <rhs>

We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper
and beta-reduce, so we get to
   exprIsConApp_maybe (case v of y -> K y)

So we may float the case, and end up with
   case v of y -> <rhs>[y/w]

But if `v` is already evaluated, the next run of the Simplifier will
eliminate the case, and we may then make more progress with <rhs>.
Better to do it in one iteration.  Hence the `do_case_elim`
check in `exprIsConApp_maybe`.

Note [Unfolding DFuns]
~~~~~~~~~~~~~~~~~~~~~~
DFuns look like

  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
                               ($c2 a b d_a d_b)

So to split it up we just need to apply the ops $c1, $c2 etc
to the very same args as the dfun.  It takes a little more work
to compute the type arguments to the dictionary constructor.

Note [DFun arity check]
~~~~~~~~~~~~~~~~~~~~~~~
Here we check that the total number of supplied arguments (including
type args) matches what the dfun is expecting.  This may be *less*
than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core
-}

exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Same deal as exprIsConApp_maybe, but much simpler
-- Nevertheless we do need to look through unfoldings for
-- string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
exprIsLiteral_maybe :: InScopeEnv -> OutExpr -> Maybe Literal
exprIsLiteral_maybe env :: InScopeEnv
env@(ISE InScopeSet
_ IdUnfoldingFun
id_unf) OutExpr
e
  = case OutExpr
e of
      Lit Literal
l     -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
      Tick CoreTickish
_ OutExpr
e' -> InScopeEnv -> OutExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env OutExpr
e' -- dubious?
      Var Id
v     -> Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
                    Maybe OutExpr -> (OutExpr -> Maybe Literal) -> Maybe Literal
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InScopeEnv -> OutExpr -> Maybe Literal
exprIsLiteral_maybe InScopeEnv
env
      OutExpr
_         -> Maybe Literal
forall a. Maybe a
Nothing

{-
Note [exprIsLambda_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~
exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
casts (using the Push rule), and it unfolds function calls if the unfolding
has a greater arity than arguments are present.

Currently, it is used in GHC.Core.Rules.match, and is required to make
"map coerce = coerce" match.
-}

exprIsLambda_maybe :: HasDebugCallStack
                   => InScopeEnv -> CoreExpr
                   -> Maybe (Var, CoreExpr,[CoreTickish])
    -- See Note [exprIsLambda_maybe]

-- The simple case: It is a lambda already
exprIsLambda_maybe :: HasDebugCallStack =>
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe InScopeEnv
_ (Lam Id
x OutExpr
e)
    = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, [])

-- Still straightforward: Ticks that we can float out of the way
exprIsLambda_maybe InScopeEnv
ise (Tick CoreTickish
t OutExpr
e)
    | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
    , Just (Id
x, OutExpr
e, [CoreTickish]
ts) <- HasDebugCallStack =>
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe InScopeEnv
ise OutExpr
e
    = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts)

-- Also possible: A casted lambda. Push the coercion inside
exprIsLambda_maybe ise :: InScopeEnv
ise@(ISE InScopeSet
in_scope_set IdUnfoldingFun
_) (Cast OutExpr
casted_e Coercion
co)
    | Just (Id
x, OutExpr
e,[CoreTickish]
ts) <- HasDebugCallStack =>
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe InScopeEnv
ise OutExpr
casted_e
    -- Only do value lambdas.
    -- this implies that x is not in scope in gamma (makes this code simpler)
    , Bool -> Bool
not (Id -> Bool
isTyVar Id
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isCoVar Id
x)
    , Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id
x Id -> VarSet -> Bool
`elemVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co) Bool
True
    , Just (Id
x',OutExpr
e') <- HasDebugCallStack =>
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
pushCoercionIntoLambda InScopeSet
in_scope_set Id
x OutExpr
e Coercion
co
    , let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x',OutExpr
e',[CoreTickish]
ts)
    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
      Maybe (Id, OutExpr, [CoreTickish])
res

-- Another attempt: See if we find a partial unfolding
exprIsLambda_maybe ise :: InScopeEnv
ise@(ISE InScopeSet
in_scope_set IdUnfoldingFun
id_unf) OutExpr
e
    | (Var Id
f, [OutExpr]
as, [CoreTickish]
ts) <- (CoreTickish -> Bool)
-> OutExpr -> (OutExpr, [OutExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
e
    , Id -> BranchCount
idArity Id
f BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
as
    -- Make sure there is hope to get a lambda
    , Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
f)
    -- Optimize, for beta-reduction
    , let e' :: OutExpr
e' = HasDebugCallStack => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
defaultSimpleOpts (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope_set) (OutExpr
rhs OutExpr -> [OutExpr] -> OutExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [OutExpr]
as)
    -- Recurse, because of possible casts
    , Just (Id
x', OutExpr
e'', [CoreTickish]
ts') <- HasDebugCallStack =>
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
InScopeEnv -> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe InScopeEnv
ise OutExpr
e'
    , let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x', OutExpr
e'', [CoreTickish]
ts[CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++[CoreTickish]
ts')
    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
      Maybe (Id, OutExpr, [CoreTickish])
res

exprIsLambda_maybe InScopeEnv
_ OutExpr
_e
    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
      Maybe (Id, OutExpr, [CoreTickish])
forall a. Maybe a
Nothing