{-# LANGUAGE CPP #-}
module CoreOpt (
simpleOptPgm, simpleOptExpr, simpleOptExprWith,
joinPointBinding_maybe, joinPointBindings_maybe,
exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
) where
#include "HsVersions.h"
import GhcPrelude
import CoreArity( etaExpandToJoinPoint )
import CoreSyn
import CoreSubst
import CoreUtils
import CoreFVs
import {-#SOURCE #-} CoreUnfold ( mkUnfolding )
import MkCore ( FloatBind(..) )
import PprCore ( pprCoreBindings, pprRules )
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import Literal ( Literal(LitString) )
import Id
import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
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
simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
simpleOptExpr DynFlags
dflags CoreExpr
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))
simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr
simpleOptExprWith :: DynFlags -> Subst -> CoreExpr -> CoreExpr
simpleOptExprWith DynFlags
dflags Subst
subst CoreExpr
expr
= HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
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])
simpleOptPgm :: DynFlags
-> Module
-> CoreProgram
-> [CoreRule]
-> IO (CoreProgram, [CoreRule])
simpleOptPgm DynFlags
dflags Module
this_mod CoreProgram
binds [CoreRule]
rules
= do { DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_occur_anal String
"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
(\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 (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
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 -> DynFlags
soe_dflags :: DynFlags
, SimpleOptEnv -> IdEnv SimpleClo
soe_inl :: IdEnv SimpleClo
, SimpleOptEnv -> Subst
soe_subst :: Subst
}
instance Outputable SimpleOptEnv where
ppr :: SimpleOptEnv -> SDoc
ppr (SOE { soe_inl :: SimpleOptEnv -> IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
inl, soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
= String -> SDoc
text String
"SOE {" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"soe_inl =" SDoc -> SDoc -> SDoc
<+> IdEnv SimpleClo -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv SimpleClo
inl
, String -> SDoc
text String
"soe_subst =" SDoc -> SDoc -> SDoc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst ]
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"}"
emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv :: DynFlags -> SimpleOptEnv
emptyEnv DynFlags
dflags
= SOE :: DynFlags -> IdEnv SimpleClo -> Subst -> SimpleOptEnv
SOE { soe_dflags :: DynFlags
soe_dflags = DynFlags
dflags
, soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv
, soe_subst :: Subst
soe_subst = Subst
emptySubst }
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
soeZapSubst env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst })
= SimpleOptEnv
env { soe_inl :: IdEnv SimpleClo
soe_inl = IdEnv SimpleClo
forall a. VarEnv a
emptyVarEnv, soe_subst :: Subst
soe_subst = Subst -> Subst
zapSubstEnv Subst
subst }
soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
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 SimpleOptEnv
env (SimpleOptEnv
e_env, CoreExpr
e)
= HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr (SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
soeSetInScope SimpleOptEnv
env SimpleOptEnv
e_env) CoreExpr
e
simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr
simple_opt_expr :: SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env 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 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 -> CoreExpr
simple_opt_clo SimpleOptEnv
env SimpleClo
clo
| Bool
otherwise
= SDoc -> Subst -> Id -> CoreExpr
lookupIdSubst (String -> SDoc
text String
"simpleOptExpr") (SimpleOptEnv -> Subst
soe_subst SimpleOptEnv
env) Id
v
go (App CoreExpr
e1 CoreExpr
e2) = SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env CoreExpr
e1 [(SimpleOptEnv
env,CoreExpr
e2)]
go (Type Type
ty) = Type -> CoreExpr
forall b. Type -> Expr b
Type (Subst -> Type -> Type
substTy Subst
subst Type
ty)
go (Coercion 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 Literal
lit) = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
go (Tick Tickish Id
tickish 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 CoreExpr
e 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 InBind
bind CoreExpr
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 -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body
(SimpleOptEnv
env', Just InBind
bind) -> InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
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 CoreExpr
e Id
b Type
ty [Alt Id]
as)
| Id -> Bool
isDeadBinder Id
b
, Just (InScopeSet
_, [], DataCon
con, [Type]
_tys, [CoreExpr]
es) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (InScopeSet, IdUnfoldingFun)
in_scope_env CoreExpr
e'
, Just (AltCon
altcon, [Id]
bs, 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
AltCon
DEFAULT -> CoreExpr -> CoreExpr
go CoreExpr
rhs
AltCon
_ -> (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 (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
rhs) [Maybe (Id, CoreExpr)]
mb_prs
where
(SimpleOptEnv
env', [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 (TopLevelFlag
-> SimpleOptEnv
-> (Id, CoreExpr)
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind TopLevelFlag
NotTopLevel) 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 String
"simpleOptExpr" [Id]
bs [CoreExpr]
es
| Id -> Bool
isDeadBinder Id
b
, [(AltCon
DEFAULT, [Id]
_, CoreExpr
rhs)] <- [Alt Id]
as
, Type -> Bool
isCoVarType (Id -> Type
varType Id
b)
, (Var Id
fun, [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
= 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
(SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
go_alt :: SimpleOptEnv -> (a, [Id], CoreExpr) -> (a, [Id], CoreExpr)
go_alt SimpleOptEnv
env (a
con, [Id]
bndrs, CoreExpr
rhs)
= (a
con, [Id]
bndrs', HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
rhs)
where
(SimpleOptEnv
env', [Id]
bndrs') = SimpleOptEnv -> [Id] -> (SimpleOptEnv, [Id])
subst_opt_bndrs SimpleOptEnv
env [Id]
bndrs
go_lam :: SimpleOptEnv -> [Id] -> CoreExpr -> CoreExpr
go_lam SimpleOptEnv
env [Id]
bs' (Lam Id
b 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
(SimpleOptEnv
env', Id
b') = SimpleOptEnv -> Id -> (SimpleOptEnv, Id)
subst_opt_bndr SimpleOptEnv
env Id
b
go_lam SimpleOptEnv
env [Id]
bs' CoreExpr
e
| Just 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' = HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env CoreExpr
e
simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
simple_app :: SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env (Var Id
v) [SimpleClo]
as
| Just (SimpleOptEnv
env', 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)
= 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 String
"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 SimpleOptEnv
env (App CoreExpr
e1 CoreExpr
e2) [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 SimpleOptEnv
env (Lam Id
b CoreExpr
e) (SimpleClo
a:[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
(SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b Maybe Id
forall a. Maybe a
Nothing SimpleClo
a TopLevelFlag
NotTopLevel
simple_app SimpleOptEnv
env (Tick Tickish Id
t CoreExpr
e) [SimpleClo]
as
| 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 SimpleOptEnv
env (Let InBind
bind CoreExpr
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) -> SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env' CoreExpr
body [SimpleClo]
args
(SimpleOptEnv
env', Just InBind
bind')
| InBind -> Bool
isJoinBind InBind
bind' -> SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env CoreExpr
expr' [SimpleClo]
args
| Bool
otherwise -> InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
simple_app SimpleOptEnv
env' CoreExpr
body [SimpleClo]
args)
where
expr' :: CoreExpr
expr' = InBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind' (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
SimpleOptEnv -> CoreExpr -> CoreExpr
simple_opt_expr SimpleOptEnv
env' CoreExpr
body)
simple_app SimpleOptEnv
env CoreExpr
e [SimpleClo]
as
= SimpleOptEnv -> CoreExpr -> [SimpleClo] -> CoreExpr
finish_app SimpleOptEnv
env (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
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 SimpleOptEnv
_ CoreExpr
fun []
= CoreExpr
fun
finish_app SimpleOptEnv
env CoreExpr
fun (SimpleClo
arg:[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 -> TopLevelFlag
-> (SimpleOptEnv, Maybe OutBind)
simple_opt_bind :: SimpleOptEnv
-> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe InBind)
simple_opt_bind SimpleOptEnv
env (NonRec Id
b CoreExpr
r) TopLevelFlag
top_level
= (SimpleOptEnv
env', case Maybe (Id, CoreExpr)
mb_pr of
Maybe (Id, CoreExpr)
Nothing -> Maybe InBind
forall a. Maybe a
Nothing
Just (Id
b,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
(Id
b', 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)
(SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_bind_pair SimpleOptEnv
env Id
b' Maybe Id
forall a. Maybe a
Nothing (SimpleOptEnv
env,CoreExpr
r') TopLevelFlag
top_level
simple_opt_bind SimpleOptEnv
env (Rec [(Id, CoreExpr)]
prs) TopLevelFlag
top_level
= (SimpleOptEnv
env'', Maybe InBind
res_bind)
where
res_bind :: Maybe InBind
res_bind = InBind -> Maybe InBind
forall a. a -> Maybe a
Just ([(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
(SimpleOptEnv
env', [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')
(SimpleOptEnv
env'', [(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 (SimpleOptEnv
env, [(Id, CoreExpr)]
prs) ((Id
b,CoreExpr
r), Id
b')
= (SimpleOptEnv
env', case Maybe (Id, CoreExpr)
mb_pr of
Just (Id, CoreExpr)
pr -> (Id, CoreExpr)
pr (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
prs
Maybe (Id, CoreExpr)
Nothing -> [(Id, CoreExpr)]
prs)
where
(SimpleOptEnv
env', Maybe (Id, CoreExpr)
mb_pr) = SimpleOptEnv
-> Id
-> Maybe Id
-> SimpleClo
-> TopLevelFlag
-> (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) 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, 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 })
Id
in_bndr Maybe Id
mb_out_bndr clo :: SimpleClo
clo@(SimpleOptEnv
rhs_env, CoreExpr
in_rhs)
TopLevelFlag
top_level
| Type Type
ty <- CoreExpr
in_rhs
, 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 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 )
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
-> TopLevelFlag
-> (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 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 :: CoreExpr
out_rhs | Just 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 Int
join_arity
= [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
join_bndrs' (HasCallStack => SimpleOptEnv -> CoreExpr -> CoreExpr
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
([Id]
join_bndrs, CoreExpr
join_body) = Int -> CoreExpr -> ([Id], CoreExpr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CoreExpr
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 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 :: TopLevelFlag
-> SimpleOptEnv
-> (InVar, OutExpr)
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind :: TopLevelFlag
-> SimpleOptEnv
-> (Id, CoreExpr)
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind TopLevelFlag
top_level env :: SimpleOptEnv
env@(SOE { soe_subst :: SimpleOptEnv -> Subst
soe_subst = Subst
subst }) (Id
in_bndr, CoreExpr
out_rhs)
| Type 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 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
-> TopLevelFlag
-> (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 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
-> CoreExpr
-> OccInfo
-> Bool
-> Bool
-> TopLevelFlag
-> (SimpleOptEnv, Maybe (Id, CoreExpr))
simple_out_bind_pair SimpleOptEnv
env Id
in_bndr Maybe Id
mb_out_bndr CoreExpr
out_rhs
OccInfo
occ_info Bool
active Bool
stable_unf TopLevelFlag
top_level
| ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
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
(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 -> CoreExpr -> Id -> Id
add_info SimpleOptEnv
env' Id
in_bndr TopLevelFlag
top_level CoreExpr
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
| 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
coercible_hack :: Bool
coercible_hack | (Var Id
fun, [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
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
= (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreExpr -> Bool
exprIsTrivial [CoreExpr]
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 :: * -> *) 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 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 = 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
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 -> 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 -> TopLevelFlag -> OutExpr -> OutVar -> OutVar
add_info :: SimpleOptEnv -> Id -> TopLevelFlag -> CoreExpr -> Id -> Id
add_info SimpleOptEnv
env Id
old_bndr TopLevelFlag
top_level CoreExpr
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
dflags :: DynFlags
dflags = SimpleOptEnv -> DynFlags
soe_dflags SimpleOptEnv
env
old_info :: IdInfo
old_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
old_bndr
new_info :: IdInfo
new_info = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
new_bndr IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` RuleInfo
new_rules
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
new_unfolding
old_rules :: RuleInfo
old_rules = IdInfo -> RuleInfo
ruleInfo IdInfo
old_info
new_rules :: RuleInfo
new_rules = Subst -> Id -> RuleInfo -> RuleInfo
substSpec Subst
subst Id
new_bndr RuleInfo
old_rules
old_unfolding :: Unfolding
old_unfolding = IdInfo -> Unfolding
unfoldingInfo IdInfo
old_info
new_unfolding :: Unfolding
new_unfolding | Unfolding -> Bool
isStableUnfolding Unfolding
old_unfolding
= Subst -> Unfolding -> Unfolding
substUnfolding Subst
subst Unfolding
old_unfolding
| Bool
otherwise
= Unfolding
unfolding_from_rhs
unfolding_from_rhs :: Unfolding
unfolding_from_rhs = DynFlags
-> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
mkUnfolding DynFlags
dflags UnfoldingSource
InlineRhs
(TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_level)
Bool
False
CoreExpr
new_rhs
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, CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Maybe (Id, CoreExpr)
Nothing CoreExpr
body = CoreExpr
body
wrapLet (Just (Id
b,CoreExpr
r)) 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
joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
joinPointBinding_maybe :: Id -> CoreExpr -> Maybe (Id, CoreExpr)
joinPointBinding_maybe Id
bndr 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 Int
join_arity <- OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)
, ([Id]
bndrs, 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
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 [(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
data ConCont = CC [CoreExpr] Coercion
exprIsConApp_maybe :: InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe :: (InScopeSet, IdUnfoldingFun)
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) CoreExpr
expr
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], 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
-> [FloatBind] -> CoreExpr -> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go :: Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats (Tick Tickish Id
t CoreExpr
expr) ConCont
cont
| Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t) = Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Cast CoreExpr
expr Coercion
co1) (CC [CoreExpr]
args Coercion
co2)
| Just ([CoreExpr]
args', 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
= case MCoercion
m_co1' of
MCo Coercion
co1' -> Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' (Coercion
co1' Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2))
MCoercion
MRefl -> Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
expr ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args' Coercion
co2)
go Either InScopeSet Subst
subst [FloatBind]
floats (App CoreExpr
fun CoreExpr
arg) (CC [CoreExpr]
args Coercion
co)
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst [FloatBind]
floats CoreExpr
fun ([CoreExpr] -> Coercion -> ConCont
CC (Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
arg CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Lam Id
bndr CoreExpr
body) (CC (CoreExpr
arg:[CoreExpr]
args) Coercion
co)
| CoreExpr -> Bool
exprIsTrivial CoreExpr
arg
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], 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
bndr CoreExpr
arg) [FloatBind]
floats CoreExpr
body ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args Coercion
co)
| Bool
otherwise
= let (Either a Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either a 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 -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
arg)
in Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
forall a. Either a Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
body ([CoreExpr] -> Coercion -> ConCont
CC [CoreExpr]
args Coercion
co)
go Either InScopeSet Subst
subst [FloatBind]
floats (Let (NonRec Id
bndr CoreExpr
rhs) CoreExpr
expr) ConCont
cont
= let rhs' :: CoreExpr
rhs' = Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
rhs
(Either a Subst
subst', Id
bndr') = Either InScopeSet Subst -> Id -> (Either a 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 -> CoreExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
rhs')
in Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
forall a. Either a Subst
subst' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
expr ConCont
cont
go Either InScopeSet Subst
subst [FloatBind]
floats (Case CoreExpr
scrut Id
b Type
_ [(AltCon
con, [Id]
vars, CoreExpr
expr)]) ConCont
cont
= let
scrut' :: CoreExpr
scrut' = Either InScopeSet Subst -> CoreExpr -> CoreExpr
forall a. Either a Subst -> CoreExpr -> CoreExpr
subst_expr Either InScopeSet Subst
subst CoreExpr
scrut
(Either a Subst
subst', Id
b') = Either InScopeSet Subst -> Id -> (Either a 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
forall a. Either a Subst
subst' [Id]
vars
float :: FloatBind
float = CoreExpr -> Id -> AltCon -> [Id] -> FloatBind
FloatCase CoreExpr
scrut' Id
b' AltCon
con [Id]
vars'
in
Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go Either InScopeSet Subst
subst'' (FloatBind
floatFloatBind -> [FloatBind] -> [FloatBind]
forall a. a -> [a] -> [a]
:[FloatBind]
floats) CoreExpr
expr ConCont
cont
go (Right Subst
sub) [FloatBind]
floats (Var Id
v) ConCont
cont
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left (Subst -> InScopeSet
substInScope Subst
sub))
[FloatBind]
floats
(SDoc -> Subst -> Id -> CoreExpr
lookupIdSubst (String -> SDoc
text String
"exprIsConApp" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr) Subst
sub Id
v)
ConCont
cont
go (Left InScopeSet
in_scope) [FloatBind]
floats (Var Id
fun) cont :: ConCont
cont@(CC [CoreExpr]
args Coercion
co)
| Just 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
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
con [CoreExpr]
args Coercion
co
| Id -> Bool
isDataConWrapId Id
fun
, let rhs :: CoreExpr
rhs = Unfolding -> CoreExpr
uf_tmpl (IdUnfoldingFun
realIdUnfolding Id
fun)
= Either InScopeSet Subst
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope) [FloatBind]
floats CoreExpr
rhs ConCont
cont
| 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
, 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)
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
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 String
"exprIsConApp1") Subst
subst) [CoreExpr]
dfun_args) Coercion
co
| Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
, Just 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
-> [FloatBind]
-> CoreExpr
-> ConCont
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
go (InScopeSet -> Either InScopeSet Subst
forall a b. a -> Either a b
Left InScopeSet
in_scope') [FloatBind]
floats CoreExpr
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)
, [CoreExpr
arg] <- [CoreExpr]
args
, Just (LitString ByteString
str) <- (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet
in_scope, IdUnfoldingFun
id_unf) CoreExpr
arg
= InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
floats (Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]))
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a b. (a -> b) -> a -> b
$
Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral Id
fun ByteString
str Coercion
co
where
unfolding :: Unfolding
unfolding = IdUnfoldingFun
id_unf Id
fun
go Either InScopeSet Subst
_ [FloatBind]
_ CoreExpr
_ ConCont
_ = Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall a. Maybe a
Nothing
succeedWith :: InScopeSet -> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith :: InScopeSet
-> [FloatBind]
-> Maybe (DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
succeedWith InScopeSet
in_scope [FloatBind]
rev_floats Maybe (DataCon, [Type], [CoreExpr])
x
= do { (DataCon
con, [Type]
tys, [CoreExpr]
args) <- Maybe (DataCon, [Type], [CoreExpr])
x
; let floats :: [FloatBind]
floats = [FloatBind] -> [FloatBind]
forall a. [a] -> [a]
reverse [FloatBind]
rev_floats
; (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return (InScopeSet
in_scope, [FloatBind]
floats, DataCon
con, [Type]
tys, [CoreExpr]
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
CoreSubst.substCo Subst
s Coercion
co
subst_expr :: Either a Subst -> CoreExpr -> CoreExpr
subst_expr (Left {}) CoreExpr
e = CoreExpr
e
subst_expr (Right Subst
s) CoreExpr
e = SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr (String -> SDoc
text String
"exprIsConApp2") Subst
s CoreExpr
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 in_scope -> InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
Right 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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 -> CoreExpr -> Either a Subst
extend (Left InScopeSet
in_scope) Id
v 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 Subst
s) Id
v 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)
dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
-> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral :: Id -> ByteString -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
dealWithStringLiteral Id
_ ByteString
str 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 Id
fun ByteString
str 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
bytesFS (FastString -> FastString
tailFS FastString
strFS)
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
exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe :: (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe env :: (InScopeSet, IdUnfoldingFun)
env@(InScopeSet
_, IdUnfoldingFun
id_unf) CoreExpr
e
= case CoreExpr
e of
Lit Literal
l -> Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
l
Tick Tickish Id
_ CoreExpr
e' -> (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env CoreExpr
e'
Var Id
v | Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
v)
-> (InScopeSet, IdUnfoldingFun) -> CoreExpr -> Maybe Literal
exprIsLiteral_maybe (InScopeSet, IdUnfoldingFun)
env CoreExpr
rhs
CoreExpr
_ -> Maybe Literal
forall a. Maybe a
Nothing
exprIsLambda_maybe :: InScopeEnv -> CoreExpr
-> Maybe (Var, CoreExpr,[Tickish Id])
exprIsLambda_maybe :: (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [Tickish Id])
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ (Lam Id
x CoreExpr
e)
= (Id, CoreExpr, [Tickish Id]) -> Maybe (Id, CoreExpr, [Tickish Id])
forall a. a -> Maybe a
Just (Id
x, CoreExpr
e, [])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Tick Tickish Id
t CoreExpr
e)
| Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
t
, Just (Id
x, CoreExpr
e, [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)
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) (Cast CoreExpr
casted_e Coercion
co)
| Just (Id
x, CoreExpr
e,[Tickish Id]
ts) <- (InScopeSet, IdUnfoldingFun)
-> CoreExpr -> Maybe (Id, CoreExpr, [Tickish Id])
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
casted_e
, 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 (Id
x',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)
=
Maybe (Id, CoreExpr, [Tickish Id])
res
exprIsLambda_maybe (InScopeSet
in_scope_set, IdUnfoldingFun
id_unf) CoreExpr
e
| (Var Id
f, [CoreExpr]
as, [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
, Just CoreExpr
rhs <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (IdUnfoldingFun
id_unf Id
f)
, 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)
, Just (Id
x', CoreExpr
e'', [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')
=
Maybe (Id, CoreExpr, [Tickish Id])
res
exprIsLambda_maybe (InScopeSet, IdUnfoldingFun)
_ CoreExpr
_e
=
Maybe (Id, CoreExpr, [Tickish Id])
forall a. Maybe a
Nothing
pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
pushCoArgs :: Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs Coercion
co [] = ([CoreExpr], MCoercion) -> Maybe ([CoreExpr], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Coercion -> MCoercion
MCo Coercion
co)
pushCoArgs Coercion
co (CoreExpr
arg:[CoreExpr]
args) = do { (CoreExpr
arg', MCoercion
m_co1) <- Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg Coercion
co CoreExpr
arg
; case MCoercion
m_co1 of
MCo Coercion
co1 -> do { ([CoreExpr]
args', 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) }
MCoercion
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)
pushCoArg :: Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg Coercion
co (Type Type
ty) = do { (Type
ty', 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 Coercion
co CoreExpr
val_arg = do { (Coercion
arg_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)
pushCoTyArg :: Coercion -> Type -> Maybe (Type, MCoercion)
pushCoTyArg Coercion
co Type
ty
| 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 Type
tyL Type
tyR = Coercion -> Pair Type
coercionKind Coercion
co
co1 :: Coercion
co1 = Coercion -> Coercion
mkSymCo (HasDebugCallStack => Role -> Int -> Coercion -> Coercion
Role -> Int -> Coercion -> Coercion
mkNthCo Role
Nominal Int
0 Coercion
co)
co2 :: Coercion
co2 = Coercion -> Coercion -> Coercion
mkInstCo Coercion
co (Role -> Type -> Coercion -> Coercion
mkGReflLeftCo Role
Nominal Type
ty Coercion
co1)
pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)
pushCoValArg :: Coercion -> Maybe (Coercion, MCoercion)
pushCoValArg Coercion
co
| 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
, (Coercion
co1, Coercion
co2) <- HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Representational Coercion
co
= 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 Type
tyL Type
tyR = Coercion -> Pair Type
coercionKind Coercion
co
pushCoercionIntoLambda
:: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
pushCoercionIntoLambda :: InScopeSet -> Id -> CoreExpr -> Coercion -> Maybe (Id, CoreExpr)
pushCoercionIntoLambda InScopeSet
in_scope Id
x CoreExpr
e Coercion
co
| ASSERT(not (isTyVar x) && not (isCoVar x)) True
, Pair Type
s1s2 Type
t1t2 <- Coercion -> Pair Type
coercionKind Coercion
co
, Just (Type
_s1,Type
_s2) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
s1s2
, Just (Type
t1,Type
_t2) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
t1t2
= let (Coercion
co1, Coercion
co2) = HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Representational Coercion
co
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 String
"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 String
"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]
, [CoreExpr])
pushCoDataCon :: DataCon
-> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
dc [CoreExpr]
dc_args Coercion
co
| Coercion -> Bool
isReflCo Coercion
co Bool -> Bool -> Bool
|| Type
from_ty Type -> Type -> Bool
`eqType` Type
to_ty
, let ([CoreExpr]
univ_ty_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 (TyCon
to_tc, [Type]
to_tc_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
to_ty
, TyCon
to_tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
dc
= 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
([CoreExpr]
ex_args, [CoreExpr]
val_args) = [Id] -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
dc_ex_tcvars [CoreExpr]
non_univ_args
omegas :: [Coercion]
omegas = Int -> Coercion -> [Role] -> [Coercion]
decomposeCo Int
tc_arity Coercion
co (TyCon -> [Role]
tyConRolesRepresentational TyCon
to_tc)
(Type -> Coercion
psi_subst, [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)
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 Type
arg_ty 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 Type
from_ty Type
to_ty = Coercion -> Pair Type
coercionKind Coercion
co
collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
collectBindersPushingCo :: CoreExpr -> ([Id], CoreExpr)
collectBindersPushingCo CoreExpr
e
= [Id] -> CoreExpr -> ([Id], CoreExpr)
go [] CoreExpr
e
where
go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
go :: [Id] -> CoreExpr -> ([Id], CoreExpr)
go [Id]
bs (Lam Id
b CoreExpr
e) = [Id] -> CoreExpr -> ([Id], CoreExpr)
go (Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs) CoreExpr
e
go [Id]
bs (Cast CoreExpr
e Coercion
co) = [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c [Id]
bs CoreExpr
e Coercion
co
go [Id]
bs CoreExpr
e = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreExpr
e)
go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
go_c :: [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c [Id]
bs (Cast CoreExpr
e Coercion
co1) Coercion
co2 = [Id] -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_c [Id]
bs CoreExpr
e (Coercion
co1 Coercion -> Coercion -> Coercion
`mkTransCo` Coercion
co2)
go_c [Id]
bs (Lam Id
b CoreExpr
e) Coercion
co = [Id] -> Id -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_lam [Id]
bs Id
b CoreExpr
e Coercion
co
go_c [Id]
bs CoreExpr
e Coercion
co = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
e Coercion
co)
go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
go_lam :: [Id] -> Id -> CoreExpr -> Coercion -> ([Id], CoreExpr)
go_lam [Id]
bs Id
b CoreExpr
e Coercion
co
| Id -> Bool
isTyVar Id
b
, let Pair Type
tyL 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 Int
0 Coercion
co)
= [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 Type
tyL 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 Int
0 Coercion
co)
, 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 Type
tyL Type
tyR = Coercion -> Pair Type
coercionKind Coercion
co
, ASSERT( isFunTy tyL) isFunTy tyR
, (Coercion
co_arg, Coercion
co_res) <- HasDebugCallStack => Role -> Coercion -> (Coercion, Coercion)
Role -> Coercion -> (Coercion, Coercion)
decomposeFunCo Role
Representational Coercion
co
, Coercion -> Bool
isReflCo Coercion
co_arg
= [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)