{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Opt.Arity
( manifestArity, joinRhsArity, exprArity, typeArity
, exprEtaExpandArity, findRhsArity
, etaExpand, etaExpandAT
, exprBotStrictness_maybe
, ArityType(..), mkBotArityType, mkTopArityType, expandableArityType
, arityTypeArity, maxWithArity, idArityType
, etaExpandToJoinPoint, etaExpandToJoinPointRule
, pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg
, pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Driver.Ppr
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Core.Subst as Core
import GHC.Core.Type as Type
import GHC.Core.Coercion as Type
import GHC.Core.DataCon
import GHC.Core.TyCon ( tyConArity )
import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
import GHC.Core.Predicate ( isDictTy )
import GHC.Core.Multiplicity
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Builtin.Uniques
import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Utils.Misc
manifestArity :: CoreExpr -> Arity
manifestArity :: CoreExpr -> Arity
manifestArity (Lam CoreBndr
v CoreExpr
e) | CoreBndr -> Bool
isId CoreBndr
v = Arity
1 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ CoreExpr -> Arity
manifestArity CoreExpr
e
| Bool
otherwise = CoreExpr -> Arity
manifestArity CoreExpr
e
manifestArity (Tick CoreTickish
t CoreExpr
e) | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = CoreExpr -> Arity
manifestArity CoreExpr
e
manifestArity (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Arity
manifestArity CoreExpr
e
manifestArity CoreExpr
_ = Arity
0
joinRhsArity :: CoreExpr -> JoinArity
joinRhsArity :: CoreExpr -> Arity
joinRhsArity (Lam CoreBndr
_ CoreExpr
e) = Arity
1 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ CoreExpr -> Arity
joinRhsArity CoreExpr
e
joinRhsArity CoreExpr
_ = Arity
0
exprArity :: CoreExpr -> Arity
exprArity :: CoreExpr -> Arity
exprArity CoreExpr
e = CoreExpr -> Arity
go CoreExpr
e
where
go :: CoreExpr -> Arity
go (Var CoreBndr
v) = CoreBndr -> Arity
idArity CoreBndr
v
go (Lam CoreBndr
x CoreExpr
e) | CoreBndr -> Bool
isId CoreBndr
x = CoreExpr -> Arity
go CoreExpr
e Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1
| Bool
otherwise = CoreExpr -> Arity
go CoreExpr
e
go (Tick CoreTickish
t CoreExpr
e) | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = CoreExpr -> Arity
go CoreExpr
e
go (Cast CoreExpr
e CoercionR
co) = Arity -> Type -> Arity
trim_arity (CoreExpr -> Arity
go CoreExpr
e) (CoercionR -> Type
coercionRKind CoercionR
co)
go (App CoreExpr
e (Type Type
_)) = CoreExpr -> Arity
go CoreExpr
e
go (App CoreExpr
f CoreExpr
a) | CoreExpr -> Bool
exprIsTrivial CoreExpr
a = (CoreExpr -> Arity
go CoreExpr
f Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1) Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`max` Arity
0
go CoreExpr
_ = Arity
0
trim_arity :: Arity -> Type -> Arity
trim_arity :: Arity -> Type -> Arity
trim_arity Arity
arity Type
ty = Arity
arity Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`min` [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (Type -> [OneShotInfo]
typeArity Type
ty)
typeArity :: Type -> [OneShotInfo]
typeArity :: Type -> [OneShotInfo]
typeArity Type
ty
= RecTcChecker -> Type -> [OneShotInfo]
go RecTcChecker
initRecTc Type
ty
where
go :: RecTcChecker -> Type -> [OneShotInfo]
go RecTcChecker
rec_nts Type
ty
| Just (CoreBndr
_, Type
ty') <- Type -> Maybe (CoreBndr, Type)
splitForAllTyCoVar_maybe Type
ty
= RecTcChecker -> Type -> [OneShotInfo]
go RecTcChecker
rec_nts Type
ty'
| Just (Type
_,Type
arg,Type
res) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
ty
= Type -> OneShotInfo
typeOneShot Type
arg OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: RecTcChecker -> Type -> [OneShotInfo]
go RecTcChecker
rec_nts Type
res
| Just (TyCon
tc,[Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Just (Type
ty', CoercionR
_) <- TyCon -> [Type] -> Maybe (Type, CoercionR)
instNewTyCon_maybe TyCon
tc [Type]
tys
, Just RecTcChecker
rec_nts' <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc
= RecTcChecker -> Type -> [OneShotInfo]
go RecTcChecker
rec_nts' Type
ty'
| Bool
otherwise
= []
exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
exprBotStrictness_maybe CoreExpr
e
= case ArityType -> Maybe Arity
getBotArity (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
botStrictnessArityEnv CoreExpr
e) of
Maybe Arity
Nothing -> Maybe (Arity, StrictSig)
forall a. Maybe a
Nothing
Just Arity
ar -> (Arity, StrictSig) -> Maybe (Arity, StrictSig)
forall a. a -> Maybe a
Just (Arity
ar, Arity -> StrictSig
sig Arity
ar)
where
sig :: Arity -> StrictSig
sig Arity
ar = [Demand] -> Divergence -> StrictSig
mkClosedStrictSig (Arity -> Demand -> [Demand]
forall a. Arity -> a -> [a]
replicate Arity
ar Demand
topDmd) Divergence
botDiv
data ArityType
= AT ![OneShotInfo] !Divergence
deriving ArityType -> ArityType -> Bool
(ArityType -> ArityType -> Bool)
-> (ArityType -> ArityType -> Bool) -> Eq ArityType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArityType -> ArityType -> Bool
$c/= :: ArityType -> ArityType -> Bool
== :: ArityType -> ArityType -> Bool
$c== :: ArityType -> ArityType -> Bool
Eq
instance Outputable ArityType where
ppr :: ArityType -> SDoc
ppr (AT [OneShotInfo]
oss Divergence
div)
| [OneShotInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OneShotInfo]
oss = Divergence -> SDoc
pp_div Divergence
div
| Bool
otherwise = Char -> SDoc
char Char
'\\' SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
hcat ((OneShotInfo -> SDoc) -> [OneShotInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map OneShotInfo -> SDoc
pp_os [OneShotInfo]
oss) SDoc -> SDoc -> SDoc
<> SDoc
dot SDoc -> SDoc -> SDoc
<> Divergence -> SDoc
pp_div Divergence
div
where
pp_div :: Divergence -> SDoc
pp_div Divergence
Diverges = Char -> SDoc
char Char
'⊥'
pp_div Divergence
ExnOrDiv = Char -> SDoc
char Char
'x'
pp_div Divergence
Dunno = Char -> SDoc
char Char
'T'
pp_os :: OneShotInfo -> SDoc
pp_os OneShotInfo
OneShotLam = Char -> SDoc
char Char
'1'
pp_os OneShotInfo
NoOneShotInfo = Char -> SDoc
char Char
'?'
mkBotArityType :: [OneShotInfo] -> ArityType
mkBotArityType :: [OneShotInfo] -> ArityType
mkBotArityType [OneShotInfo]
oss = [OneShotInfo] -> Divergence -> ArityType
AT [OneShotInfo]
oss Divergence
botDiv
botArityType :: ArityType
botArityType :: ArityType
botArityType = [OneShotInfo] -> ArityType
mkBotArityType []
mkTopArityType :: [OneShotInfo] -> ArityType
mkTopArityType :: [OneShotInfo] -> ArityType
mkTopArityType [OneShotInfo]
oss = [OneShotInfo] -> Divergence -> ArityType
AT [OneShotInfo]
oss Divergence
topDiv
topArityType :: ArityType
topArityType :: ArityType
topArityType = [OneShotInfo] -> ArityType
mkTopArityType []
arityTypeArity :: ArityType -> Arity
arityTypeArity :: ArityType -> Arity
arityTypeArity (AT [OneShotInfo]
oss Divergence
_) = [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [OneShotInfo]
oss
expandableArityType :: ArityType -> Bool
expandableArityType :: ArityType -> Bool
expandableArityType ArityType
at = ArityType -> Arity
arityTypeArity ArityType
at Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
/= Arity
0
isDeadEndArityType :: ArityType -> Bool
isDeadEndArityType :: ArityType -> Bool
isDeadEndArityType (AT [OneShotInfo]
_ Divergence
div) = Divergence -> Bool
isDeadEndDiv Divergence
div
maxWithArity :: ArityType -> Arity -> ArityType
maxWithArity :: ArityType -> Arity -> ArityType
maxWithArity at :: ArityType
at@(AT [OneShotInfo]
oss Divergence
div) !Arity
ar
| ArityType -> Bool
isDeadEndArityType ArityType
at = ArityType
at
| [OneShotInfo]
oss [OneShotInfo] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthAtLeast` Arity
ar = ArityType
at
| Bool
otherwise = [OneShotInfo] -> Divergence -> ArityType
AT (Arity -> [OneShotInfo] -> [OneShotInfo]
forall a. Arity -> [a] -> [a]
take Arity
ar ([OneShotInfo] -> [OneShotInfo]) -> [OneShotInfo] -> [OneShotInfo]
forall a b. (a -> b) -> a -> b
$ [OneShotInfo]
oss [OneShotInfo] -> [OneShotInfo] -> [OneShotInfo]
forall a. [a] -> [a] -> [a]
++ OneShotInfo -> [OneShotInfo]
forall a. a -> [a]
repeat OneShotInfo
NoOneShotInfo) Divergence
div
minWithArity :: ArityType -> Arity -> ArityType
minWithArity :: ArityType -> Arity -> ArityType
minWithArity at :: ArityType
at@(AT [OneShotInfo]
oss Divergence
_) Arity
ar
| [OneShotInfo]
oss [OneShotInfo] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthAtMost` Arity
ar = ArityType
at
| Bool
otherwise = [OneShotInfo] -> Divergence -> ArityType
AT (Arity -> [OneShotInfo] -> [OneShotInfo]
forall a. Arity -> [a] -> [a]
take Arity
ar [OneShotInfo]
oss) Divergence
topDiv
takeWhileOneShot :: ArityType -> ArityType
takeWhileOneShot :: ArityType -> ArityType
takeWhileOneShot (AT [OneShotInfo]
oss Divergence
div)
| Divergence -> Bool
isDeadEndDiv Divergence
div = [OneShotInfo] -> Divergence -> ArityType
AT ((OneShotInfo -> Bool) -> [OneShotInfo] -> [OneShotInfo]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile OneShotInfo -> Bool
isOneShotInfo [OneShotInfo]
oss) Divergence
topDiv
| Bool
otherwise = [OneShotInfo] -> Divergence -> ArityType
AT ((OneShotInfo -> Bool) -> [OneShotInfo] -> [OneShotInfo]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile OneShotInfo -> Bool
isOneShotInfo [OneShotInfo]
oss) Divergence
div
exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
exprEtaExpandArity DynFlags
dflags CoreExpr
e = ArityEnv -> CoreExpr -> ArityType
arityType (DynFlags -> ArityEnv
etaExpandArityEnv DynFlags
dflags) CoreExpr
e
getBotArity :: ArityType -> Maybe Arity
getBotArity :: ArityType -> Maybe Arity
getBotArity (AT [OneShotInfo]
oss Divergence
div)
| Divergence -> Bool
isDeadEndDiv Divergence
div = Arity -> Maybe Arity
forall a. a -> Maybe a
Just (Arity -> Maybe Arity) -> Arity -> Maybe Arity
forall a b. (a -> b) -> a -> b
$ [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [OneShotInfo]
oss
| Bool
otherwise = Maybe Arity
forall a. Maybe a
Nothing
findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
findRhsArity :: DynFlags -> CoreBndr -> CoreExpr -> Arity -> ArityType
findRhsArity DynFlags
dflags CoreBndr
bndr CoreExpr
rhs Arity
old_arity
= Arity -> ArityType -> ArityType
go Arity
0 ArityType
botArityType
where
go :: Int -> ArityType -> ArityType
go :: Arity -> ArityType -> ArityType
go !Arity
n cur_at :: ArityType
cur_at@(AT [OneShotInfo]
oss Divergence
div)
| Bool -> Bool
not (Divergence -> Bool
isDeadEndDiv Divergence
div)
, [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [OneShotInfo]
oss Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
old_arity = ArityType
cur_at
| ArityType
next_at ArityType -> ArityType -> Bool
forall a. Eq a => a -> a -> Bool
== ArityType
cur_at = ArityType
cur_at
| Bool
otherwise =
WARN( debugIsOn && n > 2, text "Exciting arity"
$$ nest 2 (
ppr bndr <+> ppr cur_at <+> ppr next_at
$$ ppr rhs) )
Arity -> ArityType -> ArityType
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) ArityType
next_at
where
next_at :: ArityType
next_at = ArityType -> ArityType
step ArityType
cur_at
step :: ArityType -> ArityType
step :: ArityType -> ArityType
step ArityType
at =
ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
rhs
where
env :: ArityEnv
env = ArityEnv -> CoreBndr -> ArityType -> ArityEnv
extendSigEnv (DynFlags -> ArityEnv
findRhsArityEnv DynFlags
dflags) CoreBndr
bndr ArityType
at
arityLam :: Id -> ArityType -> ArityType
arityLam :: CoreBndr -> ArityType -> ArityType
arityLam CoreBndr
id (AT [OneShotInfo]
oss Divergence
div) = [OneShotInfo] -> Divergence -> ArityType
AT (CoreBndr -> OneShotInfo
idStateHackOneShotInfo CoreBndr
id OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: [OneShotInfo]
oss) Divergence
div
floatIn :: Bool -> ArityType -> ArityType
floatIn :: Bool -> ArityType -> ArityType
floatIn Bool
cheap ArityType
at
| ArityType -> Bool
isDeadEndArityType ArityType
at Bool -> Bool -> Bool
|| Bool
cheap = ArityType
at
| Bool
otherwise = ArityType -> ArityType
takeWhileOneShot ArityType
at
arityApp :: ArityType -> Bool -> ArityType
arityApp :: ArityType -> Bool -> ArityType
arityApp (AT (OneShotInfo
_:[OneShotInfo]
oss) Divergence
div) Bool
cheap = Bool -> ArityType -> ArityType
floatIn Bool
cheap ([OneShotInfo] -> Divergence -> ArityType
AT [OneShotInfo]
oss Divergence
div)
arityApp ArityType
at Bool
_ = ArityType
at
andArityType :: ArityType -> ArityType -> ArityType
andArityType :: ArityType -> ArityType -> ArityType
andArityType (AT (OneShotInfo
os1:[OneShotInfo]
oss1) Divergence
div1) (AT (OneShotInfo
os2:[OneShotInfo]
oss2) Divergence
div2)
| AT [OneShotInfo]
oss' Divergence
div' <- ArityType -> ArityType -> ArityType
andArityType ([OneShotInfo] -> Divergence -> ArityType
AT [OneShotInfo]
oss1 Divergence
div1) ([OneShotInfo] -> Divergence -> ArityType
AT [OneShotInfo]
oss2 Divergence
div2)
= [OneShotInfo] -> Divergence -> ArityType
AT ((OneShotInfo
os1 OneShotInfo -> OneShotInfo -> OneShotInfo
`bestOneShot` OneShotInfo
os2) OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: [OneShotInfo]
oss') Divergence
div'
andArityType (AT [] Divergence
div1) ArityType
at2
| Divergence -> Bool
isDeadEndDiv Divergence
div1 = ArityType
at2
| Bool
otherwise = ArityType -> ArityType
takeWhileOneShot ArityType
at2
andArityType ArityType
at1 (AT [] Divergence
div2)
| Divergence -> Bool
isDeadEndDiv Divergence
div2 = ArityType
at1
| Bool
otherwise = ArityType -> ArityType
takeWhileOneShot ArityType
at1
data AnalysisMode
= BotStrictness
| EtaExpandArity { AnalysisMode -> Bool
am_ped_bot :: !Bool
, AnalysisMode -> Bool
am_dicts_cheap :: !Bool }
| FindRhsArity { am_ped_bot :: !Bool
, am_dicts_cheap :: !Bool
, AnalysisMode -> IdEnv ArityType
am_sigs :: !(IdEnv ArityType) }
data ArityEnv
= AE
{ ArityEnv -> AnalysisMode
ae_mode :: !AnalysisMode
, ArityEnv -> IdSet
ae_joins :: !IdSet
}
botStrictnessArityEnv :: ArityEnv
botStrictnessArityEnv :: ArityEnv
botStrictnessArityEnv = AE :: AnalysisMode -> IdSet -> ArityEnv
AE { ae_mode :: AnalysisMode
ae_mode = AnalysisMode
BotStrictness, ae_joins :: IdSet
ae_joins = IdSet
emptyVarSet }
etaExpandArityEnv :: DynFlags -> ArityEnv
etaExpandArityEnv :: DynFlags -> ArityEnv
etaExpandArityEnv DynFlags
dflags
= AE :: AnalysisMode -> IdSet -> ArityEnv
AE { ae_mode :: AnalysisMode
ae_mode = EtaExpandArity :: Bool -> Bool -> AnalysisMode
EtaExpandArity { am_ped_bot :: Bool
am_ped_bot = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PedanticBottoms DynFlags
dflags
, am_dicts_cheap :: Bool
am_dicts_cheap = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DictsCheap DynFlags
dflags }
, ae_joins :: IdSet
ae_joins = IdSet
emptyVarSet }
findRhsArityEnv :: DynFlags -> ArityEnv
findRhsArityEnv :: DynFlags -> ArityEnv
findRhsArityEnv DynFlags
dflags
= AE :: AnalysisMode -> IdSet -> ArityEnv
AE { ae_mode :: AnalysisMode
ae_mode = FindRhsArity :: Bool -> Bool -> IdEnv ArityType -> AnalysisMode
FindRhsArity { am_ped_bot :: Bool
am_ped_bot = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PedanticBottoms DynFlags
dflags
, am_dicts_cheap :: Bool
am_dicts_cheap = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DictsCheap DynFlags
dflags
, am_sigs :: IdEnv ArityType
am_sigs = IdEnv ArityType
forall a. VarEnv a
emptyVarEnv }
, ae_joins :: IdSet
ae_joins = IdSet
emptyVarSet }
modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
modifySigEnv IdEnv ArityType -> IdEnv ArityType
f env :: ArityEnv
env@AE { ae_mode :: ArityEnv -> AnalysisMode
ae_mode = am :: AnalysisMode
am@FindRhsArity{am_sigs :: AnalysisMode -> IdEnv ArityType
am_sigs = IdEnv ArityType
sigs} } =
ArityEnv
env { ae_mode :: AnalysisMode
ae_mode = AnalysisMode
am { am_sigs :: IdEnv ArityType
am_sigs = IdEnv ArityType -> IdEnv ArityType
f IdEnv ArityType
sigs } }
modifySigEnv IdEnv ArityType -> IdEnv ArityType
_ ArityEnv
env = ArityEnv
env
{-# INLINE modifySigEnv #-}
del_sig_env :: Id -> ArityEnv -> ArityEnv
del_sig_env :: CoreBndr -> ArityEnv -> ArityEnv
del_sig_env CoreBndr
id = (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
modifySigEnv (\IdEnv ArityType
sigs -> IdEnv ArityType -> CoreBndr -> IdEnv ArityType
forall a. VarEnv a -> CoreBndr -> VarEnv a
delVarEnv IdEnv ArityType
sigs CoreBndr
id)
{-# INLINE del_sig_env #-}
del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv
del_sig_env_list :: [CoreBndr] -> ArityEnv -> ArityEnv
del_sig_env_list [CoreBndr]
ids = (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
modifySigEnv (\IdEnv ArityType
sigs -> IdEnv ArityType -> [CoreBndr] -> IdEnv ArityType
forall a. VarEnv a -> [CoreBndr] -> VarEnv a
delVarEnvList IdEnv ArityType
sigs [CoreBndr]
ids)
{-# INLINE del_sig_env_list #-}
del_join_env :: JoinId -> ArityEnv -> ArityEnv
del_join_env :: CoreBndr -> ArityEnv -> ArityEnv
del_join_env CoreBndr
id env :: ArityEnv
env@(AE { ae_joins :: ArityEnv -> IdSet
ae_joins = IdSet
joins })
= ArityEnv
env { ae_joins :: IdSet
ae_joins = IdSet -> CoreBndr -> IdSet
delVarSet IdSet
joins CoreBndr
id }
{-# INLINE del_join_env #-}
del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv
del_join_env_list :: [CoreBndr] -> ArityEnv -> ArityEnv
del_join_env_list [CoreBndr]
ids env :: ArityEnv
env@(AE { ae_joins :: ArityEnv -> IdSet
ae_joins = IdSet
joins })
= ArityEnv
env { ae_joins :: IdSet
ae_joins = IdSet -> [CoreBndr] -> IdSet
delVarSetList IdSet
joins [CoreBndr]
ids }
{-# INLINE del_join_env_list #-}
extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv
extendJoinEnv :: ArityEnv -> [CoreBndr] -> ArityEnv
extendJoinEnv env :: ArityEnv
env@(AE { ae_joins :: ArityEnv -> IdSet
ae_joins = IdSet
joins }) [CoreBndr]
join_ids
= [CoreBndr] -> ArityEnv -> ArityEnv
del_sig_env_list [CoreBndr]
join_ids
(ArityEnv -> ArityEnv) -> ArityEnv -> ArityEnv
forall a b. (a -> b) -> a -> b
$ ArityEnv
env { ae_joins :: IdSet
ae_joins = IdSet
joins IdSet -> [CoreBndr] -> IdSet
`extendVarSetList` [CoreBndr]
join_ids }
extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv
extendSigEnv :: ArityEnv -> CoreBndr -> ArityType -> ArityEnv
extendSigEnv ArityEnv
env CoreBndr
id ArityType
ar_ty
= CoreBndr -> ArityEnv -> ArityEnv
del_join_env CoreBndr
id ((IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
modifySigEnv (\IdEnv ArityType
sigs -> IdEnv ArityType -> CoreBndr -> ArityType -> IdEnv ArityType
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv IdEnv ArityType
sigs CoreBndr
id ArityType
ar_ty) ArityEnv
env)
delInScope :: ArityEnv -> Id -> ArityEnv
delInScope :: ArityEnv -> CoreBndr -> ArityEnv
delInScope ArityEnv
env CoreBndr
id = CoreBndr -> ArityEnv -> ArityEnv
del_join_env CoreBndr
id (ArityEnv -> ArityEnv) -> ArityEnv -> ArityEnv
forall a b. (a -> b) -> a -> b
$ CoreBndr -> ArityEnv -> ArityEnv
del_sig_env CoreBndr
id ArityEnv
env
delInScopeList :: ArityEnv -> [Id] -> ArityEnv
delInScopeList :: ArityEnv -> [CoreBndr] -> ArityEnv
delInScopeList ArityEnv
env [CoreBndr]
ids = [CoreBndr] -> ArityEnv -> ArityEnv
del_join_env_list [CoreBndr]
ids (ArityEnv -> ArityEnv) -> ArityEnv -> ArityEnv
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> ArityEnv -> ArityEnv
del_sig_env_list [CoreBndr]
ids ArityEnv
env
lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType
lookupSigEnv :: ArityEnv -> CoreBndr -> Maybe ArityType
lookupSigEnv AE{ ae_mode :: ArityEnv -> AnalysisMode
ae_mode = AnalysisMode
mode } CoreBndr
id = case AnalysisMode
mode of
AnalysisMode
BotStrictness -> Maybe ArityType
forall a. Maybe a
Nothing
EtaExpandArity{} -> Maybe ArityType
forall a. Maybe a
Nothing
FindRhsArity{ am_sigs :: AnalysisMode -> IdEnv ArityType
am_sigs = IdEnv ArityType
sigs } -> IdEnv ArityType -> CoreBndr -> Maybe ArityType
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdEnv ArityType
sigs CoreBndr
id
pedanticBottoms :: ArityEnv -> Bool
pedanticBottoms :: ArityEnv -> Bool
pedanticBottoms AE{ ae_mode :: ArityEnv -> AnalysisMode
ae_mode = AnalysisMode
mode } = case AnalysisMode
mode of
AnalysisMode
BotStrictness -> Bool
True
EtaExpandArity{ am_ped_bot :: AnalysisMode -> Bool
am_ped_bot = Bool
ped_bot } -> Bool
ped_bot
FindRhsArity{ am_ped_bot :: AnalysisMode -> Bool
am_ped_bot = Bool
ped_bot } -> Bool
ped_bot
myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap AE{ae_mode :: ArityEnv -> AnalysisMode
ae_mode = AnalysisMode
mode} CoreExpr
e Maybe Type
mb_ty = case AnalysisMode
mode of
AnalysisMode
BotStrictness -> Bool
False
AnalysisMode
_ -> Bool
cheap_dict Bool -> Bool -> Bool
|| CoreExpr -> Bool
cheap_fun CoreExpr
e
where
cheap_dict :: Bool
cheap_dict = AnalysisMode -> Bool
am_dicts_cheap AnalysisMode
mode Bool -> Bool -> Bool
&& (Type -> Bool) -> Maybe Type -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Bool
isDictTy Maybe Type
mb_ty Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
cheap_fun :: CoreExpr -> Bool
cheap_fun CoreExpr
e = case AnalysisMode
mode of
#if __GLASGOW_HASKELL__ <= 900
AnalysisMode
BotStrictness -> String -> Bool
forall a. String -> a
panic String
"impossible"
#endif
EtaExpandArity{} -> CoreExpr -> Bool
exprIsCheap CoreExpr
e
FindRhsArity{am_sigs :: AnalysisMode -> IdEnv ArityType
am_sigs = IdEnv ArityType
sigs} -> CheapAppFun -> CoreExpr -> Bool
exprIsCheapX (IdEnv ArityType -> CheapAppFun
myIsCheapApp IdEnv ArityType
sigs) CoreExpr
e
myIsCheapApp :: IdEnv ArityType -> CheapAppFun
myIsCheapApp :: IdEnv ArityType -> CheapAppFun
myIsCheapApp IdEnv ArityType
sigs CoreBndr
fn Arity
n_val_args = case IdEnv ArityType -> CoreBndr -> Maybe ArityType
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdEnv ArityType
sigs CoreBndr
fn of
Maybe ArityType
Nothing -> CheapAppFun
isCheapApp CoreBndr
fn Arity
n_val_args
Just (AT [OneShotInfo]
oss Divergence
div)
| Divergence -> Bool
isDeadEndDiv Divergence
div -> Bool
True
| Arity
n_val_args Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [OneShotInfo]
oss -> Bool
True
| Bool
otherwise -> Bool
False
arityType :: ArityEnv -> CoreExpr -> ArityType
arityType :: ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env (Cast CoreExpr
e CoercionR
co)
= ArityType -> Arity -> ArityType
minWithArity (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
e) Arity
co_arity
where
co_arity :: Arity
co_arity = [OneShotInfo] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (Type -> [OneShotInfo]
typeArity (CoercionR -> Type
coercionRKind CoercionR
co))
arityType ArityEnv
env (Var CoreBndr
v)
| CoreBndr
v CoreBndr -> IdSet -> Bool
`elemVarSet` ArityEnv -> IdSet
ae_joins ArityEnv
env
= ArityType
botArityType
| Just ArityType
at <- ArityEnv -> CoreBndr -> Maybe ArityType
lookupSigEnv ArityEnv
env CoreBndr
v
= ArityType
at
| Bool
otherwise
= CoreBndr -> ArityType
idArityType CoreBndr
v
arityType ArityEnv
env (Lam CoreBndr
x CoreExpr
e)
| CoreBndr -> Bool
isId CoreBndr
x = CoreBndr -> ArityType -> ArityType
arityLam CoreBndr
x (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
e)
| Bool
otherwise = ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
e
where
env' :: ArityEnv
env' = ArityEnv -> CoreBndr -> ArityEnv
delInScope ArityEnv
env CoreBndr
x
arityType ArityEnv
env (App CoreExpr
fun (Type Type
_))
= ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
fun
arityType ArityEnv
env (App CoreExpr
fun CoreExpr
arg )
= ArityType -> Bool -> ArityType
arityApp (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
fun) (ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap ArityEnv
env CoreExpr
arg Maybe Type
forall a. Maybe a
Nothing)
arityType ArityEnv
env (Case CoreExpr
scrut CoreBndr
bndr Type
_ [Alt CoreBndr]
alts)
| CoreExpr -> Bool
exprIsDeadEnd CoreExpr
scrut Bool -> Bool -> Bool
|| [Alt CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt CoreBndr]
alts
= ArityType
botArityType
| Bool -> Bool
not (ArityEnv -> Bool
pedanticBottoms ArityEnv
env)
, ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap ArityEnv
env CoreExpr
scrut (Type -> Maybe Type
forall a. a -> Maybe a
Just (CoreBndr -> Type
idType CoreBndr
bndr))
= ArityType
alts_type
| CoreExpr -> Bool
exprOkForSpeculation CoreExpr
scrut
= ArityType
alts_type
| Bool
otherwise
= ArityType -> ArityType
takeWhileOneShot ArityType
alts_type
where
env' :: ArityEnv
env' = ArityEnv -> CoreBndr -> ArityEnv
delInScope ArityEnv
env CoreBndr
bndr
arity_type_alt :: Alt CoreBndr -> ArityType
arity_type_alt (Alt AltCon
_con [CoreBndr]
bndrs CoreExpr
rhs) = ArityEnv -> CoreExpr -> ArityType
arityType (ArityEnv -> [CoreBndr] -> ArityEnv
delInScopeList ArityEnv
env' [CoreBndr]
bndrs) CoreExpr
rhs
alts_type :: ArityType
alts_type = (ArityType -> ArityType -> ArityType) -> [ArityType] -> ArityType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ArityType -> ArityType -> ArityType
andArityType ((Alt CoreBndr -> ArityType) -> [Alt CoreBndr] -> [ArityType]
forall a b. (a -> b) -> [a] -> [b]
map Alt CoreBndr -> ArityType
arity_type_alt [Alt CoreBndr]
alts)
arityType ArityEnv
env (Let (NonRec CoreBndr
j CoreExpr
rhs) CoreExpr
body)
| Just Arity
join_arity <- CoreBndr -> Maybe Arity
isJoinId_maybe CoreBndr
j
, ([CoreBndr]
_, CoreExpr
rhs_body) <- Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
forall b. Arity -> Expr b -> ([b], Expr b)
collectNBinders Arity
join_arity CoreExpr
rhs
=
ArityType -> ArityType -> ArityType
andArityType (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
rhs_body)
(ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
body)
where
env' :: ArityEnv
env' = ArityEnv -> [CoreBndr] -> ArityEnv
extendJoinEnv ArityEnv
env [CoreBndr
j]
arityType ArityEnv
env (Let (Rec [(CoreBndr, CoreExpr)]
pairs) CoreExpr
body)
| ((CoreBndr
j,CoreExpr
_):[(CoreBndr, CoreExpr)]
_) <- [(CoreBndr, CoreExpr)]
pairs
, CoreBndr -> Bool
isJoinId CoreBndr
j
=
((CoreBndr, CoreExpr) -> ArityType -> ArityType)
-> ArityType -> [(CoreBndr, CoreExpr)] -> ArityType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ArityType -> ArityType -> ArityType
andArityType (ArityType -> ArityType -> ArityType)
-> ((CoreBndr, CoreExpr) -> ArityType)
-> (CoreBndr, CoreExpr)
-> ArityType
-> ArityType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, CoreExpr) -> ArityType
do_one) (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
body) [(CoreBndr, CoreExpr)]
pairs
where
env' :: ArityEnv
env' = ArityEnv -> [CoreBndr] -> ArityEnv
extendJoinEnv ArityEnv
env (((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, CoreExpr)]
pairs)
do_one :: (CoreBndr, CoreExpr) -> ArityType
do_one (CoreBndr
j,CoreExpr
rhs)
| Just Arity
arity <- CoreBndr -> Maybe Arity
isJoinId_maybe CoreBndr
j
= ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' (CoreExpr -> ArityType) -> CoreExpr -> ArityType
forall a b. (a -> b) -> a -> b
$ ([CoreBndr], CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd (([CoreBndr], CoreExpr) -> CoreExpr)
-> ([CoreBndr], CoreExpr) -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
forall b. Arity -> Expr b -> ([b], Expr b)
collectNBinders Arity
arity CoreExpr
rhs
| Bool
otherwise
= String -> SDoc -> ArityType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"arityType:joinrec" ([(CoreBndr, CoreExpr)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(CoreBndr, CoreExpr)]
pairs)
arityType ArityEnv
env (Let (NonRec CoreBndr
b CoreExpr
r) CoreExpr
e)
= Bool -> ArityType -> ArityType
floatIn Bool
cheap_rhs (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
e)
where
cheap_rhs :: Bool
cheap_rhs = ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap ArityEnv
env CoreExpr
r (Type -> Maybe Type
forall a. a -> Maybe a
Just (CoreBndr -> Type
idType CoreBndr
b))
env' :: ArityEnv
env' = ArityEnv -> CoreBndr -> ArityType -> ArityEnv
extendSigEnv ArityEnv
env CoreBndr
b (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
r)
arityType ArityEnv
env (Let (Rec [(CoreBndr, CoreExpr)]
prs) CoreExpr
e)
= Bool -> ArityType -> ArityType
floatIn (((CoreBndr, CoreExpr) -> Bool) -> [(CoreBndr, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreBndr, CoreExpr) -> Bool
is_cheap [(CoreBndr, CoreExpr)]
prs) (ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env' CoreExpr
e)
where
env' :: ArityEnv
env' = ArityEnv -> [CoreBndr] -> ArityEnv
delInScopeList ArityEnv
env (((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, CoreExpr)]
prs)
is_cheap :: (CoreBndr, CoreExpr) -> Bool
is_cheap (CoreBndr
b,CoreExpr
e) = ArityEnv -> CoreExpr -> Maybe Type -> Bool
myExprIsCheap ArityEnv
env' CoreExpr
e (Type -> Maybe Type
forall a. a -> Maybe a
Just (CoreBndr -> Type
idType CoreBndr
b))
arityType ArityEnv
env (Tick CoreTickish
t CoreExpr
e)
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = ArityEnv -> CoreExpr -> ArityType
arityType ArityEnv
env CoreExpr
e
arityType ArityEnv
_ CoreExpr
_ = ArityType
topArityType
idArityType :: Id -> ArityType
idArityType :: CoreBndr -> ArityType
idArityType CoreBndr
v
| StrictSig
strict_sig <- CoreBndr -> StrictSig
idStrictness CoreBndr
v
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ StrictSig -> Bool
isTopSig StrictSig
strict_sig
, ([Demand]
ds, Divergence
div) <- StrictSig -> ([Demand], Divergence)
splitStrictSig StrictSig
strict_sig
, let arity :: Arity
arity = [Demand] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
ds
= [OneShotInfo] -> Divergence -> ArityType
AT (Arity -> [OneShotInfo] -> [OneShotInfo]
forall a. Arity -> [a] -> [a]
take Arity
arity [OneShotInfo]
one_shots) Divergence
div
| Bool
otherwise
= [OneShotInfo] -> Divergence -> ArityType
AT (Arity -> [OneShotInfo] -> [OneShotInfo]
forall a. Arity -> [a] -> [a]
take (CoreBndr -> Arity
idArity CoreBndr
v) [OneShotInfo]
one_shots) Divergence
topDiv
where
one_shots :: [OneShotInfo]
one_shots :: [OneShotInfo]
one_shots = Type -> [OneShotInfo]
typeArity (CoreBndr -> Type
idType CoreBndr
v)
etaExpand :: Arity -> CoreExpr -> CoreExpr
etaExpandAT :: ArityType -> CoreExpr -> CoreExpr
etaExpand :: Arity -> CoreExpr -> CoreExpr
etaExpand Arity
n CoreExpr
orig_expr = [OneShotInfo] -> CoreExpr -> CoreExpr
eta_expand (Arity -> OneShotInfo -> [OneShotInfo]
forall a. Arity -> a -> [a]
replicate Arity
n OneShotInfo
NoOneShotInfo) CoreExpr
orig_expr
etaExpandAT :: ArityType -> CoreExpr -> CoreExpr
etaExpandAT (AT [OneShotInfo]
oss Divergence
_) CoreExpr
orig_expr = [OneShotInfo] -> CoreExpr -> CoreExpr
eta_expand [OneShotInfo]
oss CoreExpr
orig_expr
eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr
eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr
eta_expand [OneShotInfo]
one_shots CoreExpr
orig_expr
= [OneShotInfo] -> CoreExpr -> CoreExpr
go [OneShotInfo]
one_shots CoreExpr
orig_expr
where
go :: [OneShotInfo] -> CoreExpr -> CoreExpr
go [] CoreExpr
expr = CoreExpr
expr
go oss :: [OneShotInfo]
oss@(OneShotInfo
_:[OneShotInfo]
oss1) (Lam CoreBndr
v CoreExpr
body) | CoreBndr -> Bool
isTyVar CoreBndr
v = CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
v ([OneShotInfo] -> CoreExpr -> CoreExpr
go [OneShotInfo]
oss CoreExpr
body)
| Bool
otherwise = CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
v ([OneShotInfo] -> CoreExpr -> CoreExpr
go [OneShotInfo]
oss1 CoreExpr
body)
go [OneShotInfo]
oss (Cast CoreExpr
expr CoercionR
co) = CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast ([OneShotInfo] -> CoreExpr -> CoreExpr
go [OneShotInfo]
oss CoreExpr
expr) CoercionR
co
go [OneShotInfo]
oss CoreExpr
expr
=
CoreExpr -> CoreExpr
retick (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs [EtaInfo]
etas (InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr
etaInfoApp InScopeSet
in_scope' CoreExpr
sexpr [EtaInfo]
etas)
where
in_scope :: InScopeSet
in_scope = IdSet -> InScopeSet
mkInScopeSet (CoreExpr -> IdSet
exprFreeVars CoreExpr
expr)
(InScopeSet
in_scope', [EtaInfo]
etas) = [OneShotInfo]
-> SDoc -> InScopeSet -> Type -> (InScopeSet, [EtaInfo])
mkEtaWW [OneShotInfo]
oss (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_expr) InScopeSet
in_scope (CoreExpr -> Type
exprType CoreExpr
expr)
(CoreExpr
expr', [CoreExpr]
args) = CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
expr
([CoreTickish]
ticks, CoreExpr
expr'') = (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
expr'
sexpr :: CoreExpr
sexpr = (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
expr'' [CoreExpr]
args
retick :: CoreExpr -> CoreExpr
retick CoreExpr
expr = (CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr [CoreTickish]
ticks
data EtaInfo
= EtaVar Var
| EtaCo CoercionR
instance Outputable EtaInfo where
ppr :: EtaInfo -> SDoc
ppr (EtaVar CoreBndr
v) = String -> SDoc
text String
"EtaVar" SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
v SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Type
idType CoreBndr
v)
ppr (EtaCo CoercionR
co) = String -> SDoc
text String
"EtaCo" SDoc -> SDoc -> SDoc
<+> SDoc -> Arity -> SDoc -> SDoc
hang (CoercionR -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionR
co) Arity
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoercionR -> Type
coercionType CoercionR
co))
pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
pushCoercion :: CoercionR -> [EtaInfo] -> [EtaInfo]
pushCoercion CoercionR
co1 (EtaCo CoercionR
co2 : [EtaInfo]
eis)
| CoercionR -> Bool
isReflCo CoercionR
co = [EtaInfo]
eis
| Bool
otherwise = CoercionR -> EtaInfo
EtaCo CoercionR
co EtaInfo -> [EtaInfo] -> [EtaInfo]
forall a. a -> [a] -> [a]
: [EtaInfo]
eis
where
co :: CoercionR
co = CoercionR
co1 CoercionR -> CoercionR -> CoercionR
`mkTransCo` CoercionR
co2
pushCoercion CoercionR
co [EtaInfo]
eis
= CoercionR -> EtaInfo
EtaCo CoercionR
co EtaInfo -> [EtaInfo] -> [EtaInfo]
forall a. a -> [a] -> [a]
: [EtaInfo]
eis
getArg_maybe :: [EtaInfo] -> Maybe (CoreArg, [EtaInfo])
getArg_maybe :: [EtaInfo] -> Maybe (CoreExpr, [EtaInfo])
getArg_maybe [EtaInfo]
eis = MCoercion -> [EtaInfo] -> Maybe (CoreExpr, [EtaInfo])
go MCoercion
MRefl [EtaInfo]
eis
where
go :: MCoercion -> [EtaInfo] -> Maybe (CoreArg, [EtaInfo])
go :: MCoercion -> [EtaInfo] -> Maybe (CoreExpr, [EtaInfo])
go MCoercion
_ [] = Maybe (CoreExpr, [EtaInfo])
forall a. Maybe a
Nothing
go MCoercion
mco (EtaCo CoercionR
co2 : [EtaInfo]
eis) = MCoercion -> [EtaInfo] -> Maybe (CoreExpr, [EtaInfo])
go (MCoercion -> CoercionR -> MCoercion
mkTransMCoL MCoercion
mco CoercionR
co2) [EtaInfo]
eis
go MCoercion
MRefl (EtaVar CoreBndr
v : [EtaInfo]
eis) = (CoreExpr, [EtaInfo]) -> Maybe (CoreExpr, [EtaInfo])
forall a. a -> Maybe a
Just (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
v, [EtaInfo]
eis)
go (MCo CoercionR
co) (EtaVar CoreBndr
v : [EtaInfo]
eis)
| Just (CoreExpr
arg, MCoercion
mco) <- CoercionR -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg CoercionR
co (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
v)
= case MCoercion
mco of
MCoercion
MRefl -> (CoreExpr, [EtaInfo]) -> Maybe (CoreExpr, [EtaInfo])
forall a. a -> Maybe a
Just (CoreExpr
arg, [EtaInfo]
eis)
MCo CoercionR
co -> (CoreExpr, [EtaInfo]) -> Maybe (CoreExpr, [EtaInfo])
forall a. a -> Maybe a
Just (CoreExpr
arg, CoercionR -> [EtaInfo] -> [EtaInfo]
pushCoercion CoercionR
co [EtaInfo]
eis)
| Bool
otherwise
= Maybe (CoreExpr, [EtaInfo])
forall a. Maybe a
Nothing
mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo :: CoreExpr -> MCoercion -> CoreExpr
mkCastMCo CoreExpr
e MCoercion
MRefl = CoreExpr
e
mkCastMCo CoreExpr
e (MCo CoercionR
co) = CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
e CoercionR
co
mkPiMCo :: Var -> MCoercionR -> MCoercionR
mkPiMCo :: CoreBndr -> MCoercion -> MCoercion
mkPiMCo CoreBndr
_ MCoercion
MRefl = MCoercion
MRefl
mkPiMCo CoreBndr
v (MCo CoercionR
co) = CoercionR -> MCoercion
MCo (Role -> CoreBndr -> CoercionR -> CoercionR
mkPiCo Role
Representational CoreBndr
v CoercionR
co)
etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs [EtaInfo]
eis CoreExpr
expr
| [EtaInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EtaInfo]
eis = CoreExpr
expr
| Bool
otherwise = case MCoercion
final_mco of
MCoercion
MRefl -> CoreExpr
expr'
MCo CoercionR
co -> CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
expr' CoercionR
co
where
(CoreExpr
expr', MCoercion
final_mco) = (EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion))
-> (CoreExpr, MCoercion) -> [EtaInfo] -> (CoreExpr, MCoercion)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion)
do_one (CoreExpr -> (CoreExpr, MCoercion)
split_cast CoreExpr
expr) [EtaInfo]
eis
do_one :: EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion)
do_one :: EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion)
do_one (EtaVar CoreBndr
v) (CoreExpr
expr, MCoercion
mco) = (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
v CoreExpr
expr, CoreBndr -> MCoercion -> MCoercion
mkPiMCo CoreBndr
v MCoercion
mco)
do_one (EtaCo CoercionR
co) (CoreExpr
expr, MCoercion
mco) = (CoreExpr
expr, MCoercion
mco MCoercion -> CoercionR -> MCoercion
`mkTransMCoL` CoercionR -> CoercionR
mkSymCo CoercionR
co)
split_cast :: CoreExpr -> (CoreExpr, MCoercion)
split_cast :: CoreExpr -> (CoreExpr, MCoercion)
split_cast (Cast CoreExpr
e CoercionR
co) = (CoreExpr
e, CoercionR -> MCoercion
MCo CoercionR
co)
split_cast CoreExpr
e = (CoreExpr
e, MCoercion
MRefl)
etaInfoApp :: InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr
etaInfoApp :: InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr
etaInfoApp InScopeSet
in_scope CoreExpr
expr [EtaInfo]
eis
= Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) CoreExpr
expr [EtaInfo]
eis
where
go :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go Subst
subst (Tick CoreTickish
t CoreExpr
e) [EtaInfo]
eis
= CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
t) (Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go Subst
subst CoreExpr
e [EtaInfo]
eis)
go Subst
subst (Cast CoreExpr
e CoercionR
co) [EtaInfo]
eis
= Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go Subst
subst CoreExpr
e (CoercionR -> [EtaInfo] -> [EtaInfo]
pushCoercion (HasCallStack => Subst -> CoercionR -> CoercionR
Subst -> CoercionR -> CoercionR
Core.substCo Subst
subst CoercionR
co) [EtaInfo]
eis)
go Subst
subst (Case CoreExpr
e CoreBndr
b Type
ty [Alt CoreBndr]
alts) [EtaInfo]
eis
= CoreExpr -> CoreBndr -> Type -> [Alt CoreBndr] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
Core.substExprSC Subst
subst CoreExpr
e) CoreBndr
b1 Type
ty' [Alt CoreBndr]
alts'
where
(Subst
subst1, CoreBndr
b1) = Subst -> CoreBndr -> (Subst, CoreBndr)
Core.substBndr Subst
subst CoreBndr
b
alts' :: [Alt CoreBndr]
alts' = (Alt CoreBndr -> Alt CoreBndr) -> [Alt CoreBndr] -> [Alt CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map Alt CoreBndr -> Alt CoreBndr
subst_alt [Alt CoreBndr]
alts
ty' :: Type
ty' = Type -> [EtaInfo] -> Type
etaInfoAppTy (Subst -> Type -> Type
Core.substTy Subst
subst Type
ty) [EtaInfo]
eis
subst_alt :: Alt CoreBndr -> Alt CoreBndr
subst_alt (Alt AltCon
con [CoreBndr]
bs CoreExpr
rhs) = AltCon -> [CoreBndr] -> CoreExpr -> Alt CoreBndr
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [CoreBndr]
bs' (Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go Subst
subst2 CoreExpr
rhs [EtaInfo]
eis)
where
(Subst
subst2,[CoreBndr]
bs') = Subst -> [CoreBndr] -> (Subst, [CoreBndr])
Core.substBndrs Subst
subst1 [CoreBndr]
bs
go Subst
subst (Let Bind CoreBndr
b CoreExpr
e) [EtaInfo]
eis
| Bool -> Bool
not (Bind CoreBndr -> Bool
isJoinBind Bind CoreBndr
b)
= Bind CoreBndr -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind CoreBndr
b' (Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go Subst
subst' CoreExpr
e [EtaInfo]
eis)
where
(Subst
subst', Bind CoreBndr
b') = HasDebugCallStack =>
Subst -> Bind CoreBndr -> (Subst, Bind CoreBndr)
Subst -> Bind CoreBndr -> (Subst, Bind CoreBndr)
Core.substBindSC Subst
subst Bind CoreBndr
b
go Subst
subst (Lam CoreBndr
v CoreExpr
e) [EtaInfo]
eis
| Just (CoreExpr
arg, [EtaInfo]
eis') <- [EtaInfo] -> Maybe (CoreExpr, [EtaInfo])
getArg_maybe [EtaInfo]
eis
= Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
go (Subst -> CoreBndr -> CoreExpr -> Subst
Core.extendSubst Subst
subst CoreBndr
v CoreExpr
arg) CoreExpr
e [EtaInfo]
eis'
go Subst
subst CoreExpr
e [EtaInfo]
eis = CoreExpr -> [EtaInfo] -> CoreExpr
forall b. Expr b -> [EtaInfo] -> Expr b
wrap (HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
Core.substExprSC Subst
subst CoreExpr
e) [EtaInfo]
eis
wrap :: Expr b -> [EtaInfo] -> Expr b
wrap Expr b
e [] = Expr b
e
wrap Expr b
e (EtaVar CoreBndr
v : [EtaInfo]
eis) = Expr b -> [EtaInfo] -> Expr b
wrap (Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App Expr b
e (CoreBndr -> Expr b
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
v)) [EtaInfo]
eis
wrap Expr b
e (EtaCo CoercionR
co : [EtaInfo]
eis) = Expr b -> [EtaInfo] -> Expr b
wrap (Expr b -> CoercionR -> Expr b
forall b. Expr b -> CoercionR -> Expr b
Cast Expr b
e CoercionR
co) [EtaInfo]
eis
etaInfoAppTy :: Type -> [EtaInfo] -> Type
etaInfoAppTy :: Type -> [EtaInfo] -> Type
etaInfoAppTy Type
ty [] = Type
ty
etaInfoAppTy Type
ty (EtaVar CoreBndr
v : [EtaInfo]
eis) = Type -> [EtaInfo] -> Type
etaInfoAppTy (Type -> CoreExpr -> Type
applyTypeToArg Type
ty (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
v)) [EtaInfo]
eis
etaInfoAppTy Type
_ (EtaCo CoercionR
co : [EtaInfo]
eis) = Type -> [EtaInfo] -> Type
etaInfoAppTy (CoercionR -> Type
coercionRKind CoercionR
co) [EtaInfo]
eis
mkEtaWW
:: [OneShotInfo]
-> SDoc
-> InScopeSet
-> Type
-> (InScopeSet, [EtaInfo])
mkEtaWW :: [OneShotInfo]
-> SDoc -> InScopeSet -> Type -> (InScopeSet, [EtaInfo])
mkEtaWW [OneShotInfo]
orig_oss SDoc
ppr_orig_expr InScopeSet
in_scope Type
orig_ty
= Arity
-> [OneShotInfo]
-> TCvSubst
-> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go Arity
0 [OneShotInfo]
orig_oss TCvSubst
empty_subst Type
orig_ty []
where
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
go :: Int
-> [OneShotInfo]
-> TCvSubst -> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go :: Arity
-> [OneShotInfo]
-> TCvSubst
-> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go Arity
_ [] TCvSubst
subst Type
_ [EtaInfo]
eis
= (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst, [EtaInfo] -> [EtaInfo]
forall a. [a] -> [a]
reverse [EtaInfo]
eis)
go Arity
n oss :: [OneShotInfo]
oss@(OneShotInfo
one_shot:[OneShotInfo]
oss1) TCvSubst
subst Type
ty [EtaInfo]
eis
| Just (CoreBndr
tcv,Type
ty') <- Type -> Maybe (CoreBndr, Type)
splitForAllTyCoVar_maybe Type
ty
, (TCvSubst
subst', CoreBndr
tcv') <- HasCallStack => TCvSubst -> CoreBndr -> (TCvSubst, CoreBndr)
TCvSubst -> CoreBndr -> (TCvSubst, CoreBndr)
Type.substVarBndr TCvSubst
subst CoreBndr
tcv
, let oss' :: [OneShotInfo]
oss' | CoreBndr -> Bool
isTyVar CoreBndr
tcv = [OneShotInfo]
oss
| Bool
otherwise = [OneShotInfo]
oss1
= Arity
-> [OneShotInfo]
-> TCvSubst
-> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go Arity
n [OneShotInfo]
oss' TCvSubst
subst' Type
ty' (CoreBndr -> EtaInfo
EtaVar CoreBndr
tcv' EtaInfo -> [EtaInfo] -> [EtaInfo]
forall a. a -> [a] -> [a]
: [EtaInfo]
eis)
| Just (Type
mult, Type
arg_ty, Type
res_ty) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
ty
, Bool -> Bool
not (Type -> Bool
isTypeLevPoly Type
arg_ty)
, (TCvSubst
subst', CoreBndr
eta_id) <- Arity -> TCvSubst -> Scaled Type -> (TCvSubst, CoreBndr)
freshEtaId Arity
n TCvSubst
subst (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty)
, let eta_id' :: CoreBndr
eta_id' = CoreBndr
eta_id CoreBndr -> OneShotInfo -> CoreBndr
`setIdOneShotInfo` OneShotInfo
one_shot
= Arity
-> [OneShotInfo]
-> TCvSubst
-> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) [OneShotInfo]
oss1 TCvSubst
subst' Type
res_ty (CoreBndr -> EtaInfo
EtaVar CoreBndr
eta_id' EtaInfo -> [EtaInfo] -> [EtaInfo]
forall a. a -> [a] -> [a]
: [EtaInfo]
eis)
| Just (CoercionR
co, Type
ty') <- Type -> Maybe (CoercionR, Type)
topNormaliseNewType_maybe Type
ty
, let co' :: CoercionR
co' = HasCallStack => TCvSubst -> CoercionR -> CoercionR
TCvSubst -> CoercionR -> CoercionR
Type.substCo TCvSubst
subst CoercionR
co
= Arity
-> [OneShotInfo]
-> TCvSubst
-> Type
-> [EtaInfo]
-> (InScopeSet, [EtaInfo])
go Arity
n [OneShotInfo]
oss TCvSubst
subst Type
ty' (CoercionR -> [EtaInfo] -> [EtaInfo]
pushCoercion CoercionR
co' [EtaInfo]
eis)
| Bool
otherwise
= WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )
(TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst, [EtaInfo] -> [EtaInfo]
forall a. [a] -> [a]
reverse [EtaInfo]
eis)
pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
pushCoArgs :: CoercionR -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs CoercionR
co [] = ([CoreExpr], MCoercion) -> Maybe ([CoreExpr], MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoercionR -> MCoercion
MCo CoercionR
co)
pushCoArgs CoercionR
co (CoreExpr
arg:[CoreExpr]
args) = do { (CoreExpr
arg', MCoercion
m_co1) <- CoercionR -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg CoercionR
co CoreExpr
arg
; case MCoercion
m_co1 of
MCo CoercionR
co1 -> do { ([CoreExpr]
args', MCoercion
m_co2) <- CoercionR -> [CoreExpr] -> Maybe ([CoreExpr], MCoercion)
pushCoArgs CoercionR
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 :: CoercionR -> CoreExpr -> Maybe (CoreExpr, MCoercion)
pushCoArg CoercionR
co (Type Type
ty) = do { (Type
ty', MCoercion
m_co') <- CoercionR -> Type -> Maybe (Type, MCoercion)
pushCoTyArg CoercionR
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 CoercionR
co CoreExpr
val_arg = do { (MCoercion
arg_co, MCoercion
m_co') <- CoercionR -> Maybe (MCoercion, MCoercion)
pushCoValArg CoercionR
co
; (CoreExpr, MCoercion) -> Maybe (CoreExpr, MCoercion)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
val_arg CoreExpr -> MCoercion -> CoreExpr
`mkCastMCo` MCoercion
arg_co, MCoercion
m_co') }
pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)
pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercion)
pushCoTyArg CoercionR
co Type
ty
| CoercionR -> Bool
isReflCo CoercionR
co
= (Type, MCoercion) -> Maybe (Type, MCoercion)
forall a. a -> Maybe a
Just (Type
ty, MCoercion
MRefl)
| Type -> Bool
isForAllTy_ty Type
tyL
= ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )
(Type, MCoercion) -> Maybe (Type, MCoercion)
forall a. a -> Maybe a
Just (Type
ty Type -> CoercionR -> Type
`mkCastTy` CoercionR
co1, CoercionR -> MCoercion
MCo CoercionR
co2)
| Bool
otherwise
= Maybe (Type, MCoercion)
forall a. Maybe a
Nothing
where
Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
co1 :: CoercionR
co1 = CoercionR -> CoercionR
mkSymCo (HasDebugCallStack => Role -> Arity -> CoercionR -> CoercionR
Role -> Arity -> CoercionR -> CoercionR
mkNthCo Role
Nominal Arity
0 CoercionR
co)
co2 :: CoercionR
co2 = CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Role -> Type -> CoercionR -> CoercionR
mkGReflLeftCo Role
Nominal Type
ty CoercionR
co1)
pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)
pushCoValArg :: CoercionR -> Maybe (MCoercion, MCoercion)
pushCoValArg CoercionR
co
| CoercionR -> Bool
isReflCo CoercionR
co
= (MCoercion, MCoercion) -> Maybe (MCoercion, MCoercion)
forall a. a -> Maybe a
Just (MCoercion
MRefl, MCoercion
MRefl)
| Type -> Bool
isFunTy Type
tyL
, (CoercionR
co_mult, CoercionR
co1, CoercionR
co2) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
, CoercionR -> Bool
isReflexiveCo CoercionR
co_mult
= ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
(MCoercion, MCoercion) -> Maybe (MCoercion, MCoercion)
forall a. a -> Maybe a
Just (CoercionR -> MCoercion
coToMCo (CoercionR -> CoercionR
mkSymCo CoercionR
co1), CoercionR -> MCoercion
coToMCo CoercionR
co2)
| Bool
otherwise
= Maybe (MCoercion, MCoercion)
forall a. Maybe a
Nothing
where
arg :: Type
arg = Type -> Type
funArgTy Type
tyR
Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
pushCoercionIntoLambda
:: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
pushCoercionIntoLambda :: InScopeSet
-> CoreBndr -> CoreExpr -> CoercionR -> Maybe (CoreBndr, CoreExpr)
pushCoercionIntoLambda InScopeSet
in_scope CoreBndr
x CoreExpr
e CoercionR
co
| ASSERT(not (isTyVar x) && not (isCoVar x)) True
, Pair Type
s1s2 Type
t1t2 <- CoercionR -> Pair Type
coercionKind CoercionR
co
, Just (Type
_, Type
_s1,Type
_s2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
s1s2
, Just (Type
w1, Type
t1,Type
_t2) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
t1t2
, (CoercionR
co_mult, CoercionR
co1, CoercionR
co2) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
, CoercionR -> Bool
isReflexiveCo CoercionR
co_mult
= let
x' :: CoreBndr
x' = CoreBndr
x CoreBndr -> Type -> CoreBndr
`setIdType` Type
t1 CoreBndr -> Type -> CoreBndr
`setIdMult` Type
w1
in_scope' :: InScopeSet
in_scope' = InScopeSet
in_scope InScopeSet -> CoreBndr -> InScopeSet
`extendInScopeSet` CoreBndr
x'
subst :: Subst
subst = Subst -> CoreBndr -> CoreExpr -> Subst
extendIdSubst (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope')
CoreBndr
x
(CoreExpr -> CoercionR -> CoreExpr
mkCast (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
x') CoercionR
co1)
in (CoreBndr, CoreExpr) -> Maybe (CoreBndr, CoreExpr)
forall a. a -> Maybe a
Just (CoreBndr
x', HasDebugCallStack => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
substExpr Subst
subst CoreExpr
e CoreExpr -> CoercionR -> CoreExpr
`mkCast` CoercionR
co2)
| Bool
otherwise
= String
-> SDoc -> Maybe (CoreBndr, CoreExpr) -> Maybe (CoreBndr, CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace String
"exprIsLambda_maybe: Unexpected lambda in case" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x CoreExpr
e))
Maybe (CoreBndr, CoreExpr)
forall a. Maybe a
Nothing
pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
-> Maybe (DataCon
, [Type]
, [CoreExpr])
pushCoDataCon :: DataCon
-> [CoreExpr] -> CoercionR -> Maybe (DataCon, [Type], [CoreExpr])
pushCoDataCon DataCon
dc [CoreExpr]
dc_args CoercionR
co
| CoercionR -> Bool
isReflCo CoercionR
co Bool -> Bool -> Bool
|| Type
from_ty Type -> Type -> Bool
`eqType` Type
to_ty
, let ([CoreExpr]
univ_ty_args, [CoreExpr]
rest_args) = [CoreBndr] -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [CoreBndr]
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 :: Arity
tc_arity = TyCon -> Arity
tyConArity TyCon
to_tc
dc_univ_tyvars :: [CoreBndr]
dc_univ_tyvars = DataCon -> [CoreBndr]
dataConUnivTyVars DataCon
dc
dc_ex_tcvars :: [CoreBndr]
dc_ex_tcvars = DataCon -> [CoreBndr]
dataConExTyCoVars DataCon
dc
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc
non_univ_args :: [CoreExpr]
non_univ_args = [CoreBndr] -> [CoreExpr] -> [CoreExpr]
forall b a. [b] -> [a] -> [a]
dropList [CoreBndr]
dc_univ_tyvars [CoreExpr]
dc_args
([CoreExpr]
ex_args, [CoreExpr]
val_args) = [CoreBndr] -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [CoreBndr]
dc_ex_tcvars [CoreExpr]
non_univ_args
omegas :: [CoercionR]
omegas = Arity -> CoercionR -> [Role] -> [CoercionR]
decomposeCo Arity
tc_arity CoercionR
co (TyCon -> [Role]
tyConRolesRepresentational TyCon
to_tc)
(Type -> CoercionR
psi_subst, [Type]
to_ex_arg_tys)
= Role
-> [CoreBndr]
-> [CoercionR]
-> [CoreBndr]
-> [Type]
-> (Type -> CoercionR, [Type])
liftCoSubstWithEx Role
Representational
[CoreBndr]
dc_univ_tyvars
[CoercionR]
omegas
[CoreBndr]
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 ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [CoreExpr]
val_args
cast_arg :: Type -> CoreExpr -> CoreExpr
cast_arg Type
arg_ty CoreExpr
arg = CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
arg (Type -> CoercionR
psi_subst Type
arg_ty)
to_ex_args :: [CoreExpr]
to_ex_args = (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
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, [CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
dc_univ_tyvars, [CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
dc_ex_tcvars,
[Scaled Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Scaled 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, CoercionR -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionR
co, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
from_ty, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
to_ty, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
to_tc
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> Type
mkTyConApp TyCon
to_tc ((CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprToType ([CoreExpr] -> [Type]) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> [CoreExpr] -> [CoreExpr]
forall b a. [b] -> [a] -> [a]
takeList [CoreBndr]
dc_univ_tyvars [CoreExpr]
dc_args) ]
in
ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
ASSERT2( equalLength val_args arg_tys, dump_doc )
(DataCon, [Type], [CoreExpr])
-> Maybe (DataCon, [Type], [CoreExpr])
forall a. a -> Maybe a
Just (DataCon
dc, [Type]
to_tc_arg_tys, [CoreExpr]
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 = CoercionR -> Pair Type
coercionKind CoercionR
co
collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
collectBindersPushingCo :: CoreExpr -> ([CoreBndr], CoreExpr)
collectBindersPushingCo CoreExpr
e
= [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go [] CoreExpr
e
where
go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
go :: [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go [CoreBndr]
bs (Lam CoreBndr
b CoreExpr
e) = [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go (CoreBndr
bCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs) CoreExpr
e
go [CoreBndr]
bs (Cast CoreExpr
e CoercionR
co) = [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c [CoreBndr]
bs CoreExpr
e CoercionR
co
go [CoreBndr]
bs CoreExpr
e = ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
bs, CoreExpr
e)
go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
go_c :: [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c [CoreBndr]
bs (Cast CoreExpr
e CoercionR
co1) CoercionR
co2 = [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c [CoreBndr]
bs CoreExpr
e (CoercionR
co1 CoercionR -> CoercionR -> CoercionR
`mkTransCo` CoercionR
co2)
go_c [CoreBndr]
bs (Lam CoreBndr
b CoreExpr
e) CoercionR
co = [CoreBndr]
-> CoreBndr -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_lam [CoreBndr]
bs CoreBndr
b CoreExpr
e CoercionR
co
go_c [CoreBndr]
bs CoreExpr
e CoercionR
co = ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
bs, CoreExpr -> CoercionR -> CoreExpr
mkCast CoreExpr
e CoercionR
co)
go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
go_lam :: [CoreBndr]
-> CoreBndr -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_lam [CoreBndr]
bs CoreBndr
b CoreExpr
e CoercionR
co
| CoreBndr -> Bool
isTyVar CoreBndr
b
, let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
, ASSERT( isForAllTy_ty tyL )
Type -> Bool
isForAllTy_ty Type
tyR
, CoercionR -> Bool
isReflCo (HasDebugCallStack => Role -> Arity -> CoercionR -> CoercionR
Role -> Arity -> CoercionR -> CoercionR
mkNthCo Role
Nominal Arity
0 CoercionR
co)
= [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c (CoreBndr
bCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs) CoreExpr
e (CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Type -> CoercionR
mkNomReflCo (CoreBndr -> Type
mkTyVarTy CoreBndr
b)))
| CoreBndr -> Bool
isCoVar CoreBndr
b
, let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
, ASSERT( isForAllTy_co tyL )
Type -> Bool
isForAllTy_co Type
tyR
, CoercionR -> Bool
isReflCo (HasDebugCallStack => Role -> Arity -> CoercionR -> CoercionR
Role -> Arity -> CoercionR -> CoercionR
mkNthCo Role
Nominal Arity
0 CoercionR
co)
, let cov :: CoercionR
cov = CoreBndr -> CoercionR
mkCoVarCo CoreBndr
b
= [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c (CoreBndr
bCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs) CoreExpr
e (CoercionR -> CoercionR -> CoercionR
mkInstCo CoercionR
co (Type -> CoercionR
mkNomReflCo (CoercionR -> Type
mkCoercionTy CoercionR
cov)))
| CoreBndr -> Bool
isId CoreBndr
b
, let Pair Type
tyL Type
tyR = CoercionR -> Pair Type
coercionKind CoercionR
co
, ASSERT( isFunTy tyL) isFunTy tyR
, (CoercionR
co_mult, CoercionR
co_arg, CoercionR
co_res) <- HasDebugCallStack =>
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
Role -> CoercionR -> (CoercionR, CoercionR, CoercionR)
decomposeFunCo Role
Representational CoercionR
co
, CoercionR -> Bool
isReflCo CoercionR
co_mult
, CoercionR -> Bool
isReflCo CoercionR
co_arg
= [CoreBndr] -> CoreExpr -> CoercionR -> ([CoreBndr], CoreExpr)
go_c (CoreBndr
bCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
bs) CoreExpr
e CoercionR
co_res
| Bool
otherwise = ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
bs, CoreExpr -> CoercionR -> CoreExpr
mkCast (CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
b CoreExpr
e) CoercionR
co)
etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)
etaExpandToJoinPoint :: Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
etaExpandToJoinPoint Arity
join_arity CoreExpr
expr
= Arity -> [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go Arity
join_arity [] CoreExpr
expr
where
go :: Arity -> [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go Arity
0 [CoreBndr]
rev_bs CoreExpr
e = ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
rev_bs, CoreExpr
e)
go Arity
n [CoreBndr]
rev_bs (Lam CoreBndr
b CoreExpr
e) = Arity -> [CoreBndr] -> CoreExpr -> ([CoreBndr], CoreExpr)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) (CoreBndr
b CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
rev_bs) CoreExpr
e
go Arity
n [CoreBndr]
rev_bs CoreExpr
e = case Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
etaBodyForJoinPoint Arity
n CoreExpr
e of
([CoreBndr]
bs, CoreExpr
e') -> ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
rev_bs [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
bs, CoreExpr
e')
etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule
etaExpandToJoinPointRule :: Arity -> CoreRule -> CoreRule
etaExpandToJoinPointRule Arity
_ rule :: CoreRule
rule@(BuiltinRule {})
= WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))
CoreRule
rule
etaExpandToJoinPointRule Arity
join_arity rule :: CoreRule
rule@(Rule { ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs
, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args })
| Arity
need_args Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= CoreRule
rule
| Arity
need_args Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Arity
0
= String -> SDoc -> CoreRule
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"etaExpandToJoinPointRule" (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
join_arity SDoc -> SDoc -> SDoc
$$ CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule)
| Bool
otherwise
= CoreRule
rule { ru_bndrs :: [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
new_bndrs, ru_args :: [CoreExpr]
ru_args = [CoreExpr]
args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
new_args
, ru_rhs :: CoreExpr
ru_rhs = CoreExpr
new_rhs }
where
need_args :: Arity
need_args = Arity
join_arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- [CoreExpr] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
args
([CoreBndr]
new_bndrs, CoreExpr
new_rhs) = Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
etaBodyForJoinPoint Arity
need_args CoreExpr
rhs
new_args :: [CoreExpr]
new_args = [CoreBndr] -> [CoreExpr]
forall b. [CoreBndr] -> [Expr b]
varsToCoreExprs [CoreBndr]
new_bndrs
etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)
etaBodyForJoinPoint :: Arity -> CoreExpr -> ([CoreBndr], CoreExpr)
etaBodyForJoinPoint Arity
need_args CoreExpr
body
= Arity
-> Type
-> TCvSubst
-> [CoreBndr]
-> CoreExpr
-> ([CoreBndr], CoreExpr)
go Arity
need_args (CoreExpr -> Type
exprType CoreExpr
body) (CoreExpr -> TCvSubst
init_subst CoreExpr
body) [] CoreExpr
body
where
go :: Arity
-> Type
-> TCvSubst
-> [CoreBndr]
-> CoreExpr
-> ([CoreBndr], CoreExpr)
go Arity
0 Type
_ TCvSubst
_ [CoreBndr]
rev_bs CoreExpr
e
= ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
rev_bs, CoreExpr
e)
go Arity
n Type
ty TCvSubst
subst [CoreBndr]
rev_bs CoreExpr
e
| Just (CoreBndr
tv, Type
res_ty) <- Type -> Maybe (CoreBndr, Type)
splitForAllTyCoVar_maybe Type
ty
, let (TCvSubst
subst', CoreBndr
tv') = HasCallStack => TCvSubst -> CoreBndr -> (TCvSubst, CoreBndr)
TCvSubst -> CoreBndr -> (TCvSubst, CoreBndr)
substVarBndr TCvSubst
subst CoreBndr
tv
= Arity
-> Type
-> TCvSubst
-> [CoreBndr]
-> CoreExpr
-> ([CoreBndr], CoreExpr)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) Type
res_ty TCvSubst
subst' (CoreBndr
tv' CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
rev_bs) (CoreExpr
e CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
tv')
| Just (Type
mult, Type
arg_ty, Type
res_ty) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
ty
, let (TCvSubst
subst', CoreBndr
b) = Arity -> TCvSubst -> Scaled Type -> (TCvSubst, CoreBndr)
freshEtaId Arity
n TCvSubst
subst (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty)
= Arity
-> Type
-> TCvSubst
-> [CoreBndr]
-> CoreExpr
-> ([CoreBndr], CoreExpr)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) Type
res_ty TCvSubst
subst' (CoreBndr
b CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
rev_bs) (CoreExpr
e CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
b)
| Bool
otherwise
= String -> SDoc -> ([CoreBndr], CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"etaBodyForJoinPoint" (SDoc -> ([CoreBndr], CoreExpr)) -> SDoc -> ([CoreBndr], CoreExpr)
forall a b. (a -> b) -> a -> b
$ Arity -> SDoc
int Arity
need_args SDoc -> SDoc -> SDoc
$$
CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
body SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreExpr -> Type
exprType CoreExpr
body)
init_subst :: CoreExpr -> TCvSubst
init_subst CoreExpr
e = InScopeSet -> TCvSubst
mkEmptyTCvSubst (IdSet -> InScopeSet
mkInScopeSet (CoreExpr -> IdSet
exprFreeVars CoreExpr
e))
freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id)
freshEtaId :: Arity -> TCvSubst -> Scaled Type -> (TCvSubst, CoreBndr)
freshEtaId Arity
n TCvSubst
subst Scaled Type
ty
= (TCvSubst
subst', CoreBndr
eta_id')
where
Scaled Type
mult' Type
ty' = HasCallStack => TCvSubst -> Scaled Type -> Scaled Type
TCvSubst -> Scaled Type -> Scaled Type
Type.substScaledTyUnchecked TCvSubst
subst Scaled Type
ty
eta_id' :: CoreBndr
eta_id' = InScopeSet -> CoreBndr -> CoreBndr
uniqAway (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst) (CoreBndr -> CoreBndr) -> CoreBndr -> CoreBndr
forall a b. (a -> b) -> a -> b
$
FastString -> Unique -> Type -> Type -> CoreBndr
mkSysLocalOrCoVar (String -> FastString
fsLit String
"eta") (Arity -> Unique
mkBuiltinUnique Arity
n) Type
mult' Type
ty'
subst' :: TCvSubst
subst' = TCvSubst -> CoreBndr -> TCvSubst
extendTCvInScope TCvSubst
subst CoreBndr
eta_id'