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

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}

module GHC.Core.SimpleOpt (
        -- ** Simple expression optimiser
        simpleOptPgm, simpleOptExpr, simpleOptExprWith,

        -- ** Join points
        joinPointBinding_maybe, joinPointBindings_maybe,

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

        -- ** Coercions and casts
        pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core.Opt.Arity( etaExpandToJoinPoint )

import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.FVs
import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding )
import GHC.Core.Make ( FloatBind(..) )
import GHC.Core.Ppr  ( pprCoreBindings, pprRules )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info  ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import GHC.Types.Var      ( isNonCoVarId )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core.DataCon
import GHC.Types.Demand( etaConvertStrictSig )
import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                            , isInScope, substTyVarBndr, cloneTyVarBndr )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
import GHC.Core.TyCon ( tyConArity )
import GHC.Core.Multiplicity
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Unit.Module ( Module )
import GHC.Utils.Encoding
import GHC.Utils.Error
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Data.Pair
import GHC.Utils.Misc
import GHC.Data.Maybe       ( orElse )
import Data.List
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.

-}

simpleOptExpr :: HasDebugCallStack => DynFlags -> 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

simpleOptExpr :: HasDebugCallStack => DynFlags -> Expr Var -> Expr Var
simpleOptExpr DynFlags
dflags Expr Var
expr
  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
    HasDebugCallStack => DynFlags -> Subst -> Expr Var -> Expr Var
DynFlags -> Subst -> Expr Var -> Expr Var
simpleOptExprWith DynFlags
dflags Subst
init_subst Expr Var
expr
  where
    init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (Expr Var -> VarSet
exprFreeVars Expr Var
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 => DynFlags -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> Expr Var -> Expr Var
simpleOptExprWith DynFlags
dflags Subst
subst Expr Var
expr
  = HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
init_env (Expr Var -> Expr Var
occurAnalyseExpr Expr Var
expr)
  where
    init_env :: SimpleOptEnv
init_env = SOE :: DynFlags -> IdEnv SimpleClo -> Subst -> SimpleOptEnv
SOE { soe_dflags :: DynFlags
soe_dflags = DynFlags
dflags
                   , soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
                   , soe_subst :: Subst
soe_subst = Subst
subst }

----------------------
simpleOptPgm :: DynFlags -> Module
             -> CoreProgram -> [CoreRule]
             -> IO (CoreProgram, [CoreRule])
-- See Note [The simple optimiser]
simpleOptPgm :: DynFlags
-> Module
-> CoreProgram
-> [CoreRule]
-> IO (CoreProgram, [CoreRule])
simpleOptPgm DynFlags
dflags Module
this_mod CoreProgram
binds [CoreRule]
rules
  = do { DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_occur_anal String
"Occurrence analysis"
            DumpFormat
FormatCore (CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings CoreProgram
occ_anald_binds SDoc -> SDoc -> SDoc
$$ [CoreRule] -> SDoc
pprRules [CoreRule]
rules );

       ; (CoreProgram, [CoreRule]) -> IO (CoreProgram, [CoreRule])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
binds', [CoreRule]
rules') }
  where
    occ_anald_binds :: CoreProgram
occ_anald_binds  = Module
-> (Var -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod
                          (\Var
_ -> 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (DynFlags -> SimpleOptEnv
emptyEnv DynFlags
dflags, []) 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 -> DynFlags
soe_dflags :: DynFlags
        , 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
        }

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
text String
"SOE {" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"soe_inl   =" SDoc -> SDoc -> SDoc
<+> IdEnv SimpleClo -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv SimpleClo
inl
                            , String -> SDoc
text String
"soe_subst =" SDoc -> SDoc -> SDoc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst ]
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"}"

emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv DynFlags
dflags
  = SOE :: DynFlags -> IdEnv SimpleClo -> Subst -> SimpleOptEnv
SOE { soe_dflags :: DynFlags
soe_dflags = DynFlags
dflags
        , soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
        , soe_subst :: Subst
soe_subst = Subst
emptySubst }

soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
  = SimpleOptEnv
env { soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv, soe_subst :: Subst
soe_subst = Subst -> Subst
zapSubstEnv Subst
subst }

soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
-- Take in-scope set from env1, and the rest from env2
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope (SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst1 })
              env2 :: SimpleOptEnv
env2@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst2 })
  = SimpleOptEnv
env2 { soe_subst :: Subst
soe_subst = Subst -> InScopeSet -> Subst
setInScope Subst
subst2 (Subst -> InScopeSet
substInScope Subst
subst1) }

---------------
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> Expr Var
simple_opt_clo SimpleOptEnv
env (SimpleOptEnv
e_env, Expr Var
e)
  = HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) Expr Var
e

simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
env Expr Var
expr
  = Expr Var -> Expr Var
go Expr Var
expr
  where
    subst :: Subst
subst        = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
    in_scope :: InScopeSet
in_scope     = Subst -> InScopeSet
substInScope Subst
subst
    in_scope_env :: (InScopeSet, IdUnfoldingFun)
in_scope_env = (InScopeSet
in_scope, IdUnfoldingFun
simpleUnfoldingFun)

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

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

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

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

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

    ----------------------
    go_co :: CoercionR -> CoercionR
go_co CoercionR
co = DynFlags -> TCvSubst -> CoercionR -> CoercionR
optCoercion (SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst Subst
subst) CoercionR
co

    ----------------------
    go_alt :: SimpleOptEnv -> (a, [Var], Expr Var) -> (a, [Var], Expr Var)
go_alt SimpleOptEnv
env (a
con, [Var]
bndrs, Expr Var
rhs)
      = (a
con, [Var]
bndrs', HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
env' Expr Var
rhs)
      where
        (SimpleOptEnv
env', [Var]
bndrs') = SimpleOptEnv -> [Var] -> (SimpleOptEnv, [Var])
subst_opt_bndrs SimpleOptEnv
env [Var]
bndrs

    ----------------------
    -- go_lam tries eta reduction
    go_lam :: SimpleOptEnv -> [Var] -> Expr Var -> Expr Var
go_lam SimpleOptEnv
env [Var]
bs' (Lam Var
b Expr Var
e)
       = SimpleOptEnv -> [Var] -> Expr Var -> Expr Var
go_lam SimpleOptEnv
env' (Var
b'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs') Expr Var
e
       where
         (SimpleOptEnv
env', Var
b') = SimpleOptEnv -> Var -> (SimpleOptEnv, Var)
subst_opt_bndr SimpleOptEnv
env Var
b
    go_lam SimpleOptEnv
env [Var]
bs' Expr Var
e
       | Just Expr Var
etad_e <- [Var] -> Expr Var -> Maybe (Expr Var)
tryEtaReduce [Var]
bs Expr Var
e' = Expr Var
etad_e
       | Bool
otherwise                         = [Var] -> Expr Var -> Expr Var
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
bs Expr Var
e'
       where
         bs :: [Var]
bs = [Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
bs'
         e' :: Expr Var
e' = HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
env Expr Var
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 :: Expr Var -> CoercionR -> Expr Var
mk_cast (Cast Expr Var
e CoercionR
co1) CoercionR
co2        = Expr Var -> CoercionR -> Expr Var
mk_cast Expr Var
e (CoercionR
co1 CoercionR -> CoercionR -> CoercionR
`mkTransCo` CoercionR
co2)
mk_cast (Tick Tickish Var
t Expr Var
e)   CoercionR
co         = Tickish Var -> Expr Var -> Expr Var
forall b. Tickish Var -> Expr b -> Expr b
Tick Tickish Var
t (Expr Var -> CoercionR -> Expr Var
mk_cast Expr Var
e CoercionR
co)
mk_cast Expr Var
e CoercionR
co | CoercionR -> Bool
isReflexiveCo CoercionR
co = Expr Var
e
             | Bool
otherwise        = Expr Var -> CoercionR -> Expr Var
forall b. Expr b -> CoercionR -> Expr b
Cast Expr Var
e CoercionR
co

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

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

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

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

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

simple_app SimpleOptEnv
env (Lam Var
b Expr Var
e) (SimpleClo
a:[SimpleClo]
as)
  = Maybe (Var, Expr Var) -> Expr Var -> Expr Var
wrapLet Maybe (Var, Expr Var)
mb_pr (HasDebugCallStack =>
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
simple_app SimpleOptEnv
env' Expr Var
e [SimpleClo]
as)
  where
     (SimpleOptEnv
env', Maybe (Var, Expr Var)
mb_pr) = SimpleOptEnv
-> Var
-> Maybe Var
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_bind_pair SimpleOptEnv
env Var
b Maybe Var
forall a. Maybe a
Nothing SimpleClo
a TopLevelFlag
NotTopLevel

simple_app SimpleOptEnv
env (Tick Tickish Var
t Expr Var
e) [SimpleClo]
as
  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
  | Tickish Var
t Tickish Var -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
  = Tickish Var -> Expr Var -> Expr Var
mkTick Tickish Var
t (Expr Var -> Expr Var) -> Expr Var -> Expr Var
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
simple_app SimpleOptEnv
env Expr Var
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 Expr Var
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 -> Expr Var -> [SimpleClo] -> Expr Var
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
simple_app SimpleOptEnv
env' Expr Var
body [SimpleClo]
args
      (SimpleOptEnv
env', Just InBind
bind')
        | InBind -> Bool
isJoinBind InBind
bind' -> SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
finish_app SimpleOptEnv
env Expr Var
expr' [SimpleClo]
args
        | Bool
otherwise        -> InBind -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasDebugCallStack =>
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
simple_app SimpleOptEnv
env' Expr Var
body [SimpleClo]
args)
        where
          expr' :: Expr Var
expr' = InBind -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
env' Expr Var
body)

simple_app SimpleOptEnv
env Expr Var
e [SimpleClo]
as
  = SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
finish_app SimpleOptEnv
env (HasCallStack => SimpleOptEnv -> Expr Var -> Expr Var
SimpleOptEnv -> Expr Var -> Expr Var
simple_opt_expr SimpleOptEnv
env Expr Var
e) [SimpleClo]
as

finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app :: SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
finish_app SimpleOptEnv
_ Expr Var
fun []
  = Expr Var
fun
finish_app SimpleOptEnv
env Expr Var
fun (SimpleClo
arg:[SimpleClo]
args)
  = SimpleOptEnv -> Expr Var -> [SimpleClo] -> Expr Var
finish_app SimpleOptEnv
env (Expr Var -> Expr Var -> Expr Var
forall b. Expr b -> Expr b -> Expr b
App Expr Var
fun (SimpleOptEnv -> SimpleClo -> Expr Var
simple_opt_clo SimpleOptEnv
env SimpleClo
arg)) [SimpleClo]
args

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

simple_opt_bind SimpleOptEnv
env (Rec [(Var, Expr Var)]
prs) TopLevelFlag
top_level
  = (SimpleOptEnv
env'', Maybe InBind
res_bind)
  where
    res_bind :: Maybe InBind
res_bind          = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(Var, Expr Var)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a]
reverse [(Var, Expr Var)]
rev_prs'))
    prs' :: [(Var, Expr Var)]
prs'              = [(Var, Expr Var)] -> Maybe [(Var, Expr Var)]
joinPointBindings_maybe [(Var, Expr Var)]
prs Maybe [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. Maybe a -> a -> a
`orElse` [(Var, Expr Var)]
prs
    (SimpleOptEnv
env', [Var]
bndrs')    = SimpleOptEnv -> [Var] -> (SimpleOptEnv, [Var])
subst_opt_bndrs SimpleOptEnv
env (((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Expr Var)]
prs')
    (SimpleOptEnv
env'', [(Var, Expr Var)]
rev_prs') = ((SimpleOptEnv, [(Var, Expr Var)])
 -> ((Var, Expr Var), Var) -> (SimpleOptEnv, [(Var, Expr Var)]))
-> (SimpleOptEnv, [(Var, Expr Var)])
-> [((Var, Expr Var), Var)]
-> (SimpleOptEnv, [(Var, Expr Var)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, [(Var, Expr Var)])
-> ((Var, Expr Var), Var) -> (SimpleOptEnv, [(Var, Expr Var)])
do_pr (SimpleOptEnv
env', []) ([(Var, Expr Var)]
prs' [(Var, Expr Var)] -> [Var] -> [((Var, Expr Var), Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
bndrs')
    do_pr :: (SimpleOptEnv, [(Var, Expr Var)])
-> ((Var, Expr Var), Var) -> (SimpleOptEnv, [(Var, Expr Var)])
do_pr (SimpleOptEnv
env, [(Var, Expr Var)]
prs) ((Var
b,Expr Var
r), Var
b')
       = (SimpleOptEnv
env', case Maybe (Var, Expr Var)
mb_pr of
                  Just (Var, Expr Var)
pr -> (Var, Expr Var)
pr (Var, Expr Var) -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. a -> [a] -> [a]
: [(Var, Expr Var)]
prs
                  Maybe (Var, Expr Var)
Nothing -> [(Var, Expr Var)]
prs)
       where
         (SimpleOptEnv
env', Maybe (Var, Expr Var)
mb_pr) = SimpleOptEnv
-> Var
-> Maybe Var
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_bind_pair SimpleOptEnv
env Var
b (Var -> Maybe Var
forall a. a -> Maybe a
Just Var
b') (SimpleOptEnv
env,Expr Var
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
-> Var
-> Maybe Var
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
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 })
                 Var
in_bndr Maybe Var
mb_out_bndr clo :: SimpleClo
clo@(SimpleOptEnv
rhs_env, Expr Var
in_rhs)
                 TopLevelFlag
top_level
  | Type Type
ty <- Expr Var
in_rhs        -- let a::* = TYPE ty in <body>
  , let out_ty :: Type
out_ty = Subst -> Type -> Type
substTy (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env) Type
ty
  = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Var -> Type -> Subst
extendTvSubst Subst
subst Var
in_bndr Type
out_ty }, Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

  | Coercion CoercionR
co <- Expr Var
in_rhs
  , let out_co :: CoercionR
out_co = DynFlags -> TCvSubst -> CoercionR -> CoercionR
optCoercion (SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env)) CoercionR
co
  = ASSERT( isCoVar in_bndr )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Var -> CoercionR -> Subst
extendCvSubst Subst
subst Var
in_bndr CoercionR
out_co }, Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

  | ASSERT2( isNonCoVarId in_bndr, ppr 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 :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo -> Var -> SimpleClo -> IdEnv SimpleClo
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv IdEnv SimpleClo
inl_env Var
in_bndr SimpleClo
clo }, Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

  | Bool
otherwise
  = SimpleOptEnv
-> Var
-> Maybe Var
-> Expr Var
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_out_bind_pair SimpleOptEnv
env Var
in_bndr Maybe Var
mb_out_bndr Expr Var
out_rhs
                         OccInfo
occ Bool
active Bool
stable_unf TopLevelFlag
top_level
  where
    stable_unf :: Bool
stable_unf = Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding Var
in_bndr)
    active :: Bool
active     = Activation -> Bool
isAlwaysActive (Var -> Activation
idInlineActivation Var
in_bndr)
    occ :: OccInfo
occ        = Var -> OccInfo
idOccInfo Var
in_bndr

    out_rhs :: Expr Var
out_rhs | Just BranchCount
join_arity <- Var -> Maybe BranchCount
isJoinId_maybe Var
in_bndr
            = BranchCount -> Expr Var
simple_join_rhs BranchCount
join_arity
            | Bool
otherwise
            = SimpleOptEnv -> SimpleClo -> Expr Var
simple_opt_clo SimpleOptEnv
env SimpleClo
clo

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

    pre_inline_unconditionally :: Bool
    pre_inline_unconditionally :: Bool
pre_inline_unconditionally
       | Var -> Bool
isExportedId Var
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

-------------------
simple_out_bind :: TopLevelFlag
                -> SimpleOptEnv
                -> (InVar, OutExpr)
                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind :: TopLevelFlag
-> SimpleOptEnv
-> (Var, Expr Var)
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Var
in_bndr, Expr Var
out_rhs)
  | Type Type
out_ty <- Expr Var
out_rhs
  = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Var -> Type -> Subst
extendTvSubst Subst
subst Var
in_bndr Type
out_ty }, Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

  | Coercion CoercionR
out_co <- Expr Var
out_rhs
  = ASSERT( isCoVar in_bndr )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Var -> CoercionR -> Subst
extendCvSubst Subst
subst Var
in_bndr CoercionR
out_co }, Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

  | Bool
otherwise
  = SimpleOptEnv
-> Var
-> Maybe Var
-> Expr Var
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_out_bind_pair SimpleOptEnv
env Var
in_bndr Maybe Var
forall a. Maybe a
Nothing Expr Var
out_rhs
                         (Var -> OccInfo
idOccInfo Var
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
-> Var
-> Maybe Var
-> Expr Var
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Var, Expr Var))
simple_out_bind_pair SimpleOptEnv
env Var
in_bndr Maybe Var
mb_out_bndr Expr Var
out_rhs
                     OccInfo
occ_info Bool
active Bool
stable_unf TopLevelFlag
top_level
  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
    -- Type and coercion bindings are caught earlier
    -- See Note [Core type and coercion invariant]
    Bool
post_inline_unconditionally
  = ( SimpleOptEnv
env' { soe_subst :: Subst
soe_subst = Subst -> Var -> Expr Var -> Subst
extendIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Var
in_bndr Expr Var
out_rhs }
    , Maybe (Var, Expr Var)
forall a. Maybe a
Nothing)

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

    post_inline_unconditionally :: Bool
    post_inline_unconditionally :: Bool
post_inline_unconditionally
       | Var -> Bool
isExportedId Var
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"
       | Expr Var -> Bool
exprIsTrivial Expr Var
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 Var
fun, [Expr Var]
args) <- Expr Var -> (Expr Var, [Expr Var])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Var
out_rhs
                   , Just DataCon
dc <- Var -> Maybe DataCon
isDataConWorkId_maybe Var
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
                   = (Expr Var -> Bool) -> [Expr Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Var -> Bool
exprIsTrivial [Expr Var]
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 [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 -> [Var] -> (SimpleOptEnv, [Var])
subst_opt_bndrs SimpleOptEnv
env [Var]
bndrs = (SimpleOptEnv -> Var -> (SimpleOptEnv, Var))
-> SimpleOptEnv -> [Var] -> (SimpleOptEnv, [Var])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL SimpleOptEnv -> Var -> (SimpleOptEnv, Var)
subst_opt_bndr SimpleOptEnv
env [Var]
bndrs

subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
subst_opt_bndr :: SimpleOptEnv -> Var -> (SimpleOptEnv, Var)
subst_opt_bndr SimpleOptEnv
env Var
bndr
  | Var -> Bool
isTyVar Var
bndr  = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
subst_tv }, Var
tv')
  | Var -> Bool
isCoVar Var
bndr  = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
subst_cv }, Var
cv')
  | Bool
otherwise     = SimpleOptEnv -> Var -> (SimpleOptEnv, Var)
subst_opt_id_bndr SimpleOptEnv
env Var
bndr
  where
    subst :: Subst
subst           = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
    (Subst
subst_tv, Var
tv') = Subst -> Var -> (Subst, Var)
substTyVarBndr Subst
subst Var
bndr
    (Subst
subst_cv, Var
cv') = Subst -> Var -> (Subst, Var)
substCoVarBndr Subst
subst Var
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 -> Var -> (SimpleOptEnv, Var)
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 }) Var
old_id
  = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
new_subst, soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
new_inl }, Var
new_id)
  where
    Subst InScopeSet
in_scope IdSubstEnv
id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst = Subst
subst

    id1 :: Var
id1    = InScopeSet -> Var -> Var
uniqAway InScopeSet
in_scope Var
old_id
    id2 :: Var
id2    = (Type -> Type) -> Var -> Var
updateIdTypeAndMult (Subst -> Type -> Type
substTy Subst
subst) Var
id1
    new_id :: Var
new_id = Var -> Var
zapFragileIdInfo Var
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 -> Var -> InScopeSet
`extendInScopeSet` Var
new_id

    no_change :: Bool
no_change = Var
new_id Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
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 -> Var -> IdSubstEnv
forall a. VarEnv a -> Var -> VarEnv a
delVarEnv IdSubstEnv
id_subst Var
old_id
      | Bool
otherwise = IdSubstEnv -> Var -> Expr Var -> IdSubstEnv
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv IdSubstEnv
id_subst Var
old_id (Var -> Expr Var
forall b. Var -> Expr b
Var Var
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 -> Var -> IdEnv SimpleClo
forall a. VarEnv a -> Var -> VarEnv a
delVarEnv IdEnv SimpleClo
inl Var
old_id

----------------------
add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Var -> TopLevelFlag -> Expr Var -> Var -> Var
add_info SimpleOptEnv
env Var
old_bndr TopLevelFlag
top_level Expr Var
new_rhs Var
new_bndr
 | Var -> Bool
isTyVar Var
old_bndr = Var
new_bndr
 | Bool
otherwise        = Var -> IdInfo -> Var
lazySetIdInfo Var
new_bndr IdInfo
new_info
 where
   subst :: Subst
subst    = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
   dflags :: DynFlags
dflags   = SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env
   old_info :: IdInfo
old_info = HasDebugCallStack => Var -> IdInfo
Var -> IdInfo
idInfo Var
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 => Var -> IdInfo
Var -> IdInfo
idInfo Var
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 -> Var -> RuleInfo -> RuleInfo
substSpec Subst
subst Var
new_bndr RuleInfo
old_rules

   old_unfolding :: Unfolding
old_unfolding = IdInfo -> Unfolding
unfoldingInfo 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 = DynFlags
-> UnfoldingSource -> Bool -> Bool -> Expr Var -> Unfolding
mkUnfolding DynFlags
dflags UnfoldingSource
InlineRhs
                                    (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
                                    Bool
False -- may be bottom or not
                                    Expr Var
new_rhs

simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun Var
id
  | Activation -> Bool
isAlwaysActive (Var -> Activation
idInlineActivation Var
id) = IdUnfoldingFun
idUnfolding Var
id
  | Bool
otherwise                              = Unfolding
noUnfolding

wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet :: Maybe (Var, Expr Var) -> Expr Var -> Expr Var
wrapLet Maybe (Var, Expr Var)
Nothing      Expr Var
body = Expr Var
body
wrapLet (Just (Var
b,Expr Var
r)) Expr Var
body = InBind -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let (Var -> Expr Var -> InBind
forall b. b -> Expr b -> Bind b
NonRec Var
b Expr Var
r) Expr Var
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 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. Some of this is addressed by compulsorily unfolding coerce on the 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 (see also Note [Desugaring coerce as cast] in
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 ...

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.

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

-- | 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 :: Var -> Expr Var -> Maybe (Var, Expr Var)
joinPointBinding_maybe Var
bndr Expr Var
rhs
  | Bool -> Bool
not (Var -> Bool
isId Var
bndr)
  = Maybe (Var, Expr Var)
forall a. Maybe a
Nothing

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

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

  | Bool
otherwise
  = Maybe (Var, Expr Var)
forall a. Maybe a
Nothing

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


{- 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)
-}

{- *********************************************************************
*                                                                      *
         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 [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] Coercion
                  -- 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 =>
(InScopeSet, IdUnfoldingFun)
-> Expr Var
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
exprIsConApp_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) Expr Var
expr
  = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [] Expr Var
expr ([Expr Var] -> CoercionR -> ConCont
CC [] (Type -> CoercionR
mkRepReflCo (Expr Var -> Type
exprType Expr Var
expr)))
  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]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick Tickish Var
t Expr Var
expr) ConCont
cont
       | Bool -> Bool
not (Tickish Var -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Var
t) = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst [FloatBind]
floats Expr Var
expr ConCont
cont

    go Either InScopeSet Subst
subst [FloatBind]
floats (Cast Expr Var
expr CoercionR
co1) (CC [Expr Var]
args CoercionR
co2)
       | Just ([Expr Var]
args', MCoercion
m_co1') <- CoercionR -> [Expr Var] -> Maybe ([Expr Var], MCoercion)
pushCoArgs (Either InScopeSet Subst -> CoercionR -> CoercionR
forall {a}. Either a Subst -> CoercionR -> CoercionR
subst_co Either InScopeSet Subst
subst CoercionR
co1) [Expr Var]
args
            -- See Note [Push coercions in exprIsConApp_maybe]
       = case MCoercion
m_co1' of
           MCo CoercionR
co1' -> Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst [FloatBind]
floats Expr Var
expr ([Expr Var] -> CoercionR -> ConCont
CC [Expr Var]
args' (CoercionR
co1' CoercionR -> CoercionR -> CoercionR
`mkTransCo` CoercionR
co2))
           MCoercion
MRefl    -> Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst [FloatBind]
floats Expr Var
expr ([Expr Var] -> CoercionR -> ConCont
CC [Expr Var]
args' CoercionR
co2)

    go Either InScopeSet Subst
subst [FloatBind]
floats (App Expr Var
fun Expr Var
arg) (CC [Expr Var]
args CoercionR
co)
       = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst [FloatBind]
floats Expr Var
fun ([Expr Var] -> CoercionR -> ConCont
CC (Either InScopeSet Subst -> Expr Var -> Expr Var
forall {a}. Either a Subst -> Expr Var -> Expr Var
subst_expr Either InScopeSet Subst
subst Expr Var
arg Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
args) CoercionR
co)

    go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Var
bndr Expr Var
body) (CC (Expr Var
arg:[Expr Var]
args) CoercionR
co)
       | Expr Var -> Bool
exprIsTrivial Expr Var
arg          -- Don't duplicate stuff!
       = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go (Either InScopeSet Subst
-> Var -> Expr Var -> Either InScopeSet Subst
forall {a}.
Either InScopeSet Subst -> Var -> Expr Var -> Either a Subst
extend Either InScopeSet Subst
subst Var
bndr Expr Var
arg) [FloatBind]
floats Expr Var
body ([Expr Var] -> CoercionR -> ConCont
CC [Expr Var]
args CoercionR
co)
       | Bool
otherwise
       = let (Either a Subst
subst', Var
bndr') = Either InScopeSet Subst -> Var -> (Either a Subst, Var)
forall {a}. Either InScopeSet Subst -> Var -> (Either a Subst, Var)
subst_bndr Either InScopeSet Subst
subst Var
bndr
             float :: FloatBind
float           = InBind -> FloatBind
FloatLet (Var -> Expr Var -> InBind
forall b. b -> Expr b -> Bind b
NonRec Var
bndr' Expr Var
arg)
         in Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
forall {a}. Either a Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) Expr Var
body ([Expr Var] -> CoercionR -> ConCont
CC [Expr Var]
args CoercionR
co)

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

    go Either InScopeSet Subst
subst [FloatBind]
floats (Case Expr Var
scrut Var
b Type
_ [(AltCon
con, [Var]
vars, Expr Var
expr)]) ConCont
cont
       = let
          scrut' :: Expr Var
scrut'           = Either InScopeSet Subst -> Expr Var -> Expr Var
forall {a}. Either a Subst -> Expr Var -> Expr Var
subst_expr Either InScopeSet Subst
subst Expr Var
scrut
          (Either a Subst
subst', Var
b')     = Either InScopeSet Subst -> Var -> (Either a Subst, Var)
forall {a}. Either InScopeSet Subst -> Var -> (Either a Subst, Var)
subst_bndr Either InScopeSet Subst
subst Var
b
          (Either InScopeSet Subst
subst'', [Var]
vars') = Either InScopeSet Subst
-> [Var] -> (Either InScopeSet Subst, [Var])
forall {t :: * -> *}.
Traversable t =>
Either InScopeSet Subst
-> t Var -> (Either InScopeSet Subst, t Var)
subst_bndrs Either InScopeSet Subst
forall {a}. Either a Subst
subst' [Var]
vars
          float :: FloatBind
float            = Expr Var -> Var -> AltCon -> [Var] -> FloatBind
FloatCase Expr Var
scrut' Var
b' AltCon
con [Var]
vars'
         in
           Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) Expr Var
expr ConCont
cont

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

    go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Var
fun) cont :: ConCont
cont@(CC [Expr Var]
args CoercionR
co)

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

        -- 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]).
        | Var -> Bool
isDataConWrapId Var
fun
        , let rhs :: Expr Var
rhs = Unfolding -> Expr Var
uf_tmpl (IdUnfoldingFun
realIdUnfolding Var
fun)
        = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats Expr Var
rhs ConCont
cont

        -- Look through dictionary functions; see Note [Unfolding DFuns]
        | DFunUnfolding { df_bndrs :: Unfolding -> [Var]
df_bndrs = [Var]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [Expr Var]
df_args = [Expr Var]
dfun_args } <- Unfolding
unfolding
        , [Var]
bndrs [Var] -> [Expr Var] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Expr Var]
args    -- See Note [DFun arity check]
        , let subst :: Subst
subst = InScopeSet -> [(Var, Expr Var)] -> Subst
mkOpenSubst InScopeSet
in_scope ([Var]
bndrs [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Var]
args)
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [Expr Var])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [Expr Var])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var]))
-> Maybe (DataCon, [Type], [Expr Var])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
forall a b. (a -> b) -> a -> b
$
          DataCon
-> [Expr Var] -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
pushCoDataCon DataCon
con ((Expr Var -> Expr Var) -> [Expr Var] -> [Expr Var]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Expr Var -> Expr Var
Subst -> Expr Var -> Expr Var
substExpr Subst
subst) [Expr Var]
dfun_args) CoercionR
co

        -- 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,
        | Var -> BranchCount
idArity Var
fun BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== BranchCount
0
        , Just Expr Var
rhs <- Unfolding -> Maybe (Expr Var)
expandUnfolding_maybe Unfolding
unfolding
        , let in_scope' :: InScopeSet
in_scope' = InScopeSet -> VarSet -> InScopeSet
extendInScopeSetSet InScopeSet
in_scope (Expr Var -> VarSet
exprFreeVars Expr Var
rhs)
        = Either InScopeSet Subst
-> [FloatBind]
-> Expr Var
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats Expr Var
rhs ConCont
cont

        -- See Note [exprIsConApp_maybe on literal strings]
        | (Var
fun Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey) Bool -> Bool -> Bool
||
          (Var
fun Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringUtf8IdKey)
        , [Expr Var
arg]              <- [Expr Var]
args
        , Just (LitString ByteString
str) <- (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
exprIsLiteral_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) Expr Var
arg
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [Expr Var])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [Expr Var])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var]))
-> Maybe (DataCon, [Type], [Expr Var])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
forall a b. (a -> b) -> a -> b
$
          Var
-> ByteString -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
dealWithStringLiteral Var
fun ByteString
str CoercionR
co
        where
          unfolding :: Unfolding
unfolding = IdUnfoldingFun
id_unf Var
fun

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

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

    ----------------------------
    -- Operations on the (Either InScopeSet GHC.Core.Subst)
    -- The Left case is wildly dominant
    subst_co :: Either a Subst -> CoercionR -> CoercionR
subst_co (Left {}) CoercionR
co = CoercionR
co
    subst_co (Right Subst
s) CoercionR
co = HasCallStack => Subst -> CoercionR -> CoercionR
Subst -> CoercionR -> CoercionR
GHC.Core.Subst.substCo Subst
s CoercionR
co

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

    subst_bndr :: Either InScopeSet Subst -> Var -> (Either a Subst, Var)
subst_bndr Either InScopeSet Subst
msubst Var
bndr
      = (Subst -> Either a Subst
forall a b. b -> Either a b
Right Subst
subst', Var
bndr')
      where
        (Subst
subst', Var
bndr') = Subst -> Var -> (Subst, Var)
substBndr Subst
subst Var
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 Var -> (Either InScopeSet Subst, t Var)
subst_bndrs Either InScopeSet Subst
subst t Var
bs = (Either InScopeSet Subst -> Var -> (Either InScopeSet Subst, Var))
-> Either InScopeSet Subst
-> t Var
-> (Either InScopeSet Subst, t Var)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Either InScopeSet Subst -> Var -> (Either InScopeSet Subst, Var)
forall {a}. Either InScopeSet Subst -> Var -> (Either a Subst, Var)
subst_bndr Either InScopeSet Subst
subst t Var
bs

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


-- See Note [exprIsConApp_maybe on literal strings]
dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
                      -> 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 :: Var
-> ByteString -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
dealWithStringLiteral Var
fun ByteString
str CoercionR
co =
  case ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString ByteString
str of
    Maybe (Char, ByteString)
Nothing -> DataCon
-> [Expr Var] -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
pushCoDataCon DataCon
nilDataCon [Type -> Expr Var
forall b. Type -> Expr b
Type Type
charTy] CoercionR
co
    Just (Char
char, ByteString
charTail) ->
      let char_expr :: Expr b
char_expr = DataCon -> [Expr b] -> Expr b
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> Expr b
forall b. Char -> Expr b
mkCharLit Char
char]
          -- In singleton strings, just add [] instead of unpackCstring# ""#.
          rest :: Expr b
rest = if ByteString -> Bool
BS.null ByteString
charTail
                   then DataCon -> [Expr b] -> Expr b
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nilDataCon [Type -> Expr b
forall b. Type -> Expr b
Type Type
charTy]
                   else Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App (Var -> Expr b
forall b. Var -> Expr b
Var Var
fun)
                            (Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))

      in DataCon
-> [Expr Var] -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
pushCoDataCon DataCon
consDataCon [Type -> Expr Var
forall b. Type -> Expr b
Type Type
charTy, Expr Var
forall {b}. Expr b
char_expr, Expr Var
forall {b}. Expr b
rest] CoercionR
co

{-
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
-- Integer and string literals, which are vigorously hoisted to top level
-- and not subsequently inlined
exprIsLiteral_maybe :: (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(InScopeSet
_, IdUnfoldingFun
id_unf) Expr Var
e
  = case Expr Var
e of
      Lit Literal
l     -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
      Tick Tickish Var
_ Expr Var
e' -> (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env Expr Var
e' -- dubious?
      Var Var
v
         | Just Expr Var
rhs <- Unfolding -> Maybe (Expr Var)
expandUnfolding_maybe (IdUnfoldingFun
id_unf Var
v)
         , Just Literal
l   <- (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env Expr Var
rhs
         -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
      Var Var
v
         | Just Expr Var
rhs <- Unfolding -> Maybe (Expr Var)
expandUnfolding_maybe (IdUnfoldingFun
id_unf Var
v)
         , Just Literal
b <- (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
matchBignum (InScopeSet, IdUnfoldingFun)
env Expr Var
rhs
         -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
b
      Expr Var
e
         | Just Literal
b <- (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
matchBignum (InScopeSet, IdUnfoldingFun)
env Expr Var
e
         -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
b

         | Bool
otherwise
         -> Maybe Literal
forall a. Maybe a
Nothing
  where
    matchBignum :: (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
matchBignum (InScopeSet, IdUnfoldingFun)
env Expr Var
e
         | Just (InScopeSet
_env,[FloatBind]
_fb,DataCon
dc,[Type]
_tys,[Expr Var
arg]) <- (InScopeSet, IdUnfoldingFun)
-> Expr Var
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
HasDebugCallStack =>
(InScopeSet, IdUnfoldingFun)
-> Expr Var
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [Expr Var])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
env Expr Var
e
         , Just (LitNumber LitNumType
_ Integer
i) <- (InScopeSet, IdUnfoldingFun) -> Expr Var -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env Expr Var
arg
         = if
            | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
naturalNSDataCon -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
mkLitNatural Integer
i)
            | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerISDataCon -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
mkLitInteger Integer
i)
            | Bool
otherwise              -> Maybe Literal
forall a. Maybe a
Nothing
         | Bool
otherwise
         = 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 :: InScopeEnv -> CoreExpr
                      -> Maybe (Var, CoreExpr,[Tickish Id])
    -- See Note [exprIsLambda_maybe]

-- The simple case: It is a lambda already
exprIsLambda_maybe :: (InScopeSet, IdUnfoldingFun)
-> Expr Var -> Maybe (Var, Expr Var, [Tickish Var])
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ (Lam Var
x Expr Var
e)
    = (Var, Expr Var, [Tickish Var])
-> Maybe (Var, Expr Var, [Tickish Var])
forall a. a -> Maybe a
Just (Var
x, Expr Var
e, [])

-- Still straightforward: Ticks that we can float out of the way
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Tick Tickish Var
t Expr Var
e)
    | Tickish Var -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Var
t
    , Just (Var
x, Expr Var
e, [Tickish Var]
ts) <- (InScopeSet, IdUnfoldingFun)
-> Expr Var -> Maybe (Var, Expr Var, [Tickish Var])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) Expr Var
e
    = (Var, Expr Var, [Tickish Var])
-> Maybe (Var, Expr Var, [Tickish Var])
forall a. a -> Maybe a
Just (Var
x, Expr Var
e, Tickish Var
tTickish Var -> [Tickish Var] -> [Tickish Var]
forall a. a -> [a] -> [a]
:[Tickish Var]
ts)

-- Also possible: A casted lambda. Push the coercion inside
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Cast Expr Var
casted_e CoercionR
co)
    | Just (Var
x, Expr Var
e,[Tickish Var]
ts) <- (InScopeSet, IdUnfoldingFun)
-> Expr Var -> Maybe (Var, Expr Var, [Tickish Var])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) Expr Var
casted_e
    -- Only do value lambdas.
    -- this implies that x is not in scope in gamma (makes this code simpler)
    , Bool -> Bool
not (Var -> Bool
isTyVar Var
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
isCoVar Var
x)
    , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
    , Just (Var
x',Expr Var
e') <- InScopeSet -> Var -> Expr Var -> CoercionR -> Maybe (Var, Expr Var)
pushCoercionIntoLambda InScopeSet
in_scope_set Var
x Expr Var
e CoercionR
co
    , let res :: Maybe (Var, Expr Var, [Tickish Var])
res = (Var, Expr Var, [Tickish Var])
-> Maybe (Var, Expr Var, [Tickish Var])
forall a. a -> Maybe a
Just (Var
x',Expr Var
e',[Tickish Var]
ts)
    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
      Maybe (Var, Expr Var, [Tickish Var])
res

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

exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ Expr Var
_e
    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
      Maybe (Var, Expr Var, [Tickish Var])
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
              The "push rules"
*                                                                      *
************************************************************************

Here we implement the "push rules" from FC papers:

* The push-argument rules, where we can move a coercion past an argument.
  We have
      (fun |> co) arg
  and we want to transform it to
    (fun arg') |> co'
  for some suitable co' and transformed arg'.

* The PushK rule for data constructors.  We have
       (K e1 .. en) |> co
  and we want to transform to
       (K e1' .. en')
  by pushing the coercion into the arguments
-}

pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
pushCoArgs :: CoercionR -> [Expr Var] -> Maybe ([Expr Var], MCoercion)
pushCoArgs CoercionR
co []         = ([Expr Var], MCoercion) -> Maybe ([Expr Var], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoercionR -> MCoercion
MCo CoercionR
co)
pushCoArgs CoercionR
co (Expr Var
arg:[Expr Var]
args) = do { (Expr Var
arg',  MCoercion
m_co1) <- CoercionR -> Expr Var -> Maybe (Expr Var, MCoercion)
pushCoArg  CoercionR
co  Expr Var
arg
                              ; case MCoercion
m_co1 of
                                  MCo CoercionR
co1 -> do { ([Expr Var]
args', MCoercion
m_co2) <- CoercionR -> [Expr Var] -> Maybe ([Expr Var], MCoercion)
pushCoArgs CoercionR
co1 [Expr Var]
args
                                                 ; ([Expr Var], MCoercion) -> Maybe ([Expr Var], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var
arg'Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
:[Expr Var]
args', MCoercion
m_co2) }
                                  MCoercion
MRefl  -> ([Expr Var], MCoercion) -> Maybe ([Expr Var], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var
arg'Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
:[Expr Var]
args, MCoercion
MRefl) }

pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)
-- We have (fun |> co) arg, and we want to transform it to
--         (fun arg) |> co
-- This may fail, e.g. if (fun :: N) where N is a newtype
-- C.f. simplCast in GHC.Core.Opt.Simplify
-- 'co' is always Representational
-- If the returned coercion is Nothing, then it would have been reflexive
pushCoArg :: CoercionR -> Expr Var -> Maybe (Expr Var, MCoercion)
pushCoArg CoercionR
co (Type Type
ty) = do { (Type
ty', MCoercion
m_co') <- CoercionR -> Type -> Maybe (Type, MCoercion)
pushCoTyArg CoercionR
co Type
ty
                            ; (Expr Var, MCoercion) -> Maybe (Expr Var, MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Expr Var
forall b. Type -> Expr b
Type Type
ty', MCoercion
m_co') }
pushCoArg CoercionR
co Expr Var
val_arg   = do { (CoercionR
arg_co, MCoercion
m_co') <- CoercionR -> Maybe (CoercionR, MCoercion)
pushCoValArg CoercionR
co
                            ; (Expr Var, MCoercion) -> Maybe (Expr Var, MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var
val_arg Expr Var -> CoercionR -> Expr Var
`mkCast` CoercionR
arg_co, MCoercion
m_co') }

pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)
-- We have (fun |> co) @ty
-- Push the coercion through to return
--         (fun @ty') |> co'
-- 'co' is always Representational
-- If the returned coercion is Nothing, then it would have been reflexive;
-- it's faster not to compute it, though.
pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercion)
pushCoTyArg CoercionR
co Type
ty
  -- The following is inefficient - don't do `eqType` here, the coercion
  -- optimizer will take care of it. See #14737.
  -- -- | tyL `eqType` tyR
  -- -- = Just (ty, Nothing)

  | CoercionR -> Bool
isReflCo CoercionR
co
  = (Type, MCoercion) -> Maybe (Type, MCoercion)
forall a. a -> Maybe a
Just (Type
ty, MCoercion
MRefl)

  | Type -> Bool
isForAllTy_ty Type
tyL
  = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )
    (Type, MCoercion) -> Maybe (Type, MCoercion)
forall a. a -> Maybe a
Just (Type
ty Type -> CoercionR -> Type
`mkCastTy` CoercionR
co1, CoercionR -> MCoercion
MCo CoercionR
co2)

  | Bool
otherwise
  = Maybe (Type, MCoercion)
forall a. Maybe a
Nothing
  where
    Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
       -- co :: tyL ~ tyR
       -- tyL = forall (a1 :: k1). ty1
       -- tyR = forall (a2 :: k2). ty2

    co1 :: CoercionR
co1 = CoercionR -> CoercionR
mkSymCo (HasDebugCallStack => Role -> BranchCount -> CoercionR -> CoercionR
Role -> BranchCount -> CoercionR -> CoercionR
mkNthCo Role
Nominal BranchCount
0 CoercionR
co)
       -- co1 :: k2 ~N k1
       -- Note that NthCo can extract a Nominal equality between the
       -- kinds of the types related by a coercion between forall-types.
       -- See the NthCo case in GHC.Core.Lint.

    co2 :: CoercionR
co2 = CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Role -> Type -> CoercionR -> CoercionR
mkGReflLeftCo Role
Nominal Type
ty CoercionR
co1)
        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
        -- Arg of mkInstCo is always nominal, hence mkNomReflCo

pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)
-- We have (fun |> co) arg
-- Push the coercion through to return
--         (fun (arg |> co_arg)) |> co_res
-- 'co' is always Representational
-- If the second returned Coercion is actually Nothing, then no cast is necessary;
-- the returned coercion would have been reflexive.
pushCoValArg :: CoercionR -> Maybe (CoercionR, MCoercion)
pushCoValArg CoercionR
co
  -- The following is inefficient - don't do `eqType` here, the coercion
  -- optimizer will take care of it. See #14737.
  -- -- | tyL `eqType` tyR
  -- -- = Just (mkRepReflCo arg, Nothing)

  | CoercionR -> Bool
isReflCo CoercionR
co
  = (CoercionR, MCoercion) -> Maybe (CoercionR, MCoercion)
forall a. a -> Maybe a
Just (Type -> CoercionR
mkRepReflCo Type
arg, MCoercion
MRefl)

  | Type -> Bool
isFunTy Type
tyL
  , (CoercionR
co_mult, CoercionR
co1, CoercionR
co2) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
  , CoercionR -> Bool
isReflexiveCo CoercionR
co_mult
    -- We can't push the coercion in the case where co_mult isn't reflexivity:
    -- it could be an unsafe axiom, and losing this information could yield
    -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x)
    -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int
    -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed

              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
              -- then co1 :: tyL1 ~ tyR1
              --      co2 :: tyL2 ~ tyR2
  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
    (CoercionR, MCoercion) -> Maybe (CoercionR, MCoercion)
forall a. a -> Maybe a
Just (CoercionR -> CoercionR
mkSymCo CoercionR
co1, CoercionR -> MCoercion
MCo CoercionR
co2)

  | Bool
otherwise
  = Maybe (CoercionR, MCoercion)
forall a. Maybe a
Nothing
  where
    arg :: Type
arg = Type -> Type
funArgTy Type
tyR
    Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co

pushCoercionIntoLambda
    :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
-- This implements the Push rule from the paper on coercions
--    (\x. e) |> co
-- ===>
--    (\x'. e |> co')
pushCoercionIntoLambda :: InScopeSet -> Var -> Expr Var -> CoercionR -> Maybe (Var, Expr Var)
pushCoercionIntoLambda InScopeSet
in_scope Var
x Expr Var
e CoercionR
co
    | ASSERT(not (isTyVar x) && not (isCoVar x)) True
    , Pair Type
s1s2 Type
t1t2 <- CoercionR -> Pair Type
coercionKind CoercionR
co
    , Just (Type
_, Type
_s1,Type
_s2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
s1s2
    , Just (Type
w1, Type
t1,Type
_t2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
t1t2
    , (CoercionR
co_mult, CoercionR
co1, CoercionR
co2) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
    , CoercionR -> Bool
isReflexiveCo CoercionR
co_mult
      -- We can't push the coercion in the case where co_mult isn't
      -- reflexivity. See pushCoValArg for more details.
    = let
          -- Should we optimize the coercions here?
          -- Otherwise they might not match too well
          x' :: Var
x' = Var
x Var -> Type -> Var
`setIdType` Type
t1 Var -> Type -> Var
`setIdMult` Type
w1
          in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> Var -> InScopeSet
`extendInScopeSet` Var
x'
          subst :: Subst
subst = Subst -> Var -> Expr Var -> Subst
extendIdSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope')
                                Var
x
                                (Expr Var -> CoercionR -> Expr Var
mkCast (Var -> Expr Var
forall b. Var -> Expr b
Var Var
x') CoercionR
co1)
      in (Var, Expr Var) -> Maybe (Var, Expr Var)
forall a. a -> Maybe a
Just (Var
x', HasDebugCallStack => Subst -> Expr Var -> Expr Var
Subst -> Expr Var -> Expr Var
substExpr Subst
subst Expr Var
e Expr Var -> CoercionR -> Expr Var
`mkCast` CoercionR
co2)
    | Bool
otherwise
    = String -> SDoc -> Maybe (Var, Expr Var) -> Maybe (Var, Expr Var)
forall a. String -> SDoc -> a -> a
pprTrace String
"exprIsLambda_maybe: Unexpected lambda in case" (Expr Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam Var
x Expr Var
e))
      Maybe (Var, Expr Var)
forall a. Maybe a
Nothing

pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
              -> Maybe (DataCon
                       , [Type]      -- Universal type args
                       , [CoreExpr]) -- All other args incl existentials
-- Implement the KPush reduction rule as described in "Down with kinds"
-- The transformation applies iff we have
--      (C e1 ... en) `cast` co
-- where co :: (T t1 .. tn) ~ to_ty
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be.  (Though it usually will.)
pushCoDataCon :: DataCon
-> [Expr Var] -> CoercionR -> Maybe (DataCon, [Type], [Expr Var])
pushCoDataCon DataCon
dc [Expr Var]
dc_args CoercionR
co
  | CoercionR -> Bool
isReflCo CoercionR
co Bool -> Bool -> Bool
|| Type
from_ty Type -> Type -> Bool
`eqType` Type
to_ty  -- try cheap test first
  , let ([Expr Var]
univ_ty_args, [Expr Var]
rest_args) = [Var] -> [Expr Var] -> ([Expr Var], [Expr Var])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Var]
dataConUnivTyVars DataCon
dc) [Expr Var]
dc_args
  = (DataCon, [Type], [Expr Var])
-> Maybe (DataCon, [Type], [Expr Var])
forall a. a -> Maybe a
Just (DataCon
dc, (Expr Var -> Type) -> [Expr Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expr Var -> Type
exprToType [Expr Var]
univ_ty_args, [Expr Var]
rest_args)

  | Just (TyCon
to_tc, [Type]
to_tc_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
to_ty
  , TyCon
to_tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
dc
        -- These two tests can fail; we might see
        --      (C x y) `cast` (g :: T a ~ S [a]),
        -- where S is a type function.  In fact, exprIsConApp
        -- will probably not be called in such circumstances,
        -- but there's nothing wrong with it

  = let
        tc_arity :: BranchCount
tc_arity       = TyCon -> BranchCount
tyConArity TyCon
to_tc
        dc_univ_tyvars :: [Var]
dc_univ_tyvars = DataCon -> [Var]
dataConUnivTyVars DataCon
dc
        dc_ex_tcvars :: [Var]
dc_ex_tcvars   = DataCon -> [Var]
dataConExTyCoVars DataCon
dc
        arg_tys :: [Scaled Type]
arg_tys        = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc

        non_univ_args :: [Expr Var]
non_univ_args  = [Var] -> [Expr Var] -> [Expr Var]
forall b a. [b] -> [a] -> [a]
dropList [Var]
dc_univ_tyvars [Expr Var]
dc_args
        ([Expr Var]
ex_args, [Expr Var]
val_args) = [Var] -> [Expr Var] -> ([Expr Var], [Expr Var])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Var]
dc_ex_tcvars [Expr Var]
non_univ_args

        -- Make the "Psi" from the paper
        omegas :: [CoercionR]
omegas = BranchCount -> CoercionR -> [Role] -> [CoercionR]
decomposeCo BranchCount
tc_arity CoercionR
co (TyCon -> [Role]
tyConRolesRepresentational TyCon
to_tc)
        (Type -> CoercionR
psi_subst, [Type]
to_ex_arg_tys)
          = Role
-> [Var]
-> [CoercionR]
-> [Var]
-> [Type]
-> (Type -> CoercionR, [Type])
liftCoSubstWithEx Role
Representational
                              [Var]
dc_univ_tyvars
                              [CoercionR]
omegas
                              [Var]
dc_ex_tcvars
                              ((Expr Var -> Type) -> [Expr Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expr Var -> Type
exprToType [Expr Var]
ex_args)

          -- Cast the value arguments (which include dictionaries)
        new_val_args :: [Expr Var]
new_val_args = (Type -> Expr Var -> Expr Var)
-> [Type] -> [Expr Var] -> [Expr Var]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Expr Var -> Expr Var
cast_arg ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [Expr Var]
val_args
        cast_arg :: Type -> Expr Var -> Expr Var
cast_arg Type
arg_ty Expr Var
arg = Expr Var -> CoercionR -> Expr Var
mkCast Expr Var
arg (Type -> CoercionR
psi_subst Type
arg_ty)

        to_ex_args :: [Expr b]
to_ex_args = (Type -> Expr b) -> [Type] -> [Expr b]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expr b
forall b. Type -> Expr b
Type [Type]
to_ex_arg_tys

        dump_doc :: SDoc
dump_doc = [SDoc] -> SDoc
vcat [DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc,      [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
dc_univ_tyvars, [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
dc_ex_tcvars,
                         [Scaled Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Scaled Type]
arg_tys, [Expr Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Var]
dc_args,
                         [Expr Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Var]
ex_args, [Expr Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Var]
val_args, CoercionR -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionR
co, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
from_ty, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
to_ty, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
to_tc
                         , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
mkTyConApp TyCon
to_tc ((Expr Var -> Type) -> [Expr Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expr Var -> Type
exprToType ([Expr Var] -> [Type]) -> [Expr Var] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Var] -> [Expr Var] -> [Expr Var]
forall b a. [b] -> [a] -> [a]
takeList [Var]
dc_univ_tyvars [Expr Var]
dc_args) ]
    in
    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
    ASSERT2( equalLength val_args arg_tys, dump_doc )
    (DataCon, [Type], [Expr Var])
-> Maybe (DataCon, [Type], [Expr Var])
forall a. a -> Maybe a
Just (DataCon
dc, [Type]
to_tc_arg_tys, [Expr Var]
forall {b}. [Expr b]
to_ex_args [Expr Var] -> [Expr Var] -> [Expr Var]
forall a. [a] -> [a] -> [a]
++ [Expr Var]
new_val_args)

  | Bool
otherwise
  = Maybe (DataCon, [Type], [Expr Var])
forall a. Maybe a
Nothing

  where
    Pair Type
from_ty Type
to_ty = CoercionR -> Pair Type
coercionKind CoercionR
co

collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
-- Collect lambda binders, pushing coercions inside if possible
-- E.g.   (\x.e) |> g         g :: <Int> -> blah
--        = (\x. e |> Nth 1 g)
--
-- That is,
--
-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
collectBindersPushingCo :: Expr Var -> ([Var], Expr Var)
collectBindersPushingCo Expr Var
e
  = [Var] -> Expr Var -> ([Var], Expr Var)
go [] Expr Var
e
  where
    -- Peel off lambdas until we hit a cast.
    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
    -- The accumulator is in reverse order
    go :: [Var] -> Expr Var -> ([Var], Expr Var)
go [Var]
bs (Lam Var
b Expr Var
e)   = [Var] -> Expr Var -> ([Var], Expr Var)
go (Var
bVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs) Expr Var
e
    go [Var]
bs (Cast Expr Var
e CoercionR
co) = [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c [Var]
bs Expr Var
e CoercionR
co
    go [Var]
bs Expr Var
e           = ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
bs, Expr Var
e)

    -- We are in a cast; peel off casts until we hit a lambda.
    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
    -- (go_c bs e c) is same as (go bs e (e |> c))
    go_c :: [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c [Var]
bs (Cast Expr Var
e CoercionR
co1) CoercionR
co2 = [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c [Var]
bs Expr Var
e (CoercionR
co1 CoercionR -> CoercionR -> CoercionR
`mkTransCo` CoercionR
co2)
    go_c [Var]
bs (Lam Var
b Expr Var
e)    CoercionR
co  = [Var] -> Var -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_lam [Var]
bs Var
b Expr Var
e CoercionR
co
    go_c [Var]
bs Expr Var
e            CoercionR
co  = ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
bs, Expr Var -> CoercionR -> Expr Var
mkCast Expr Var
e CoercionR
co)

    -- We are in a lambda under a cast; peel off lambdas and build a
    -- new coercion for the body.
    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
    go_lam :: [Var] -> Var -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_lam [Var]
bs Var
b Expr Var
e CoercionR
co
      | Var -> Bool
isTyVar Var
b
      , let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
      , ASSERT( isForAllTy_ty tyL )
        Type -> Bool
isForAllTy_ty Type
tyR
      , CoercionR -> Bool
isReflCo (HasDebugCallStack => Role -> BranchCount -> CoercionR -> CoercionR
Role -> BranchCount -> CoercionR -> CoercionR
mkNthCo Role
Nominal BranchCount
0 CoercionR
co)  -- See Note [collectBindersPushingCo]
      = [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c (Var
bVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs) Expr Var
e (CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Type -> CoercionR
mkNomReflCo (Var -> Type
mkTyVarTy Var
b)))

      | Var -> Bool
isCoVar Var
b
      , let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
      , ASSERT( isForAllTy_co tyL )
        Type -> Bool
isForAllTy_co Type
tyR
      , CoercionR -> Bool
isReflCo (HasDebugCallStack => Role -> BranchCount -> CoercionR -> CoercionR
Role -> BranchCount -> CoercionR -> CoercionR
mkNthCo Role
Nominal BranchCount
0 CoercionR
co)  -- See Note [collectBindersPushingCo]
      , let cov :: CoercionR
cov = Var -> CoercionR
mkCoVarCo Var
b
      = [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c (Var
bVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs) Expr Var
e (CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Type -> CoercionR
mkNomReflCo (CoercionR -> Type
mkCoercionTy CoercionR
cov)))

      | Var -> Bool
isId Var
b
      , let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
      , ASSERT( isFunTy tyL) isFunTy tyR
      , (CoercionR
co_mult, CoercionR
co_arg, CoercionR
co_res) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
      , CoercionR -> Bool
isReflCo CoercionR
co_mult -- See Note [collectBindersPushingCo]
      , CoercionR -> Bool
isReflCo CoercionR
co_arg  -- See Note [collectBindersPushingCo]
      = [Var] -> Expr Var -> CoercionR -> ([Var], Expr Var)
go_c (Var
bVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs) Expr Var
e CoercionR
co_res

      | Bool
otherwise = ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
bs, Expr Var -> CoercionR -> Expr Var
mkCast (Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam Var
b Expr Var
e) CoercionR
co)

{-

Note [collectBindersPushingCo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We just look for coercions of form
   <type> # w -> blah
(and similarly for foralls) to keep this function simple.  We could do
more elaborate stuff, but it'd involve substitution etc.

-}