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

{-# LANGUAGE CPP #-}
module CoreOpt (
        -- ** 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 GhcPrelude

import CoreArity( etaExpandToJoinPoint )

import CoreSyn
import CoreSubst
import CoreUtils
import CoreFVs
import PprCore  ( pprCoreBindings, pprRules )
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import Literal  ( Literal(LitString) )
import Id
import Var      ( isNonCoVarId )
import VarSet
import VarEnv
import DataCon
import Demand( etaExpandStrictSig )
import OptCoercion ( optCoercion )
import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                       , isInScope, substTyVarBndr, cloneTyVarBndr )
import Coercion hiding ( substCo, substCoVarBndr )
import TyCon        ( tyConArity )
import TysWiredIn
import PrelNames
import BasicTypes
import Module       ( Module )
import ErrUtils
import DynFlags
import Outputable
import Pair
import Util
import Maybes       ( orElse )
import FastString
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 :: 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 :: DynFlags -> CoreExpr -> CoreExpr
simpleOptExpr dflags :: DynFlags
dflags expr :: CoreExpr
expr
  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
    DynFlags -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith DynFlags
dflags Subst
init_subst CoreExpr
expr
  where
    init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (CoreExpr -> VarSet
exprFreeVars CoreExpr
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 :: DynFlags -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith :: DynFlags -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith dflags :: DynFlags
dflags subst :: Subst
subst expr :: CoreExpr
expr
  = SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
init_env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
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 dflags :: DynFlags
dflags this_mod :: Module
this_mod binds :: CoreProgram
binds rules :: [CoreRule]
rules
  = do { DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_occur_anal "Occurrence analysis"
                       (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
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod
                          (\_ -> Bool
True)  {- All unfoldings active -}
                          (\_ -> Bool
False) {- No rules active -}
                          [CoreRule]
rules CoreProgram
binds

    (final_env :: SimpleOptEnv
final_env, binds' :: 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 (env :: SimpleOptEnv
env, binds' :: CoreProgram
binds') bind :: InBind
bind
      = case SimpleOptEnv -> InBind -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind of
          (env' :: SimpleOptEnv
env', Nothing)    -> (SimpleOptEnv
env', CoreProgram
binds')
          (env' :: SimpleOptEnv
env', Just bind' :: 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 "SOE {" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ String -> SDoc
text "soe_inl   =" SDoc -> SDoc -> SDoc
<+> IdEnv SimpleClo -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv SimpleClo
inl
                            , String -> SDoc
text "soe_subst =" SDoc -> SDoc -> SDoc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst ]
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "}"

emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv dflags :: 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 -> CoreExpr
simple_opt_clo env :: SimpleOptEnv
env (e_env :: SimpleOptEnv
e_env, e :: CoreExpr
e)
  = SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) CoreExpr
e

simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr env :: SimpleOptEnv
env expr :: CoreExpr
expr
  = CoreExpr -> CoreExpr
go CoreExpr
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 :: CoreExpr -> CoreExpr
go (Var v :: Id
v)
       | Just clo :: SimpleClo
clo <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
       = SimpleOptEnv -> SimpleClo -> CoreExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
       | Bool
otherwise
       = SDoc -> Subst -> Id -> CoreExpr
lookupIdSubst (String -> SDoc
text "simpleOptExpr") (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v

    go (App e1 :: CoreExpr
e1 e2 :: CoreExpr
e2)      = SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e1 [(SimpleOptEnv
env,CoreExpr
e2)]
    go (Type ty :: Type
ty)        = Type -> CoreExpr
forall b. Type -> Expr b
Type     (Subst -> Type -> Type
substTy Subst
subst Type
ty)
    go (Coercion co :: Coercion
co)    = Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (DynFlags -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst Subst
subst) Coercion
co)
    go (Lit lit :: Literal
lit)        = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
    go (Tick tickish :: Tickish Id
tickish e :: CoreExpr
e) = Tickish Id -> CoreExpr -> CoreExpr
mkTick (Subst -> Tickish Id -> Tickish Id
substTickish Subst
subst Tickish Id
tickish) (CoreExpr -> CoreExpr
go CoreExpr
e)
    go (Cast e :: CoreExpr
e co :: Coercion
co)      | Coercion -> Bool
isReflCo Coercion
co' = CoreExpr -> CoreExpr
go CoreExpr
e
                        | Bool
otherwise    = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> CoreExpr
go CoreExpr
e) Coercion
co'
                        where
                          co' :: Coercion
co' = DynFlags -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst Subst
subst) Coercion
co

    go (Let bind :: InBind
bind body :: CoreExpr
body) = case SimpleOptEnv -> InBind -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind of
                           (env' :: SimpleOptEnv
env', Nothing)   -> SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body
                           (env' :: SimpleOptEnv
env', Just bind :: InBind
bind) -> InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body)

    go lam :: CoreExpr
lam@(Lam {})     = SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env [] CoreExpr
lam
    go (Case e :: CoreExpr
e b :: Id
b ty :: Type
ty as :: [Alt Id]
as)
       -- See Note [Getting the map/coerce RULE to work]
      | Id -> Bool
isDeadBinder Id
b
      , Just (con :: DataCon
con, _tys :: [Type]
_tys, es :: [CoreExpr]
es) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
in_scope_env CoreExpr
e'
      , Just (altcon :: AltCon
altcon, bs :: [Id]
bs, rhs :: CoreExpr
rhs) <- AltCon -> [Alt Id] -> Maybe (Alt Id)
forall a b. AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
findAlt (DataCon -> AltCon
DataAlt DataCon
con) [Alt Id]
as
      = case AltCon
altcon of
          DEFAULT -> CoreExpr -> CoreExpr
go CoreExpr
rhs
          _       -> (Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Maybe (Id, CoreExpr)] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet (SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
rhs) [Maybe (Id, CoreExpr)]
mb_prs
            where
              (env' :: SimpleOptEnv
env', mb_prs :: [Maybe (Id, CoreExpr)]
mb_prs) = (SimpleOptEnv
 -> (Id, CoreExpr) -> (SimpleOptEnv, Maybe (Id, CoreExpr)))
-> SimpleOptEnv
-> [(Id, CoreExpr)]
-> (SimpleOptEnv, [Maybe (Id, CoreExpr)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL SimpleOptEnv
-> (Id, CoreExpr) -> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind SimpleOptEnv
env ([(Id, CoreExpr)] -> (SimpleOptEnv, [Maybe (Id, CoreExpr)]))
-> [(Id, CoreExpr)] -> (SimpleOptEnv, [Maybe (Id, CoreExpr)])
forall a b. (a -> b) -> a -> b
$
                               String -> [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "simpleOptExpr" [Id]
bs [CoreExpr]
es

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

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

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

    ----------------------
    -- go_lam tries eta reduction
    go_lam :: SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam env :: SimpleOptEnv
env bs' :: [Id]
bs' (Lam b :: Id
b e :: CoreExpr
e)
       = SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env' (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs') CoreExpr
e
       where
         (env' :: SimpleOptEnv
env', b' :: Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
    go_lam env :: SimpleOptEnv
env bs' :: [Id]
bs' e :: CoreExpr
e
       | Just etad_e :: CoreExpr
etad_e <- [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce [Id]
bs CoreExpr
e' = CoreExpr
etad_e
       | Bool
otherwise                         = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bs CoreExpr
e'
       where
         bs :: [Id]
bs = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs'
         e' :: CoreExpr
e' = SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
e

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

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

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

  | Bool
otherwise
  , let out_fn :: CoreExpr
out_fn = SDoc -> Subst -> Id -> CoreExpr
lookupIdSubst (String -> SDoc
text "simple_app") (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
  = SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env CoreExpr
out_fn [SimpleClo]
as

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

simple_app env :: SimpleOptEnv
env (Lam b :: Id
b e :: CoreExpr
e) (a :: SimpleClo
a:as :: [SimpleClo]
as)
  = Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Maybe (Id, CoreExpr)
mb_pr (SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env' CoreExpr
e [SimpleClo]
as)
  where
     (env' :: SimpleOptEnv
env', mb_pr :: Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b Maybe Id
forall a. Maybe a
Nothing SimpleClo
a

simple_app env :: SimpleOptEnv
env (Tick t :: Tickish Id
t e :: CoreExpr
e) as :: [SimpleClo]
as
  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
  | Tickish Id
t Tickish Id -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
  = Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e [SimpleClo]
as

simple_app env :: SimpleOptEnv
env e :: CoreExpr
e as :: [SimpleClo]
as
  = SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env (SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
e) [SimpleClo]
as

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

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

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

----------------------
simple_bind_pair :: SimpleOptEnv
                 -> InVar -> Maybe OutVar
                 -> SimpleClo
                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
    -- (simple_bind_pair subst in_var out_rhs)
    --   either extends subst with (in_var -> out_rhs)
    --   or     returns Nothing
simple_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
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 })
                 in_bndr :: Id
in_bndr mb_out_bndr :: Maybe Id
mb_out_bndr clo :: SimpleClo
clo@(rhs_env :: SimpleOptEnv
rhs_env, in_rhs :: CoreExpr
in_rhs)
  | Type ty :: Type
ty <- CoreExpr
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
  = ASSERT( isTyVar in_bndr )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)

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

  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
    -- The previous two guards got rid of tyvars and coercions
    -- See Note [CoreSyn type and coercion invariant] in CoreSyn
    Bool
pre_inline_unconditionally
  = (SimpleOptEnv
env { soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo -> Id -> SimpleClo -> IdEnv SimpleClo
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv SimpleClo
inl_env Id
in_bndr SimpleClo
clo }, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)

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

    out_rhs :: CoreExpr
out_rhs | Just join_arity :: Int
join_arity <- Id -> Maybe Int
isJoinId_maybe Id
in_bndr
            = Int -> CoreExpr
simple_join_rhs Int
join_arity
            | Bool
otherwise
            = SimpleOptEnv -> SimpleClo -> CoreExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo

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

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

        -- Unconditionally safe to inline
    safe_to_inline :: OccInfo -> Bool
    safe_to_inline :: OccInfo -> Bool
safe_to_inline (IAmALoopBreaker {}) = Bool
False
    safe_to_inline IAmDead              = Bool
True
    safe_to_inline occ :: OccInfo
occ@(OneOcc {})      =  Bool -> Bool
not (OccInfo -> Bool
occ_in_lam OccInfo
occ)
                                        Bool -> Bool -> Bool
&& OccInfo -> Bool
occ_one_br OccInfo
occ
    safe_to_inline (ManyOccs {})        = Bool
False

-------------------
simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind :: SimpleOptEnv
-> (Id, CoreExpr) -> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (in_bndr :: Id
in_bndr, out_rhs :: CoreExpr
out_rhs)
  | Type out_ty :: Type
out_ty <- CoreExpr
out_rhs
  = ASSERT( isTyVar in_bndr )
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)

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

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

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

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

    post_inline_unconditionally :: Bool
    post_inline_unconditionally :: Bool
post_inline_unconditionally
       | Id -> Bool
isExportedId Id
in_bndr  = Bool
False -- Note [Exported Ids and trivial RHSs]
       | Bool
stable_unf            = Bool
False -- Note [Stable unfoldings and postInlineUnconditionally]
       | Bool -> Bool
not Bool
active            = Bool
False --     in SimplUtils
       | 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"
       | CoreExpr -> Bool
exprIsTrivial CoreExpr
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 fun :: Id
fun, args :: [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
out_rhs
                   , Just dc :: DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
                   , DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqDataConKey Bool -> Bool -> Bool
|| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleDataConKey
                   = (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreExpr -> Bool
exprIsTrivial [CoreExpr]
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 SimplUtils, 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.  Trac #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).
-}

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

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

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

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

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

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

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

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

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

----------------------
add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Id -> Id -> Id
add_info env :: SimpleOptEnv
env old_bndr :: Id
old_bndr new_bndr :: Id
new_bndr
 | Id -> Bool
isTyVar Id
old_bndr = Id
new_bndr
 | Bool
otherwise        = Maybe IdInfo -> Id -> Id
maybeModifyIdInfo Maybe IdInfo
mb_new_info Id
new_bndr
 where
   subst :: Subst
subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
   mb_new_info :: Maybe IdInfo
mb_new_info = Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo Subst
subst Id
new_bndr (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr)

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

wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet :: Maybe (Id, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing      body :: CoreExpr
body = CoreExpr
body
wrapLet (Just (b :: Id
b,r :: CoreExpr
r)) body :: CoreExpr
body = InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r) CoreExpr
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 Desugar.

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

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

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

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

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

joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe :: [(Id, CoreExpr)] -> Maybe [(Id, CoreExpr)]
joinPointBindings_maybe bndrs :: [(Id, CoreExpr)]
bndrs
  = ((Id, CoreExpr) -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe [(Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Id -> CoreExpr -> Maybe (Id, CoreExpr))
-> (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> CoreExpr -> Maybe (Id, CoreExpr)
joinPointBinding_maybe) [(Id, CoreExpr)]
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 increses (Trac #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 MkCore.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 a ByteString, so
we must parse it back into a FastString to split off the first character.
That way we can treat unpackCString# and unpackCStringUtf8# in the same way.

We must also be caeful 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.

Note [Push coercions in exprIsConApp_maybe]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Trac #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.
-}

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

-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
-- where t1..tk are the *universally-quantified* type args of 'dc'
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope :: InScopeSet
in_scope, id_unf :: IdUnfoldingFun
id_unf) expr :: CoreExpr
expr
  = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [] (Type -> Coercion
mkRepReflCo (CoreExpr -> Type
exprType CoreExpr
expr)))
  where
    go :: Either InScopeSet Subst
             -- Left in-scope  means "empty substitution"
             -- Right subst    means "apply this substitution to the CoreExpr"
       -> CoreExpr -> ConCont
       -> Maybe (DataCon, [Type], [CoreExpr])
    go :: Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go subst :: Either InScopeSet Subst
subst (Tick t :: Tickish Id
t expr :: CoreExpr
expr) cont :: ConCont
cont
       | Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t) = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst CoreExpr
expr ConCont
cont
    go subst :: Either InScopeSet Subst
subst (Cast expr :: CoreExpr
expr co1 :: Coercion
co1) (CC args :: [CoreExpr]
args co2 :: Coercion
co2)
       | Just (args' :: [CoreExpr]
args', m_co1' :: MCoercion
m_co1') <- Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs (Either InScopeSet Subst -> Coercion -> Coercion
forall a. Either a Subst -> Coercion -> Coercion
subst_co Either InScopeSet Subst
subst Coercion
co1) [CoreExpr]
args
            -- See Note [Push coercions in exprIsConApp_maybe]
       = case MCoercion
m_co1' of
           MCo co1' :: Coercion
co1' -> Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' (Coercion
co1' Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2))
           MRefl    -> Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' Coercion
co2)
    go subst :: Either InScopeSet Subst
subst (App fun :: CoreExpr
fun arg :: CoreExpr
arg) (CC args :: [CoreExpr]
args co :: Coercion
co)
       = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst CoreExpr
fun ([CoreExpr] -> Coercion -> ConCont
CC (Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_arg Either InScopeSet Subst
subst CoreExpr
arg CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) Coercion
co)
    go subst :: Either InScopeSet Subst
subst (Lam var :: Id
var body :: CoreExpr
body) (CC (arg :: CoreExpr
arg:args :: [CoreExpr]
args) co :: Coercion
co)
       | CoreExpr -> Bool
exprIsTrivial CoreExpr
arg          -- Don't duplicate stuff!
       = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go (Either InScopeSet Subst
-> Id -> CoreExpr -> Either InScopeSet Subst
forall a.
Either InScopeSet Subst -> Id -> CoreExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
var CoreExpr
arg) CoreExpr
body ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args Coercion
co)
    go (Right sub :: Subst
sub) (Var v :: Id
v) cont :: ConCont
cont
       = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
substInScope Subst
sub))
            (SDoc -> Subst -> Id -> CoreExpr
lookupIdSubst (String -> SDoc
text "exprIsConApp" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) Subst
sub Id
v)
            ConCont
cont

    go (Left in_scope :: InScopeSet
in_scope) (Var fun :: Id
fun) cont :: ConCont
cont@(CC args :: [CoreExpr]
args co :: Coercion
co)

        | Just con :: DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
        , (CoreExpr -> Bool) -> [CoreExpr] -> Int
forall a. (a -> Bool) -> [a] -> Int
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Int
idArity Id
fun
        = DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
con [CoreExpr]
args Coercion
co

        -- Look through dictionary functions; see Note [Unfolding DFuns]
        | DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
dfun_args } <- Unfolding
unfolding
        , [Id]
bndrs [Id] -> [CoreExpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [CoreExpr]
args    -- See Note [DFun arity check]
        , let subst :: Subst
subst = InScopeSet -> [(Id, CoreExpr)] -> Subst
mkOpenSubst InScopeSet
in_scope ([Id]
bndrs [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
args)
        = DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
con ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr (String -> SDoc
text "exprIsConApp1") Subst
subst) [CoreExpr]
dfun_args) Coercion
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,
        | Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
        , Just rhs :: CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe Unfolding
unfolding
        , let in_scope' :: InScopeSet
in_scope' = InScopeSet -> VarSet -> InScopeSet
extendInScopeSetSet InScopeSet
in_scope (CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs)
        = Either InScopeSet Subst
-> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') CoreExpr
rhs ConCont
cont

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

    go _ _ _ = Maybe (DataCon, [Type], [CoreExpr])
forall a. Maybe a
Nothing

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

    subst_arg :: Either a Subst -> CoreExpr -> CoreExpr
subst_arg (Left {}) e :: CoreExpr
e = CoreExpr
e
    subst_arg (Right s :: Subst
s) e :: CoreExpr
e = SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr (String -> SDoc
text "exprIsConApp2") Subst
s CoreExpr
e

    extend :: Either InScopeSet Subst -> Id -> CoreExpr -> Either a Subst
extend (Left in_scope :: InScopeSet
in_scope) v :: Id
v e :: CoreExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> CoreExpr -> Subst
extendSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Id
v CoreExpr
e)
    extend (Right s :: Subst
s)       v :: Id
v e :: CoreExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> CoreExpr -> Subst
extendSubst Subst
s Id
v CoreExpr
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, MkCore.mkStringExprFS
-- turns those into [] automatically, but just in case something else in GHC
-- generates a string literal directly.
dealWithStringLiteral :: Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral _   str :: ByteString
str co :: Coercion
co
  | ByteString -> Bool
BS.null ByteString
str
  = DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
nilDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy] Coercion
co

dealWithStringLiteral fun :: Id
fun str :: ByteString
str co :: Coercion
co
  = let strFS :: FastString
strFS = ByteString -> FastString
mkFastStringByteString ByteString
str

        char :: Expr b
char = DataCon -> [Expr b] -> Expr b
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> Expr b
forall b. Char -> Expr b
mkCharLit (FastString -> Char
headFS FastString
strFS)]
        charTail :: ByteString
charTail = FastString -> ByteString
fastStringToByteString (FastString -> FastString
tailFS FastString
strFS)

        -- 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 (Id -> Expr b
forall b. Id -> Expr b
Var Id
fun)
                          (Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))

    in DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
consDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
charTy, CoreExpr
forall b. Expr b
char, CoreExpr
forall b. Expr b
rest] Coercion
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 (inclding
type args) matches what the dfun is expecting.  This may be *less*
than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
-}

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) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(_, id_unf :: IdUnfoldingFun
id_unf) e :: CoreExpr
e
  = case CoreExpr
e of
      Lit l :: Literal
l     -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
      Tick _ e' :: CoreExpr
e' -> (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env CoreExpr
e' -- dubious?
      Var v :: Id
v     | Just rhs :: CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
                -> (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env CoreExpr
rhs
      _         -> 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 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)
-> CoreExpr -> Maybe (Id, CoreExpr, [Tickish Id])
exprIsLambda_maybe _ (Lam x :: Id
x e :: CoreExpr
e)
    = (Id, CoreExpr, [Tickish Id]) -> Maybe (Id, CoreExpr, [Tickish Id])
forall a. a -> Maybe a
Just (Id
x, CoreExpr
e, [])

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

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

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

exprIsLambda_maybe _ _e :: CoreExpr
_e
    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
      Maybe (Id, CoreExpr, [Tickish Id])
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 tranformed arg'.

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

pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
pushCoArgs :: Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs co :: Coercion
co []         = ([CoreExpr], MCoercion) -> Maybe ([CoreExpr], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Coercion -> MCoercion
MCo Coercion
co)
pushCoArgs co :: Coercion
co (arg :: CoreExpr
arg:args :: [CoreExpr]
args) = do { (arg' :: CoreExpr
arg',  m_co1 :: MCoercion
m_co1) <- Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg  Coercion
co  CoreExpr
arg
                              ; case MCoercion
m_co1 of
                                  MCo co1 :: Coercion
co1 -> do { (args' :: [CoreExpr]
args', m_co2 :: MCoercion
m_co2) <- Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs Coercion
co1 [CoreExpr]
args
                                                 ; ([CoreExpr], MCoercion) -> Maybe ([CoreExpr], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg'CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args', MCoercion
m_co2) }
                                  MRefl  -> ([CoreExpr], MCoercion) -> Maybe ([CoreExpr], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg'CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
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 Simplify.hs
-- 'co' is always Representational
-- If the returned coercion is Nothing, then it would have been reflexive
pushCoArg :: Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg co :: Coercion
co (Type ty :: Type
ty) = do { (ty' :: Type
ty', m_co' :: MCoercion
m_co') <- Coercion -> Type -> Maybe (Type, MCoercion)
pushCoTyArg Coercion
co Type
ty
                            ; (CoreExpr, MCoercion) -> Maybe (CoreExpr, MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty', MCoercion
m_co') }
pushCoArg co :: Coercion
co val_arg :: CoreExpr
val_arg   = do { (arg_co :: Coercion
arg_co, m_co' :: MCoercion
m_co') <- Coercion -> Maybe (Coercion, MCoercion)
pushCoValArg Coercion
co
                            ; (CoreExpr, MCoercion) -> Maybe (CoreExpr, MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
val_arg CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
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 :: Coercion -> Type -> Maybe (Type, MCoercion)
pushCoTyArg co :: Coercion
co ty :: Type
ty
  -- The following is inefficient - don't do `eqType` here, the coercion
  -- optimizer will take care of it. See Trac #14737.
  -- -- | tyL `eqType` tyR
  -- -- = Just (ty, Nothing)

  | Coercion -> Bool
isReflCo Coercion
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 -> Coercion -> Type
`mkCastTy` Coercion
co1, Coercion -> MCoercion
MCo Coercion
co2)

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

    co1 :: Coercion
co1 = Coercion -> Coercion
mkSymCo (HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal 0 Coercion
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 CoreLint.

    co2 :: Coercion
co2 = Coercion -> Coercion -> Coercion
mkInstCo Coercion
co (Role -> Type -> Coercion -> Coercion
mkGReflLeftCo Role
Nominal Type
ty Coercion
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 :: Coercion -> Maybe (Coercion, MCoercion)
pushCoValArg co :: Coercion
co
  -- The following is inefficient - don't do `eqType` here, the coercion
  -- optimizer will take care of it. See Trac #14737.
  -- -- | tyL `eqType` tyR
  -- -- = Just (mkRepReflCo arg, Nothing)

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

  | Type -> Bool
isFunTy Type
tyL
  , (co1 :: Coercion
co1, co2 :: Coercion
co2) <- HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Representational Coercion
co
              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
              -- then co1 :: tyL1 ~ tyR1
              --      co2 :: tyL2 ~ tyR2
  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
    (Coercion, MCoercion) -> Maybe (Coercion, MCoercion)
forall a. a -> Maybe a
Just (Coercion -> Coercion
mkSymCo Coercion
co1, Coercion -> MCoercion
MCo Coercion
co2)

  | Bool
otherwise
  = Maybe (Coercion, MCoercion)
forall a. Maybe a
Nothing
  where
    arg :: Type
arg = Type -> Type
funArgTy Type
tyR
    Pair tyL :: Type
tyL tyR :: Type
tyR = Coercion -> Pair Type
coercionKind Coercion
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 -> Id -> CoreExpr -> Coercion -> Maybe (Id, CoreExpr)
pushCoercionIntoLambda in_scope :: InScopeSet
in_scope x :: Id
x e :: CoreExpr
e co :: Coercion
co
    | ASSERT(not (isTyVar x) && not (isCoVar x)) True
    , Pair s1s2 :: Type
s1s2 t1t2 :: Type
t1t2 <- Coercion -> Pair Type
coercionKind Coercion
co
    , Just (_s1 :: Type
_s1,_s2 :: Type
_s2) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
s1s2
    , Just (t1 :: Type
t1,_t2 :: Type
_t2) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
t1t2
    = let (co1 :: Coercion
co1, co2 :: Coercion
co2) = HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Representational Coercion
co
          -- Should we optimize the coercions here?
          -- Otherwise they might not match too well
          x' :: Id
x' = Id
x Id -> Type -> Id
`setIdType` Type
t1
          in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> Id -> InScopeSet
`extendInScopeSet` Id
x'
          subst :: Subst
subst = Subst -> Id -> CoreExpr -> Subst
extendIdSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope')
                                Id
x
                                (CoreExpr -> Coercion -> CoreExpr
mkCast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x') Coercion
co1)
      in (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a. a -> Maybe a
Just (Id
x', SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr (String -> SDoc
text "pushCoercionIntoLambda") Subst
subst CoreExpr
e CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co2)
    | Bool
otherwise
    = String -> SDoc -> Maybe (Id, CoreExpr) -> Maybe (Id, CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x CoreExpr
e))
      Maybe (Id, CoreExpr)
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
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon dc :: DataCon
dc dc_args :: [CoreExpr]
dc_args co :: Coercion
co
  | Coercion -> Bool
isReflCo Coercion
co Bool -> Bool -> Bool
|| Type
from_ty Type -> Type -> Bool
`eqType` Type
to_ty  -- try cheap test first
  , let (univ_ty_args :: [CoreExpr]
univ_ty_args, rest_args :: [CoreExpr]
rest_args) = [Id] -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [CoreExpr]
dc_args
  = (DataCon, [Type], [CoreExpr])
-> Maybe (DataCon, [Type], [CoreExpr])
forall a. a -> Maybe a
Just (DataCon
dc, (CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprToType [CoreExpr]
univ_ty_args, [CoreExpr]
rest_args)

  | Just (to_tc :: TyCon
to_tc, to_tc_arg_tys :: [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 :: Int
tc_arity       = TyCon -> Int
tyConArity TyCon
to_tc
        dc_univ_tyvars :: [Id]
dc_univ_tyvars = DataCon -> [Id]
dataConUnivTyVars DataCon
dc
        dc_ex_tcvars :: [Id]
dc_ex_tcvars   = DataCon -> [Id]
dataConExTyCoVars DataCon
dc
        arg_tys :: [Type]
arg_tys        = DataCon -> [Type]
dataConRepArgTys DataCon
dc

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

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

          -- Cast the value arguments (which include dictionaries)
        new_val_args :: [CoreExpr]
new_val_args = (Type -> CoreExpr -> CoreExpr)
-> [Type] -> [CoreExpr] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> CoreExpr -> CoreExpr
cast_arg [Type]
arg_tys [CoreExpr]
val_args
        cast_arg :: Type -> CoreExpr -> CoreExpr
cast_arg arg_ty :: Type
arg_ty arg :: CoreExpr
arg = CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
arg (Type -> Coercion
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,      [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
dc_univ_tyvars, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
dc_ex_tcvars,
                         [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys, [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
dc_args,
                         [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
ex_args, [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
val_args, Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
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 ]
    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], [CoreExpr])
-> Maybe (DataCon, [Type], [CoreExpr])
forall a. a -> Maybe a
Just (DataCon
dc, [Type]
to_tc_arg_tys, [CoreExpr]
forall b. [Expr b]
to_ex_args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
new_val_args)

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

  where
    Pair from_ty :: Type
from_ty to_ty :: Type
to_ty = Coercion -> Pair Type
coercionKind Coercion
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 :: CoreExpr -> ([Id], CoreExpr)
collectBindersPushingCo e :: CoreExpr
e
  = [Id] -> CoreExpr -> ([Id], CoreExpr)
go [] CoreExpr
e
  where
    -- Peel off lambdas until we hit a cast.
    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
    -- The accumulator is in reverse order
    go :: [Id] -> CoreExpr -> ([Id], CoreExpr)
go bs :: [Id]
bs (Lam b :: Id
b e :: CoreExpr
e)   = [Id] -> CoreExpr -> ([Id], CoreExpr)
go (Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs) CoreExpr
e
    go bs :: [Id]
bs (Cast e :: CoreExpr
e co :: Coercion
co) = [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c [Id]
bs CoreExpr
e Coercion
co
    go bs :: [Id]
bs e :: CoreExpr
e           = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreExpr
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 :: [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c bs :: [Id]
bs (Cast e :: CoreExpr
e co1 :: Coercion
co1) co2 :: Coercion
co2 = [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c [Id]
bs CoreExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
    go_c bs :: [Id]
bs (Lam b :: Id
b e :: CoreExpr
e)    co :: Coercion
co  = [Id] -> Id -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_lam [Id]
bs Id
b CoreExpr
e Coercion
co
    go_c bs :: [Id]
bs e :: CoreExpr
e            co :: Coercion
co  = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
e Coercion
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 :: [Id] -> Id -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_lam bs :: [Id]
bs b :: Id
b e :: CoreExpr
e co :: Coercion
co
      | Id -> Bool
isTyVar Id
b
      , let Pair tyL :: Type
tyL tyR :: Type
tyR = Coercion -> Pair Type
coercionKind Coercion
co
      , ASSERT( isForAllTy_ty tyL )
        Type -> Bool
isForAllTy_ty Type
tyR
      , Coercion -> Bool
isReflCo (HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal 0 Coercion
co)  -- See Note [collectBindersPushingCo]
      = [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c (Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs) CoreExpr
e (Coercion -> Coercion -> Coercion
mkInstCo Coercion
co (Type -> Coercion
mkNomReflCo (Id -> Type
mkTyVarTy Id
b)))

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

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

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

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