module GHC.Core.SimpleOpt (
        SimpleOpts (..), defaultSimpleOpts,
        
        simpleOptPgm, simpleOptExpr, simpleOptExprWith,
        
        joinPointBinding_maybe, joinPointBindings_maybe,
        
        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
    ) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Opt.Arity
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Make ( FloatBind(..) )
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info  ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
import GHC.Types.Var      ( isNonCoVarId )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core.DataCon
import GHC.Types.Demand( etaConvertDmdSig )
import GHC.Types.Tickish
import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )
import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                            , isInScope, substTyVarBndr, cloneTyVarBndr )
import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Unit.Module ( Module )
import GHC.Utils.Encoding
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe       ( orElse )
import GHC.Data.Graph.UnVar
import Data.List (mapAccumL)
import qualified Data.ByteString as BS
data SimpleOpts = SimpleOpts
   { SimpleOpts -> UnfoldingOpts
so_uf_opts :: !UnfoldingOpts   
   , SimpleOpts -> OptCoercionOpts
so_co_opts :: !OptCoercionOpts 
   }
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts :: SimpleOpts
defaultSimpleOpts = SimpleOpts
   { so_uf_opts :: UnfoldingOpts
so_uf_opts = UnfoldingOpts
defaultUnfoldingOpts
   , so_co_opts :: OptCoercionOpts
so_co_opts = OptCoercionOpts
      { optCoercionEnabled :: Bool
optCoercionEnabled = Bool
False }
   }
simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr :: (() :: Constraint) => SimpleOpts -> OutExpr -> OutExpr
simpleOptExpr SimpleOpts
opts OutExpr
expr
  = 
    (() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
init_subst OutExpr
expr
  where
    init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet (OutExpr -> VarSet
exprFreeVars OutExpr
expr))
        
        
        
        
        
        
        
        
        
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
simpleOptExprWith :: (() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
opts Subst
subst OutExpr
expr
  = HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
init_env (OutExpr -> OutExpr
occurAnalyseExpr OutExpr
expr)
  where
    init_env :: SimpleOptEnv
init_env = (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts) { soe_subst :: Subst
soe_subst = Subst
subst }
simpleOptPgm :: SimpleOpts
             -> Module
             -> CoreProgram
             -> [CoreRule]
             -> (CoreProgram, [CoreRule], CoreProgram)
simpleOptPgm :: SimpleOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> (CoreProgram, [CoreRule], CoreProgram)
simpleOptPgm SimpleOpts
opts Module
this_mod CoreProgram
binds [CoreRule]
rules =
    (CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
binds', [CoreRule]
rules', CoreProgram
occ_anald_binds)
  where
    occ_anald_binds :: CoreProgram
occ_anald_binds  = Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm Module
this_mod
                          (\Id
_ -> Bool
True)  
                          (\Activation
_ -> Bool
False) 
                          [CoreRule]
rules CoreProgram
binds
    (SimpleOptEnv
final_env, CoreProgram
binds') = ((SimpleOptEnv, CoreProgram)
 -> InBind -> (SimpleOptEnv, CoreProgram))
-> (SimpleOptEnv, CoreProgram)
-> CoreProgram
-> (SimpleOptEnv, CoreProgram)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, CoreProgram)
-> InBind -> (SimpleOptEnv, CoreProgram)
do_one (SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts, []) CoreProgram
occ_anald_binds
    final_subst :: Subst
final_subst = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
final_env
    rules' :: [CoreRule]
rules' = Subst -> [CoreRule] -> [CoreRule]
substRulesForImportedIds Subst
final_subst [CoreRule]
rules
             
             
    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')
type SimpleClo = (SimpleOptEnv, InExpr)
data SimpleOptEnv
  = SOE { SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts :: !OptCoercionOpts
             
        , SimpleOptEnv -> UnfoldingOpts
soe_uf_opts :: !UnfoldingOpts
             
        , SimpleOptEnv -> IdEnv SimpleClo
soe_inl   :: IdEnv SimpleClo
             
             
             
        , SimpleOptEnv -> Subst
soe_subst :: Subst
             
        , SimpleOptEnv -> UnVarSet
soe_rec_ids :: !UnVarSet
             
             
        }
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 :: SimpleOpts -> SimpleOptEnv
emptyEnv :: SimpleOpts -> SimpleOptEnv
emptyEnv SimpleOpts
opts = SOE
   { soe_inl :: IdEnv SimpleClo
soe_inl         = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
   , soe_subst :: Subst
soe_subst       = Subst
emptySubst
   , soe_rec_ids :: UnVarSet
soe_rec_ids = UnVarSet
emptyUnVarSet
   , soe_co_opt_opts :: OptCoercionOpts
soe_co_opt_opts = SimpleOpts -> OptCoercionOpts
so_co_opts SimpleOpts
opts
   , soe_uf_opts :: UnfoldingOpts
soe_uf_opts     = SimpleOpts -> UnfoldingOpts
so_uf_opts SimpleOpts
opts
   }
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
  = SimpleOptEnv
env { soe_inl :: 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
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) }
enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))
                  -> (SimpleOptEnv, r)
enterRecGroupRHSs :: forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env [Id]
bndrs SimpleOptEnv -> (SimpleOptEnv, r)
k
  = (SimpleOptEnv
env'{soe_rec_ids :: UnVarSet
soe_rec_ids = SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env}, r
r)
  where
    (SimpleOptEnv
env', r
r) = SimpleOptEnv -> (SimpleOptEnv, r)
k SimpleOptEnv
env{soe_rec_ids :: UnVarSet
soe_rec_ids = [Id] -> UnVarSet -> UnVarSet
extendUnVarSetList [Id]
bndrs (SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env)}
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env (SimpleOptEnv
e_env, OutExpr
e)
  = HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) OutExpr
e
simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
expr
  = OutExpr -> OutExpr
go OutExpr
expr
  where
    rec_ids :: UnVarSet
rec_ids      = SimpleOptEnv -> UnVarSet
soe_rec_ids SimpleOptEnv
env
    subst :: Subst
subst        = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
    in_scope :: InScopeSet
in_scope     = Subst -> InScopeSet
substInScope Subst
subst
    in_scope_env :: (InScopeSet, IdUnfoldingFun)
in_scope_env = (InScopeSet
in_scope, IdUnfoldingFun
simpleUnfoldingFun)
    
    go :: OutExpr -> OutExpr
go (Var Id
v)
       | Just SimpleClo
clo <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
       = SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
       | Bool
otherwise
       = (() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
    go (App OutExpr
e1 OutExpr
e2)      = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 [(SimpleOptEnv
env,OutExpr
e2)]
    go (Type Type
ty)        = Type -> OutExpr
forall b. Type -> Expr b
Type     (Subst -> Type -> Type
substTy Subst
subst Type
ty)
    go (Coercion Coercion
co)    = Coercion -> OutExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion
go_co Coercion
co)
    go (Lit Literal
lit)        = Literal -> OutExpr
forall b. Literal -> Expr b
Lit Literal
lit
    go (Tick CoreTickish
tickish OutExpr
e) = CoreTickish -> OutExpr -> OutExpr
mkTick (Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
tickish) (OutExpr -> OutExpr
go OutExpr
e)
    go (Cast OutExpr
e Coercion
co)      = OutExpr -> Coercion -> OutExpr
mk_cast (OutExpr -> OutExpr
go OutExpr
e) (Coercion -> Coercion
go_co Coercion
co)
    go (Let InBind
bind OutExpr
body)  = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
                             (SimpleOptEnv
env', Maybe InBind
Nothing)   -> HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body
                             (SimpleOptEnv
env', Just InBind
bind) -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)
    go lam :: OutExpr
lam@(Lam {})     = SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [] OutExpr
lam
    go (Case OutExpr
e Id
b Type
ty [Alt Id]
as)
       
      | Id -> Bool
isDeadBinder Id
b
      , Just (InScopeSet
_, [], DataCon
con, [Type]
_tys, [OutExpr]
es) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
in_scope_env OutExpr
e'
        
      , Just (Alt AltCon
altcon [Id]
bs OutExpr
rhs) <- AltCon -> [Alt Id] -> Maybe (Alt Id)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt (DataCon -> AltCon
DataAlt DataCon
con) [Alt Id]
as
      = case AltCon
altcon of
          AltCon
DEFAULT -> OutExpr -> OutExpr
go OutExpr
rhs
          AltCon
_       -> (Maybe (Id, OutExpr) -> OutExpr -> OutExpr)
-> OutExpr -> [Maybe (Id, OutExpr)] -> OutExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs) [Maybe (Id, OutExpr)]
mb_prs
            where
              (SimpleOptEnv
env', [Maybe (Id, OutExpr)]
mb_prs) = (SimpleOptEnv
 -> (Id, OutExpr) -> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> SimpleOptEnv
-> [(Id, OutExpr)]
-> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (TopLevelFlag
-> SimpleOptEnv
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
NotTopLevel) SimpleOptEnv
env ([(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)]))
-> [(Id, OutExpr)] -> (SimpleOptEnv, [Maybe (Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$
                               String -> [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"simpleOptExpr" [Id]
bs [OutExpr]
es
         
      | Id -> Bool
isDeadBinder Id
b
      , [Alt AltCon
DEFAULT [Id]
_ OutExpr
rhs] <- [Alt Id]
as
      , Type -> Bool
isCoVarType (Id -> Type
varType Id
b)
      , (Var Id
fun, [OutExpr]
_args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
e
      , Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleSCSelIdKey
         
      = OutExpr -> OutExpr
go OutExpr
rhs
      | Bool
otherwise
      = OutExpr -> Id -> Type -> [Alt Id] -> OutExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case OutExpr
e' Id
b' (Subst -> Type -> Type
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
go_alt SimpleOptEnv
env') [Alt Id]
as)
      where
        e' :: OutExpr
e' = OutExpr -> OutExpr
go OutExpr
e
        (SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
    
    go_co :: Coercion -> Coercion
go_co Coercion
co = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst Subst
subst) Coercion
co
    
    go_alt :: SimpleOptEnv -> Alt Id -> Alt Id
go_alt SimpleOptEnv
env (Alt AltCon
con [Id]
bndrs OutExpr
rhs)
      = AltCon -> [Id] -> OutExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
rhs)
      where
        (SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs
    
    
    
    
    
    go_lam :: SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env [Id]
bs' (Lam Id
b OutExpr
e)
       = SimpleOptEnv -> [Id] -> OutExpr -> OutExpr
go_lam SimpleOptEnv
env' (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs') OutExpr
e
       where
         (SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
    go_lam SimpleOptEnv
env [Id]
bs' OutExpr
e
       | Just OutExpr
etad_e <- UnVarSet -> [Id] -> OutExpr -> Maybe OutExpr
tryEtaReduce UnVarSet
rec_ids [Id]
bs OutExpr
e' = OutExpr
etad_e
       | Bool
otherwise                                 = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bs OutExpr
e'
       where
         bs :: [Id]
bs = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs'
         e' :: OutExpr
e' = HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e
mk_cast :: CoreExpr -> CoercionR -> CoreExpr
mk_cast :: OutExpr -> Coercion -> OutExpr
mk_cast (Cast OutExpr
e Coercion
co1) Coercion
co2        = OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
mk_cast (Tick CoreTickish
t OutExpr
e)   Coercion
co         = CoreTickish -> OutExpr -> OutExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (OutExpr -> Coercion -> OutExpr
mk_cast OutExpr
e Coercion
co)
mk_cast OutExpr
e Coercion
co | Coercion -> Bool
isReflexiveCo Coercion
co = OutExpr
e
             | Bool
otherwise        = OutExpr -> Coercion -> OutExpr
forall b. Expr b -> Coercion -> Expr b
Cast OutExpr
e Coercion
co
simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app :: (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env (Var Id
v) [SimpleClo]
as
  | Just (SimpleOptEnv
env', OutExpr
e) <- IdEnv SimpleClo -> Id -> Maybe SimpleClo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (SimpleOptEnv -> IdEnv SimpleClo
soe_inl SimpleOptEnv
env) Id
v
  = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
env') OutExpr
e [SimpleClo]
as
  | let unf :: Unfolding
unf = IdUnfoldingFun
idUnfolding Id
v
  , Unfolding -> Bool
isCompulsoryUnfolding (IdUnfoldingFun
idUnfolding Id
v)
  , Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
v)
    
  = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app (SimpleOptEnv -> SimpleOptEnv
soeZapSubst SimpleOptEnv
env) (Unfolding -> OutExpr
unfoldingTemplate Unfolding
unf) [SimpleClo]
as
  | Bool
otherwise
  , let out_fn :: OutExpr
out_fn = (() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
  = SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
out_fn [SimpleClo]
as
simple_app SimpleOptEnv
env (App OutExpr
e1 OutExpr
e2) [SimpleClo]
as
  = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e1 ((SimpleOptEnv
env, OutExpr
e2) SimpleClo -> [SimpleClo] -> [SimpleClo]
forall a. a -> [a] -> [a]
: [SimpleClo]
as)
simple_app SimpleOptEnv
env e :: OutExpr
e@(Lam {}) as :: [SimpleClo]
as@(SimpleClo
_:[SimpleClo]
_)
  = SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (OutExpr -> BranchCount -> OutExpr
zapLambdaBndrs OutExpr
e BranchCount
n_args) [SimpleClo]
as
    
    
    
    
    
    
  where
    n_args :: BranchCount
n_args = [SimpleClo] -> BranchCount
forall a. [a] -> BranchCount
forall (t :: * -> *) a. Foldable t => t a -> BranchCount
length [SimpleClo]
as
    do_beta :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env (Lam Id
b OutExpr
body) (SimpleClo
a:[SimpleClo]
as)
      | (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) <- SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b Maybe Id
forall a. Maybe a
Nothing SimpleClo
a TopLevelFlag
NotTopLevel
      = Maybe (Id, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
mb_pr (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
do_beta SimpleOptEnv
env' OutExpr
body [SimpleClo]
as
    do_beta SimpleOptEnv
env OutExpr
body [SimpleClo]
as
      = (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
body [SimpleClo]
as
simple_app SimpleOptEnv
env (Tick CoreTickish
t OutExpr
e) [SimpleClo]
as
  
  | CoreTickish
t CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
  = CoreTickish -> OutExpr -> OutExpr
mkTick CoreTickish
t (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as
simple_app SimpleOptEnv
env (Let InBind
bind OutExpr
body) [SimpleClo]
args
  = case SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env InBind
bind TopLevelFlag
NotTopLevel of
      (SimpleOptEnv
env', Maybe InBind
Nothing)   -> (() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args
      (SimpleOptEnv
env', Just InBind
bind')
        | InBind -> Bool
isJoinBind InBind
bind' -> SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env OutExpr
expr' [SimpleClo]
args
        | Bool
otherwise        -> InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' ((() :: Constraint) =>
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
simple_app SimpleOptEnv
env' OutExpr
body [SimpleClo]
args)
        where
          expr' :: OutExpr
expr' = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env' OutExpr
body)
simple_app SimpleOptEnv
env OutExpr
e [SimpleClo]
as
  = SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env OutExpr
e) [SimpleClo]
as
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
_ OutExpr
fun []
  = OutExpr
fun
finish_app SimpleOptEnv
env OutExpr
fun (SimpleClo
arg:[SimpleClo]
args)
  = SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
finish_app SimpleOptEnv
env (OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App OutExpr
fun (SimpleOptEnv -> SimpleClo -> OutExpr
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 Id
b OutExpr
r) TopLevelFlag
top_level
  = (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
            Maybe (Id, OutExpr)
Nothing    -> Maybe InBind
forall a. Maybe a
Nothing
            Just (Id
b,OutExpr
r) -> InBind -> Maybe InBind
forall a. a -> Maybe a
Just (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r))
  where
    (Id
b', OutExpr
r') = Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
b OutExpr
r Maybe (Id, OutExpr) -> (Id, OutExpr) -> (Id, OutExpr)
forall a. Maybe a -> a -> a
`orElse` (Id
b, OutExpr
r)
    (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b' Maybe Id
forall a. Maybe a
Nothing (SimpleOptEnv
env,OutExpr
r') TopLevelFlag
top_level
simple_opt_bind SimpleOptEnv
env (Rec [(Id, OutExpr)]
prs) TopLevelFlag
top_level
  = (SimpleOptEnv
env2, Maybe InBind
res_bind)
  where
    res_bind :: Maybe InBind
res_bind          = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a]
reverse [(Id, OutExpr)]
rev_prs'))
    prs' :: [(Id, OutExpr)]
prs'              = [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
prs Maybe [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. Maybe a -> a -> a
`orElse` [(Id, OutExpr)]
prs
    (SimpleOptEnv
env1, [Id]
bndrs')    = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env (((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
prs')
    (SimpleOptEnv
env2, [(Id, OutExpr)]
rev_prs')  = SimpleOptEnv
-> [Id]
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall r.
SimpleOptEnv
-> [Id] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r)
enterRecGroupRHSs SimpleOptEnv
env1 [Id]
bndrs' ((SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
 -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
forall a b. (a -> b) -> a -> b
$ \SimpleOptEnv
env ->
                          ((SimpleOptEnv, [(Id, OutExpr)])
 -> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)]))
-> (SimpleOptEnv, [(Id, OutExpr)])
-> [((Id, OutExpr), Id)]
-> (SimpleOptEnv, [(Id, OutExpr)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, []) ([(Id, OutExpr)]
prs' [(Id, OutExpr)] -> [Id] -> [((Id, OutExpr), Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs')
    do_pr :: (SimpleOptEnv, [(Id, OutExpr)])
-> ((Id, OutExpr), Id) -> (SimpleOptEnv, [(Id, OutExpr)])
do_pr (SimpleOptEnv
env, [(Id, OutExpr)]
prs) ((Id
b,OutExpr
r), Id
b')
       = (SimpleOptEnv
env', case Maybe (Id, OutExpr)
mb_pr of
                  Just (Id, OutExpr)
pr -> (Id, OutExpr)
pr (Id, OutExpr) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. a -> [a] -> [a]
: [(Id, OutExpr)]
prs
                  Maybe (Id, OutExpr)
Nothing -> [(Id, OutExpr)]
prs)
       where
         (SimpleOptEnv
env', Maybe (Id, OutExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair SimpleOptEnv
env Id
b (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
b') (SimpleOptEnv
env,OutExpr
r) TopLevelFlag
top_level
simple_bind_pair :: SimpleOptEnv
                 -> InVar -> Maybe OutVar
                 -> SimpleClo
                 -> TopLevelFlag
                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
    
    
    
simple_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_bind_pair env :: SimpleOptEnv
env@(SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl_env, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
                 Id
in_bndr Maybe Id
mb_out_bndr clo :: SimpleClo
clo@(SimpleOptEnv
rhs_env, OutExpr
in_rhs)
                 TopLevelFlag
top_level
  | Type Type
ty <- OutExpr
in_rhs        
  , let out_ty :: Type
out_ty = Subst -> Type -> Type
substTy (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env) Type
ty
  = Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
in_rhs) ((SimpleOptEnv, Maybe (Id, OutExpr))
 -> (SimpleOptEnv, Maybe (Id, OutExpr)))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a b. (a -> b) -> a -> b
$
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
  | Coercion Coercion
co <- OutExpr
in_rhs
  , let out_co :: Coercion
out_co = OptCoercionOpts -> TCvSubst -> Coercion -> Coercion
optCoercion (SimpleOptEnv -> OptCoercionOpts
soe_co_opt_opts SimpleOptEnv
env) (Subst -> TCvSubst
getTCvSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
rhs_env)) Coercion
co
  = Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Coercion -> Subst
extendCvSubst Subst
subst Id
in_bndr Coercion
out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
  | Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
    
    
    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, OutExpr)
forall a. Maybe a
Nothing)
  | Bool
otherwise
  = SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
                         OccInfo
occ Bool
active Bool
stable_unf TopLevelFlag
top_level
  where
    stable_unf :: Bool
stable_unf = Unfolding -> Bool
isStableUnfolding (IdUnfoldingFun
idUnfolding Id
in_bndr)
    active :: Bool
active     = Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
in_bndr)
    occ :: OccInfo
occ        = Id -> OccInfo
idOccInfo Id
in_bndr
    out_rhs :: OutExpr
out_rhs | Just BranchCount
join_arity <- Id -> Maybe BranchCount
isJoinId_maybe Id
in_bndr
            = BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity
            | Bool
otherwise
            = SimpleOptEnv -> SimpleClo -> OutExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
    simple_join_rhs :: BranchCount -> OutExpr
simple_join_rhs BranchCount
join_arity 
      = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
join_bndrs' (HasCallStack => SimpleOptEnv -> OutExpr -> OutExpr
SimpleOptEnv -> OutExpr -> OutExpr
simple_opt_expr SimpleOptEnv
env_body OutExpr
join_body)
      where
        env0 :: SimpleOptEnv
env0 = SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
rhs_env
        ([Id]
join_bndrs, OutExpr
join_body) = BranchCount -> OutExpr -> ([Id], OutExpr)
forall b. BranchCount -> Expr b -> ([b], Expr b)
collectNBinders BranchCount
join_arity OutExpr
in_rhs
        (SimpleOptEnv
env_body, [Id]
join_bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env0 [Id]
join_bndrs
    pre_inline_unconditionally :: Bool
    pre_inline_unconditionally :: Bool
pre_inline_unconditionally
       | Id -> Bool
isExportedId Id
in_bndr     = Bool
False
       | Bool
stable_unf               = Bool
False
       | Bool -> Bool
not Bool
active               = Bool
False    
       | Bool -> Bool
not (OccInfo -> Bool
safe_to_inline OccInfo
occ) = Bool
False
       | Bool
otherwise                = Bool
True
        
    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
-> (Id, OutExpr)
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Id
in_bndr, OutExpr
out_rhs)
  | Type Type
out_ty <- OutExpr
out_rhs
  = Bool
-> SDoc
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isTyVar Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
out_ty SDoc -> SDoc -> SDoc
$$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
out_rhs)
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Type -> Subst
extendTvSubst Subst
subst Id
in_bndr Type
out_ty }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
  | Coercion Coercion
out_co <- OutExpr
out_rhs
  = Bool
-> (SimpleOptEnv, Maybe (Id, OutExpr))
-> (SimpleOptEnv, Maybe (Id, OutExpr))
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isCoVar Id
in_bndr)
    (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst -> Id -> Coercion -> Subst
extendCvSubst Subst
subst Id
in_bndr Coercion
out_co }, Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
  | Bool
otherwise
  = SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
forall a. Maybe a
Nothing OutExpr
out_rhs
                         (Id -> OccInfo
idOccInfo Id
in_bndr) Bool
True Bool
False TopLevelFlag
top_level
simple_out_bind_pair :: SimpleOptEnv
                     -> InId -> Maybe OutId -> OutExpr
                     -> OccInfo -> Bool -> Bool -> TopLevelFlag
                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind_pair :: SimpleOptEnv
-> Id
-> Maybe Id
-> OutExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, OutExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr OutExpr
out_rhs
                     OccInfo
occ_info Bool
active Bool
stable_unf TopLevelFlag
top_level
  | Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isNonCoVarId Id
in_bndr) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
in_bndr)
    
    
    Bool
post_inline_unconditionally
  = ( SimpleOptEnv
env' { soe_subst :: Subst
soe_subst = Subst -> Id -> OutExpr -> Subst
extendIdSubst (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
in_bndr OutExpr
out_rhs }
    , Maybe (Id, OutExpr)
forall a. Maybe a
Nothing)
  | Bool
otherwise
  = ( SimpleOptEnv
env', (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
out_bndr, OutExpr
out_rhs) )
  where
    (SimpleOptEnv
env', Id
bndr1) = case Maybe Id
mb_out_bndr of
                      Just Id
out_bndr -> (SimpleOptEnv
env, Id
out_bndr)
                      Maybe Id
Nothing       -> SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
in_bndr
    out_bndr :: Id
out_bndr = SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env' Id
in_bndr TopLevelFlag
top_level OutExpr
out_rhs Id
bndr1
    post_inline_unconditionally :: Bool
    post_inline_unconditionally :: Bool
post_inline_unconditionally
       | Id -> Bool
isExportedId Id
in_bndr  = Bool
False 
       | Bool
stable_unf            = Bool
False 
       | Bool -> Bool
not Bool
active            = Bool
False 
       | Bool
is_loop_breaker       = Bool
False 
                                       
       | OutExpr -> Bool
exprIsTrivial OutExpr
out_rhs = Bool
True
       | Bool
coercible_hack        = Bool
True
       | Bool
otherwise             = Bool
False
    is_loop_breaker :: Bool
is_loop_breaker = OccInfo -> Bool
isWeakLoopBreaker OccInfo
occ_info
    
    coercible_hack :: Bool
coercible_hack | (Var Id
fun, [OutExpr]
args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
out_rhs
                   , Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
                   , DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqDataConKey Bool -> Bool -> Bool
|| DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleDataConKey
                   = (OutExpr -> Bool) -> [OutExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all OutExpr -> Bool
exprIsTrivial [OutExpr]
args
                   | Bool
otherwise
                   = Bool
False
subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
subst_opt_bndrs :: SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs = (SimpleOptEnv -> Id -> (SimpleOptEnv, Id))
-> SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env [Id]
bndrs
subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
subst_opt_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
bndr
  | Id -> Bool
isTyVar Id
bndr  = (SimpleOptEnv
env { soe_subst :: Subst
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
subst_tv, Id
tv') = Subst -> Id -> (Subst, Id)
substTyVarBndr Subst
subst Id
bndr
    (Subst
subst_cv, Id
cv') = Subst -> Id -> (Subst, Id)
substCoVarBndr Subst
subst Id
bndr
subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
subst_opt_id_bndr :: SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_id_bndr env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst, soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl }) Id
old_id
  = (SimpleOptEnv
env { soe_subst :: Subst
soe_subst = Subst
new_subst, soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
new_inl }, Id
new_id)
  where
    Subst InScopeSet
in_scope IdSubstEnv
id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst = Subst
subst
    id1 :: Id
id1    = InScopeSet -> Id -> Id
uniqAway InScopeSet
in_scope Id
old_id
    id2 :: Id
id2    = (Type -> Type) -> Id -> Id
updateIdTypeAndMult (Subst -> Type -> Type
substTy Subst
subst) Id
id1
    new_id :: Id
new_id = Id -> Id
zapFragileIdInfo Id
id2
             
             
    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
        
        
    new_id_subst :: IdSubstEnv
new_id_subst
      | Bool
no_change = IdSubstEnv -> Id -> IdSubstEnv
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdSubstEnv
id_subst Id
old_id
      | Bool
otherwise = IdSubstEnv -> Id -> OutExpr -> IdSubstEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdSubstEnv
id_subst Id
old_id (Id -> OutExpr
forall b. Id -> Expr b
Var Id
new_id)
    new_subst :: Subst
new_subst = InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst
Subst InScopeSet
new_in_scope IdSubstEnv
new_id_subst TvSubstEnv
tv_subst CvSubstEnv
cv_subst
    new_inl :: IdEnv SimpleClo
new_inl   = IdEnv SimpleClo -> Id -> IdEnv SimpleClo
forall a. VarEnv a -> Id -> VarEnv a
delVarEnv IdEnv SimpleClo
inl Id
old_id
add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Id -> TopLevelFlag -> OutExpr -> Id -> Id
add_info SimpleOptEnv
env Id
old_bndr TopLevelFlag
top_level OutExpr
new_rhs Id
new_bndr
 | Id -> Bool
isTyVar Id
old_bndr = Id
new_bndr
 | Bool
otherwise        = Id -> IdInfo -> Id
lazySetIdInfo Id
new_bndr IdInfo
new_info
 where
   subst :: Subst
subst    = SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env
   uf_opts :: UnfoldingOpts
uf_opts  = SimpleOptEnv -> UnfoldingOpts
soe_uf_opts SimpleOptEnv
env
   old_info :: IdInfo
old_info = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr
   
   
   
   
   new_info :: IdInfo
new_info = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
new_bndr IdInfo -> RuleInfo -> IdInfo
`setRuleInfo`      RuleInfo
new_rules
                              IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unfolding
   old_rules :: RuleInfo
old_rules = IdInfo -> RuleInfo
ruleInfo IdInfo
old_info
   new_rules :: RuleInfo
new_rules = Subst -> Id -> RuleInfo -> RuleInfo
substRuleInfo Subst
subst Id
new_bndr RuleInfo
old_rules
   old_unfolding :: Unfolding
old_unfolding = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
old_info
   new_unfolding :: Unfolding
new_unfolding | Unfolding -> Bool
isStableUnfolding Unfolding
old_unfolding
                 = Subst -> Unfolding -> Unfolding
substUnfolding Subst
subst Unfolding
old_unfolding
                 | Bool
otherwise
                 = Unfolding
unfolding_from_rhs
   unfolding_from_rhs :: Unfolding
unfolding_from_rhs = UnfoldingOpts
-> UnfoldingSource
-> Bool
-> Bool
-> OutExpr
-> Maybe UnfoldingCache
-> Unfolding
mkUnfolding UnfoldingOpts
uf_opts UnfoldingSource
InlineRhs
                                    (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
                                    Bool
False 
                                    OutExpr
new_rhs Maybe UnfoldingCache
forall a. Maybe a
Nothing
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun 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, OutExpr) -> OutExpr -> OutExpr
wrapLet Maybe (Id, OutExpr)
Nothing      OutExpr
body = OutExpr
body
wrapLet (Just (Id
b,OutExpr
r)) OutExpr
body = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r) OutExpr
body
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe :: Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe Id
bndr OutExpr
rhs
  | Bool -> Bool
not (Id -> Bool
isId Id
bndr)
  = Maybe (Id, OutExpr)
forall a. Maybe a
Nothing
  | Id -> Bool
isJoinId Id
bndr
  = (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
bndr, OutExpr
rhs)
  | AlwaysTailCalled BranchCount
join_arity <- OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
  , ([Id]
bndrs, OutExpr
body) <- BranchCount -> OutExpr -> ([Id], OutExpr)
etaExpandToJoinPoint BranchCount
join_arity OutExpr
rhs
  , let str_sig :: DmdSig
str_sig   = Id -> DmdSig
idDmdSig Id
bndr
        str_arity :: BranchCount
str_arity = (Id -> Bool) -> [Id] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count Id -> Bool
isId [Id]
bndrs  
        join_bndr :: Id
join_bndr = Id
bndr Id -> BranchCount -> Id
`asJoinId`        BranchCount
join_arity
                         Id -> DmdSig -> Id
`setIdDmdSig` BranchCount -> DmdSig -> DmdSig
etaConvertDmdSig BranchCount
str_arity DmdSig
str_sig
  = (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a. a -> Maybe a
Just (Id
join_bndr, [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs OutExpr
body)
  | Bool
otherwise
  = Maybe (Id, OutExpr)
forall a. Maybe a
Nothing
joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
joinPointBindings_maybe :: [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
joinPointBindings_maybe [(Id, OutExpr)]
bndrs
  = ((Id, OutExpr) -> Maybe (Id, OutExpr))
-> [(Id, OutExpr)] -> Maybe [(Id, OutExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Id -> OutExpr -> Maybe (Id, OutExpr))
-> (Id, OutExpr) -> Maybe (Id, OutExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Id -> OutExpr -> Maybe (Id, OutExpr)
joinPointBinding_maybe) [(Id, OutExpr)]
bndrs
data ConCont = CC [CoreExpr] Coercion
                  
exprIsConApp_maybe :: HasDebugCallStack
                   => InScopeEnv -> CoreExpr
                   -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: (() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
exprIsConApp_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) OutExpr
expr
  = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [] OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [] (Type -> Coercion
mkRepReflCo ((() :: Constraint) => OutExpr -> Type
OutExpr -> Type
exprType OutExpr
expr)))
  where
    go :: Either InScopeSet Subst
             
             
             
             
       -> [FloatBind] -> CoreExpr -> ConCont
             
       -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    go :: Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick CoreTickish
t OutExpr
expr) ConCont
cont
       | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ConCont
cont
    go Either InScopeSet Subst
subst [FloatBind]
floats (Cast OutExpr
expr Coercion
co1) (CC [OutExpr]
args Coercion
co2)
       | Just ([OutExpr]
args', MCoercion
m_co1') <- Coercion -> [OutExpr] -> Maybe ([OutExpr], MCoercion)
pushCoArgs (Either InScopeSet Subst -> Coercion -> Coercion
forall {a}. Either a Subst -> Coercion -> Coercion
subst_co Either InScopeSet Subst
subst Coercion
co1) [OutExpr]
args
            
       = case MCoercion
m_co1' of
           MCo Coercion
co1' -> Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args' (Coercion
co1' Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2))
           MCoercion
MRefl    -> Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
expr ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args' Coercion
co2)
    go Either InScopeSet Subst
subst [FloatBind]
floats (App OutExpr
fun OutExpr
arg) (CC [OutExpr]
args Coercion
co)
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats OutExpr
fun ([OutExpr] -> Coercion -> ConCont
CC (Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
arg OutExpr -> [OutExpr] -> [OutExpr]
forall a. a -> [a] -> [a]
: [OutExpr]
args) Coercion
co)
    go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Id
bndr OutExpr
body) (CC (OutExpr
arg:[OutExpr]
args) Coercion
co)
       | OutExpr -> Bool
exprIsTrivial OutExpr
arg          
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (Either InScopeSet Subst -> Id -> OutExpr -> Either InScopeSet Subst
forall {a}.
Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend Either InScopeSet Subst
subst Id
bndr OutExpr
arg) [FloatBind]
floats OutExpr
body ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args Coercion
co)
       | Bool
otherwise
       = let (Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
             float :: FloatBind
float           = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
arg)
         in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
body ([OutExpr] -> Coercion -> ConCont
CC [OutExpr]
args Coercion
co)
    go Either InScopeSet Subst
subst [FloatBind]
floats (Let (NonRec Id
bndr OutExpr
rhs) OutExpr
expr) ConCont
cont
       | Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
         
       = let rhs' :: OutExpr
rhs'            = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
rhs
             (Either InScopeSet Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
bndr
             float :: FloatBind
float           = InBind -> FloatBind
FloatLet (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' OutExpr
rhs')
         in Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont
    go Either InScopeSet Subst
subst [FloatBind]
floats (Case OutExpr
scrut Id
b Type
_ [Alt AltCon
con [Id]
vars OutExpr
expr]) ConCont
cont
       = let
          scrut' :: OutExpr
scrut'           = Either InScopeSet Subst -> OutExpr -> OutExpr
forall {a}. Either a Subst -> OutExpr -> OutExpr
subst_expr Either InScopeSet Subst
subst OutExpr
scrut
          (Either InScopeSet Subst
subst', Id
b')     = Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst Id
b
          (Either InScopeSet Subst
subst'', [Id]
vars') = Either InScopeSet Subst -> [Id] -> (Either InScopeSet Subst, [Id])
forall {t :: * -> *}.
Traversable t =>
Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst' [Id]
vars
          float :: FloatBind
float            = OutExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase OutExpr
scrut' Id
b' AltCon
con [Id]
vars'
         in
           Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) OutExpr
expr ConCont
cont
    go (Right Subst
sub) [FloatBind]
floats (Var Id
v) ConCont
cont
       = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
substInScope Subst
sub))
            [FloatBind]
floats
            ((() :: Constraint) => Subst -> Id -> OutExpr
Subst -> Id -> OutExpr
lookupIdSubst Subst
sub Id
v)
            ConCont
cont
    go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Id
fun) cont :: ConCont
cont@(CC [OutExpr]
args Coercion
co)
        | Just DataCon
con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun
        , (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
args BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> BranchCount
idArity Id
fun
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con [OutExpr]
args Coercion
co
        
        
        
        
        | Id -> Bool
isDataConWrapId Id
fun
        , let rhs :: OutExpr
rhs = Unfolding -> OutExpr
uf_tmpl (IdUnfoldingFun
realIdUnfolding Id
fun)
        = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats OutExpr
rhs ConCont
cont
        
        | DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [OutExpr]
df_args = [OutExpr]
dfun_args } <- Unfolding
unfolding
        , [Id]
bndrs [Id] -> [OutExpr] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [OutExpr]
args    
        , let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope ([OutExpr] -> VarSet
exprsFreeVars [OutExpr]
dfun_args)
              subst :: Subst
subst = InScopeSet -> [(Id, OutExpr)] -> Subst
mkOpenSubst InScopeSet
in_scope' ([Id]
bndrs [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
args)
              
              
              
              
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
con ((OutExpr -> OutExpr) -> [OutExpr] -> [OutExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
subst) [OutExpr]
dfun_args) Coercion
co
        
        
        
        
        
        | Id -> BranchCount
idArity Id
fun BranchCount -> BranchCount -> Bool
forall a. Eq a => a -> a -> Bool
== BranchCount
0
        , Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe Unfolding
unfolding
        , let in_scope' :: InScopeSet
in_scope' = VarSet -> InScopeSet
extend_in_scope (OutExpr -> VarSet
exprFreeVars OutExpr
rhs)
        = Either InScopeSet Subst
-> [FloatBind]
-> OutExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats OutExpr
rhs ConCont
cont
        
        | (Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringIdKey) Bool -> Bool -> Bool
||
          (Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unpackCStringUtf8IdKey)
        , [OutExpr
arg]              <- [OutExpr]
args
        , Just (LitString ByteString
str) <- (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) OutExpr
arg
        = InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [OutExpr])
 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr]))
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a b. (a -> b) -> a -> b
$
          Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co
        where
          unfolding :: Unfolding
unfolding = IdUnfoldingFun
id_unf Id
fun
          extend_in_scope :: VarSet -> InScopeSet
extend_in_scope VarSet
unf_fvs
            | Id -> Bool
isLocalId Id
fun = InScopeSet
in_scope InScopeSet -> VarSet -> InScopeSet
`extendInScopeSetSet` VarSet
unf_fvs
            | Bool
otherwise     = InScopeSet
in_scope
            
            
    go Either InScopeSet Subst
_ [FloatBind]
_ OutExpr
_ ConCont
_ = Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a. Maybe a
Nothing
    succeedWith :: InScopeSet -> [FloatBind]
                -> Maybe (DataCon, [Type], [CoreExpr])
                -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    succeedWith :: InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
succeedWith InScopeSet
in_scope [FloatBind]
rev_floats Maybe (DataCon, [Type], [OutExpr])
x
      = do { (DataCon
con, [Type]
tys, [OutExpr]
args) <- Maybe (DataCon, [Type], [OutExpr])
x
           ; let floats :: [FloatBind]
floats = [FloatBind] -> [FloatBind]
forall a. [a] -> [a]
reverse [FloatBind]
rev_floats
           ; (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [OutExpr])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (InScopeSet
in_scope, [FloatBind]
floats, DataCon
con, [Type]
tys, [OutExpr]
args) }
    
    
    
    subst_co :: Either a Subst -> Coercion -> Coercion
subst_co (Left {}) Coercion
co = Coercion
co
    subst_co (Right Subst
s) Coercion
co = HasCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
GHC.Core.Subst.substCo Subst
s Coercion
co
    subst_expr :: Either a Subst -> OutExpr -> OutExpr
subst_expr (Left {}) OutExpr
e = OutExpr
e
    subst_expr (Right Subst
s) OutExpr
e = (() :: Constraint) => Subst -> OutExpr -> OutExpr
Subst -> OutExpr -> OutExpr
substExpr Subst
s OutExpr
e
    subst_bndr :: Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
msubst Id
bndr
      = (Subst -> Either a Subst
forall a b. b -> Either a b
Right Subst
subst', Id
bndr')
      where
        (Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr Subst
subst Id
bndr
        subst :: Subst
subst = case Either InScopeSet Subst
msubst of
                  Left InScopeSet
in_scope -> InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
                  Right Subst
subst   -> Subst
subst
    subst_bndrs :: Either InScopeSet Subst -> t Id -> (Either InScopeSet Subst, t Id)
subst_bndrs Either InScopeSet Subst
subst t Id
bs = (Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id))
-> Either InScopeSet Subst
-> t Id
-> (Either InScopeSet Subst, t Id)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Either InScopeSet Subst -> Id -> (Either InScopeSet Subst, Id)
forall {a}. Either InScopeSet Subst -> Id -> (Either a Subst, Id)
subst_bndr Either InScopeSet Subst
subst t Id
bs
    extend :: Either InScopeSet Subst -> Id -> OutExpr -> Either a Subst
extend (Left InScopeSet
in_scope) Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Id
v OutExpr
e)
    extend (Right Subst
s)       Id
v OutExpr
e = Subst -> Either a Subst
forall a b. b -> Either a b
Right (Subst -> Id -> OutExpr -> Subst
extendSubst Subst
s Id
v OutExpr
e)
dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
                      -> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral :: Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co =
  case ByteString -> Maybe (Char, ByteString)
utf8UnconsByteString ByteString
str of
    Maybe (Char, ByteString)
Nothing -> DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy] Coercion
co
    Just (Char
char, ByteString
charTail) ->
      let char_expr :: OutExpr
char_expr = DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
charDataCon [Char -> OutExpr
forall b. Char -> Expr b
mkCharLit Char
char]
          
          rest :: OutExpr
rest = if ByteString -> Bool
BS.null ByteString
charTail
                   then DataCon -> [OutExpr] -> OutExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nilDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy]
                   else OutExpr -> OutExpr -> OutExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> OutExpr
forall b. Id -> Expr b
Var Id
fun)
                            (Literal -> OutExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
charTail))
      in DataCon
-> [OutExpr] -> Coercion -> Maybe (DataCon, [Type], [OutExpr])
pushCoDataCon DataCon
consDataCon [Type -> OutExpr
forall b. Type -> Expr b
Type Type
charTy, OutExpr
char_expr, OutExpr
rest] Coercion
co
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe :: (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(InScopeSet
_, IdUnfoldingFun
id_unf) OutExpr
e
  = case OutExpr
e of
      Lit Literal
l     -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
      Tick CoreTickish
_ OutExpr
e' -> (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env OutExpr
e' 
      Var Id
v     -> Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
                    Maybe OutExpr -> (OutExpr -> Maybe Literal) -> Maybe Literal
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InScopeSet, IdUnfoldingFun) -> OutExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env
      OutExpr
_         -> Maybe Literal
forall a. Maybe a
Nothing
exprIsLambda_maybe :: HasDebugCallStack
                   => InScopeEnv -> CoreExpr
                   -> Maybe (Var, CoreExpr,[CoreTickish])
    
exprIsLambda_maybe :: (() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ (Lam Id
x OutExpr
e)
    = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, [])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Tick CoreTickish
t OutExpr
e)
    | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
    , Just (Id
x, OutExpr
e, [CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e
    = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x, OutExpr
e, CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts)
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Cast OutExpr
casted_e Coercion
co)
    | Just (Id
x, OutExpr
e,[CoreTickish]
ts) <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
casted_e
    
    
    , Bool -> Bool
not (Id -> Bool
isTyVar Id
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isCoVar Id
x)
    , Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Id
x Id -> VarSet -> Bool
`elemVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co) Bool
True
    , Just (Id
x',OutExpr
e') <- (() :: Constraint) =>
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
InScopeSet -> Id -> OutExpr -> Coercion -> Maybe (Id, OutExpr)
pushCoercionIntoLambda InScopeSet
in_scope_set Id
x OutExpr
e Coercion
co
    , let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x',OutExpr
e',[CoreTickish]
ts)
    = 
      Maybe (Id, OutExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e
    | (Var Id
f, [OutExpr]
as, [CoreTickish]
ts) <- (CoreTickish -> Bool)
-> OutExpr -> (OutExpr, [OutExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
e
    , Id -> BranchCount
idArity Id
f BranchCount -> BranchCount -> Bool
forall a. Ord a => a -> a -> Bool
> (OutExpr -> Bool) -> [OutExpr] -> BranchCount
forall a. (a -> Bool) -> [a] -> BranchCount
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
as
    
    , Just OutExpr
rhs <- Unfolding -> Maybe OutExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
f)
    
    , let e' :: OutExpr
e' = (() :: Constraint) => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
defaultSimpleOpts (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope_set) (OutExpr
rhs OutExpr -> [OutExpr] -> OutExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [OutExpr]
as)
    
    , Just (Id
x', OutExpr
e'', [CoreTickish]
ts') <- (InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
(() :: Constraint) =>
(InScopeSet, IdUnfoldingFun)
-> OutExpr -> Maybe (Id, OutExpr, [CoreTickish])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) OutExpr
e'
    , let res :: Maybe (Id, OutExpr, [CoreTickish])
res = (Id, OutExpr, [CoreTickish]) -> Maybe (Id, OutExpr, [CoreTickish])
forall a. a -> Maybe a
Just (Id
x', OutExpr
e'', [CoreTickish]
ts[CoreTickish] -> [CoreTickish] -> [CoreTickish]
forall a. [a] -> [a] -> [a]
++[CoreTickish]
ts')
    = 
      Maybe (Id, OutExpr, [CoreTickish])
res
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ OutExpr
_e
    = 
      Maybe (Id, OutExpr, [CoreTickish])
forall a. Maybe a
Nothing