{-# LANGUAGE CPP #-}
module MkId (
mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
mkPrimOpId, mkFCallId,
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, magicDictId, coerceId,
proxyHashId, noinlineId, noinlineIdName,
coerceName,
module PrelRules
) where
#include "HsVersions.h"
import GhcPrelude
import Rules
import TysPrim
import TysWiredIn
import PrelRules
import Type
import FamInstEnv
import Coercion
import TcType
import MkCore
import CoreUtils ( mkCast, mkDefaultCase )
import CoreUnfold
import Literal
import TyCon
import Class
import NameSet
import Name
import PrimOp
import ForeignCall
import DataCon
import Id
import IdInfo
import Demand
import CoreSyn
import Unique
import UniqSupply
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
import Pair
import DynFlags
import Outputable
import FastString
import ListSetOps
import Var (VarBndr(Bndr))
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe ( maybeToList )
wiredInIds :: [Id]
wiredInIds :: [Id]
wiredInIds
= [Id]
magicIds
[Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ghcPrimIds
[Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
errorIds
magicIds :: [Id]
magicIds :: [Id]
magicIds = [Id
lazyId, Id
oneShotId, Id
noinlineId]
ghcPrimIds :: [Id]
ghcPrimIds :: [Id]
ghcPrimIds
= [ Id
realWorldPrimId
, Id
voidPrimId
, Id
unsafeCoerceId
, Id
nullAddrId
, Id
seqId
, Id
magicDictId
, Id
coerceId
, Id
proxyHashId
]
mkDictSelId :: Name
-> Class -> Id
mkDictSelId :: Name -> Class -> Id
mkDictSelId Name
name Class
clas
= IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (Class -> IdDetails
ClassOpId Class
clas) Name
name Type
sel_ty IdInfo
info
where
tycon :: TyCon
tycon = Class -> TyCon
classTyCon Class
clas
sel_names :: [Name]
sel_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName (Class -> [Id]
classAllSelIds Class
clas)
new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
[DataCon
data_con] = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
tyvars :: [TyVarBinder]
tyvars = DataCon -> [TyVarBinder]
dataConUserTyVarBinders DataCon
data_con
n_ty_args :: Int
n_ty_args = [TyVarBinder] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBinder]
tyvars
arg_tys :: [Type]
arg_tys = DataCon -> [Type]
dataConRepArgTys DataCon
data_con
val_index :: Int
val_index = String -> Assoc Name Int -> Name -> Int
forall a b. Eq a => String -> Assoc a b -> a -> b
assoc String
"MkId.mkDictSelId" ([Name]
sel_names [Name] -> [Int] -> Assoc Name Int
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..]) Name
name
sel_ty :: Type
sel_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tyvars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkInvisFunTy (Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys ([TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
tyvars))) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Int -> Type
forall a. Outputable a => [a] -> Int -> a
getNth [Type]
arg_tys Int
val_index
base_info :: IdInfo
base_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
sel_ty
info :: IdInfo
info | Bool
new_tycon
= IdInfo
base_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Int
1
(Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index)
| Bool
otherwise
= IdInfo
base_info IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule
rule]
rule :: CoreRule
rule = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"Class op " RuleName -> RuleName -> RuleName
`appendFS`
OccName -> RuleName
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name)
, ru_fn :: Name
ru_fn = Name
name
, ru_nargs :: Int
ru_nargs = Int
n_ty_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, ru_try :: RuleFun
ru_try = Int -> Int -> RuleFun
dictSelRule Int
val_index Int
n_ty_args }
strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand
arg_dmd] DmdResult
topRes
arg_dmd :: Demand
arg_dmd | Bool
new_tycon = Demand
evalDmd
| Bool
otherwise = CleanDemand -> Demand
mkManyUsedDmd (CleanDemand -> Demand) -> CleanDemand -> Demand
forall a b. (a -> b) -> a -> b
$
[Demand] -> CleanDemand
mkProdDmd [ if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sel_name then Demand
evalDmd else Demand
absDmd
| Name
sel_name <- [Name]
sel_names ]
mkDictSelRhs :: Class
-> Int
-> CoreExpr
mkDictSelRhs :: Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index
= [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
dict_id CoreExpr
rhs_body)
where
tycon :: TyCon
tycon = Class -> TyCon
classTyCon Class
clas
new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
[DataCon
data_con] = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
tyvars :: [Id]
tyvars = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
arg_tys :: [Type]
arg_tys = DataCon -> [Type]
dataConRepArgTys DataCon
data_con
the_arg_id :: Id
the_arg_id = [Id] -> Int -> Id
forall a. Outputable a => [a] -> Int -> a
getNth [Id]
arg_ids Int
val_index
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
dict_id :: Id
dict_id = Int -> Type -> Id
mkTemplateLocal Int
1 Type
pred
arg_ids :: [Id]
arg_ids = Int -> [Type] -> [Id]
mkTemplateLocalsNum Int
2 [Type]
arg_tys
rhs_body :: CoreExpr
rhs_body | Bool
new_tycon = TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tycon ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
(Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dict_id)
| Bool
otherwise = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dict_id) Id
dict_id (DataCon -> AltCon
DataAlt DataCon
data_con)
[Id]
arg_ids (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
the_arg_id)
dictSelRule :: Int -> Arity -> RuleFun
dictSelRule :: Int -> Int -> RuleFun
dictSelRule Int
val_index Int
n_ty_args DynFlags
_ InScopeEnv
id_unf Id
_ [CoreExpr]
args
| (CoreExpr
dict_arg : [CoreExpr]
_) <- Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
drop Int
n_ty_args [CoreExpr]
args
, Just (InScopeSet
_, [FloatBind]
floats, DataCon
_, [Type]
_, [CoreExpr]
con_args) <- InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
id_unf CoreExpr
dict_arg
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreExpr] -> Int -> CoreExpr
forall a. Outputable a => [a] -> Int -> a
getNth [CoreExpr]
con_args Int
val_index)
| Bool
otherwise
= Maybe CoreExpr
forall a. Maybe a
Nothing
mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId Name
wkr_name DataCon
data_con
| TyCon -> Bool
isNewTyCon TyCon
tycon
= IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWrapId DataCon
data_con) Name
wkr_name Type
wkr_ty IdInfo
nt_work_info
| Bool
otherwise
= IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWorkId DataCon
data_con) Name
wkr_name Type
wkr_ty IdInfo
alg_wkr_info
where
tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con
wkr_ty :: Type
wkr_ty = DataCon -> Type
dataConRepType DataCon
data_con
alg_wkr_info :: IdInfo
alg_wkr_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
wkr_arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
wkr_sig
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
data_con
wkr_sig :: StrictSig
wkr_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
wkr_arity Demand
topDmd) (DataCon -> DmdResult
dataConCPR DataCon
data_con)
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
arg_tys :: [Type]
arg_tys = DataCon -> [Type]
dataConRepArgTys DataCon
data_con
nt_work_info :: IdInfo
nt_work_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
newtype_unf
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
id_arg1 :: Id
id_arg1 = Int -> Type -> Id
mkTemplateLocal Int
1 ([Type] -> Type
forall a. [a] -> a
head [Type]
arg_tys)
res_ty_args :: [Type]
res_ty_args = [Id] -> [Type]
mkTyCoVarTys [Id]
univ_tvs
newtype_unf :: Unfolding
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
isSingleton arg_tys
, ppr data_con )
CoreExpr -> Unfolding
mkCompulsoryUnfolding (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
forall a b. (a -> b) -> a -> b
$
[Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
univ_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id_arg1 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody TyCon
tycon [Type]
res_ty_args (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id_arg1)
dataConCPR :: DataCon -> DmdResult
dataConCPR :: DataCon -> DmdResult
dataConCPR DataCon
con
| TyCon -> Bool
isDataTyCon TyCon
tycon
, [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con)
, Int
wkr_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
, Int
wkr_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mAX_CPR_SIZE
= if Bool
is_prod then Int -> DmdResult
vanillaCprProdRes (DataCon -> Int
dataConRepArity DataCon
con)
else Int -> DmdResult
cprSumRes (DataCon -> Int
dataConTag DataCon
con)
| Bool
otherwise
= DmdResult
topRes
where
is_prod :: Bool
is_prod = TyCon -> Bool
isProductTyCon TyCon
tycon
tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
con
wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
con
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE :: Int
mAX_CPR_SIZE = Int
10
type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
mkDataConRep :: DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-> DataCon
-> UniqSM DataConRep
mkDataConRep :: DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-> DataCon
-> UniqSM DataConRep
mkDataConRep DynFlags
dflags FamInstEnvs
fam_envs Name
wrap_name Maybe [HsImplBang]
mb_bangs DataCon
data_con
| Bool -> Bool
not Bool
wrapper_reqd
= DataConRep -> UniqSM DataConRep
forall (m :: * -> *) a. Monad m => a -> m a
return DataConRep
NoDataConRep
| Bool
otherwise
= do { [Id]
wrap_args <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> UniqSM Id
newLocal [Type]
wrap_arg_tys
; CoreExpr
wrap_body <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app ([Id]
wrap_args [Id] -> [Unboxer] -> [(Id, Unboxer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [EqSpec] -> [Unboxer] -> [Unboxer]
forall b a. [b] -> [a] -> [a]
dropList [EqSpec]
eq_spec [Unboxer]
unboxers)
CoreExpr
forall b. Expr b
initial_wrap_app
; let wrap_id :: Id
wrap_id = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWrapId DataCon
data_con) Name
wrap_name Type
wrap_ty IdInfo
wrap_info
wrap_info :: IdInfo
wrap_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
wrap_arity
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
wrap_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
wrap_unf
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
wrap_sig
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wrap_ty
wrap_sig :: StrictSig
wrap_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand]
wrap_arg_dmds (DataCon -> DmdResult
dataConCPR DataCon
data_con)
wrap_arg_dmds :: [Demand]
wrap_arg_dmds =
Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
theta) Demand
topDmd [Demand] -> [Demand] -> [Demand]
forall a. [a] -> [a] -> [a]
++ (HsImplBang -> Demand) -> [HsImplBang] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map HsImplBang -> Demand
mk_dmd [HsImplBang]
arg_ibangs
mk_dmd :: HsImplBang -> Demand
mk_dmd HsImplBang
str | HsImplBang -> Bool
isBanged HsImplBang
str = Demand
evalDmd
| Bool
otherwise = Demand
topDmd
wrap_prag :: InlinePragma
wrap_prag = InlinePragma
alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation`
Activation
activeDuringFinal
wrap_unf :: Unfolding
wrap_unf | TyCon -> Bool
isNewTyCon TyCon
tycon = CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
wrap_rhs
| Bool
otherwise = CoreExpr -> Unfolding
mkInlineUnfolding CoreExpr
wrap_rhs
wrap_rhs :: CoreExpr
wrap_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody TyCon
tycon [Type]
res_ty_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
wrap_body
; DataConRep -> UniqSM DataConRep
forall (m :: * -> *) a. Monad m => a -> m a
return (DCR :: Id
-> DataConBoxer
-> [Type]
-> [StrictnessMark]
-> [HsImplBang]
-> DataConRep
DCR { dcr_wrap_id :: Id
dcr_wrap_id = Id
wrap_id
, dcr_boxer :: DataConBoxer
dcr_boxer = [Boxer] -> DataConBoxer
mk_boxer [Boxer]
boxers
, dcr_arg_tys :: [Type]
dcr_arg_tys = [Type]
rep_tys
, dcr_stricts :: [StrictnessMark]
dcr_stricts = [StrictnessMark]
rep_strs
, dcr_bangs :: [HsImplBang]
dcr_bangs = [HsImplBang]
arg_ibangs }) }
where
([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Type]
orig_arg_tys, Type
_orig_res_ty)
= DataCon -> ([Id], [Id], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
data_con
wrap_tvs :: [Id]
wrap_tvs = DataCon -> [Id]
dataConUserTyVars DataCon
data_con
res_ty_args :: [Type]
res_ty_args = TCvSubst -> [Id] -> [Type]
substTyVars ([(Id, Type)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (Id, Type)) -> [EqSpec] -> [(Id, Type)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (Id, Type)
eqSpecPair [EqSpec]
eq_spec)) [Id]
univ_tvs
tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con
wrap_ty :: Type
wrap_ty = DataCon -> Type
dataConUserType DataCon
data_con
ev_tys :: [Type]
ev_tys = [EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta
all_arg_tys :: [Type]
all_arg_tys = [Type]
ev_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
orig_arg_tys
ev_ibangs :: [HsImplBang]
ev_ibangs = (Type -> HsImplBang) -> [Type] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Type -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Type]
ev_tys
orig_bangs :: [HsSrcBang]
orig_bangs = DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
data_con
wrap_arg_tys :: [Type]
wrap_arg_tys = [Type]
theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
orig_arg_tys
wrap_arity :: Int
wrap_arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isCoVar [Id]
ex_tvs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
wrap_arg_tys
new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
arg_ibangs :: [HsImplBang]
arg_ibangs
| Bool
new_tycon
= ASSERT( isSingleton orig_arg_tys )
[HsImplBang
HsLazy]
| Bool
otherwise
= case Maybe [HsImplBang]
mb_bangs of
Maybe [HsImplBang]
Nothing -> (Type -> HsSrcBang -> HsImplBang)
-> [Type] -> [HsSrcBang] -> [HsImplBang]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs)
[Type]
orig_arg_tys [HsSrcBang]
orig_bangs
Just [HsImplBang]
bangs -> [HsImplBang]
bangs
([[(Type, StrictnessMark)]]
rep_tys_w_strs, [(Unboxer, Boxer)]
wrappers)
= [([(Type, StrictnessMark)], (Unboxer, Boxer))]
-> ([[(Type, StrictnessMark)]], [(Unboxer, Boxer)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Type
-> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer)))
-> [Type]
-> [HsImplBang]
-> [([(Type, StrictnessMark)], (Unboxer, Boxer))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep [Type]
all_arg_tys ([HsImplBang]
ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs))
([Unboxer]
unboxers, [Boxer]
boxers) = [(Unboxer, Boxer)] -> ([Unboxer], [Boxer])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Unboxer, Boxer)]
wrappers
([Type]
rep_tys, [StrictnessMark]
rep_strs) = [(Type, StrictnessMark)] -> ([Type], [StrictnessMark])
forall a b. [(a, b)] -> ([a], [b])
unzip ([[(Type, StrictnessMark)]] -> [(Type, StrictnessMark)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Type, StrictnessMark)]]
rep_tys_w_strs)
wrapper_reqd :: Bool
wrapper_reqd =
(Bool -> Bool
not Bool
new_tycon
Bool -> Bool -> Bool
&& ((HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged ([HsImplBang]
ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs)
Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec)))
Bool -> Bool -> Bool
|| TyCon -> Bool
isFamInstTyCon TyCon
tycon
Bool -> Bool -> Bool
|| DataCon -> Bool
dataConUserTyVarsArePermuted DataCon
data_con
initial_wrap_app :: Expr b
initial_wrap_app = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
data_con)
Expr b -> [Type] -> Expr b
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
res_ty_args
Expr b -> [Id] -> Expr b
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ex_tvs
Expr b -> [Coercion] -> Expr b
forall b. Expr b -> [Coercion] -> Expr b
`mkCoApps` (EqSpec -> Coercion) -> [EqSpec] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> Type -> Coercion
mkReflCo Role
Nominal (Type -> Coercion) -> (EqSpec -> Type) -> EqSpec -> Coercion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EqSpec -> Type
eqSpecType) [EqSpec]
eq_spec
mk_boxer :: [Boxer] -> DataConBoxer
mk_boxer :: [Boxer] -> DataConBoxer
mk_boxer [Boxer]
boxers = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
DCB (\ [Type]
ty_args [Id]
src_vars ->
do { let ([Id]
ex_vars, [Id]
term_vars) = [Id] -> [Id] -> ([Id], [Id])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
ex_tvs [Id]
src_vars
subst1 :: TCvSubst
subst1 = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
ty_args
subst2 :: TCvSubst
subst2 = TCvSubst -> [Id] -> [Type] -> TCvSubst
extendTCvSubstList TCvSubst
subst1 [Id]
ex_tvs
([Id] -> [Type]
mkTyCoVarTys [Id]
ex_vars)
; ([Id]
rep_ids, [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst2 [Boxer]
boxers [Id]
term_vars
; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
rep_ids, [CoreBind]
binds) } )
go :: TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
_ [] [Id]
src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
go TCvSubst
subst (Boxer
UnitBox : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
= do { ([Id]
rep_ids2, [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst [Boxer]
boxers [Id]
src_vars
; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
src_var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rep_ids2, [CoreBind]
binds) }
go TCvSubst
subst (Boxer TCvSubst -> UniqSM ([Id], CoreExpr)
boxer : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
= do { ([Id]
rep_ids1, CoreExpr
arg) <- TCvSubst -> UniqSM ([Id], CoreExpr)
boxer TCvSubst
subst
; ([Id]
rep_ids2, [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst [Boxer]
boxers [Id]
src_vars
; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
rep_ids2, Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
src_var CoreExpr
arg CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds) }
go TCvSubst
_ (Boxer
_:[Boxer]
_) [] = String -> SDoc -> UniqSM ([Id], [CoreBind])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mk_boxer" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
data_con)
mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app :: [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app [] CoreExpr
con_app
= CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
con_app
mk_rep_app ((Id
wrap_arg, Unboxer
unboxer) : [(Id, Unboxer)]
prs) CoreExpr
con_app
= do { ([Id]
rep_ids, CoreExpr -> CoreExpr
unbox_fn) <- Unboxer
unboxer Id
wrap_arg
; CoreExpr
expr <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app [(Id, Unboxer)]
prs (CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps CoreExpr
con_app [Id]
rep_ids)
; CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
unbox_fn CoreExpr
expr) }
newLocal :: Type -> UniqSM Var
newLocal :: Type -> UniqSM Id
newLocal Type
ty = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; Id -> UniqSM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> Unique -> Type -> Id
mkSysLocalOrCoVar (String -> RuleName
fsLit String
"dt") Unique
uniq Type
ty) }
dataConSrcToImplBang
:: DynFlags
-> FamInstEnvs
-> Type
-> HsSrcBang
-> HsImplBang
dataConSrcToImplBang :: DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty
(HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
= DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty
(SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
SrcStrict)
| Bool
otherwise
= HsImplBang
HsLazy
dataConSrcToImplBang DynFlags
_ FamInstEnvs
_ Type
_ (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy)
= HsImplBang
HsLazy
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty
(HsSrcBang SourceText
_ SrcUnpackedness
unpk_prag SrcStrictness
SrcStrict)
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
= HsImplBang
HsLazy
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags)
, let mb_co :: Maybe (Coercion, Type)
mb_co = FamInstEnvs -> Type -> Maybe (Coercion, Type)
topNormaliseType_maybe FamInstEnvs
fam_envs Type
arg_ty
arg_ty' :: Type
arg_ty' = case Maybe (Coercion, Type)
mb_co of { Just (Coercion
_,Type
ty) -> Type
ty; Maybe (Coercion, Type)
Nothing -> Type
arg_ty }
, DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty'
, ([(Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
_) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
arg_ty'
, case SrcUnpackedness
unpk_prag of
SrcUnpackedness
NoSrcUnpack ->
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UnboxStrictFields DynFlags
dflags
Bool -> Bool -> Bool
|| (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UnboxSmallStrictFields DynFlags
dflags
Bool -> Bool -> Bool
&& [(Type, StrictnessMark)]
rep_tys [(Type, StrictnessMark)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
1)
SrcUnpackedness
srcUnpack -> SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
srcUnpack
= case Maybe (Coercion, Type)
mb_co of
Maybe (Coercion, Type)
Nothing -> Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing
Just (Coercion
co,Type
_) -> Maybe Coercion -> HsImplBang
HsUnpack (Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co)
| Bool
otherwise
= HsImplBang
HsStrict
dataConArgRep
:: Type
-> HsImplBang
-> ([(Type,StrictnessMark)]
,(Unboxer,Boxer))
dataConArgRep :: Type -> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep Type
arg_ty HsImplBang
HsLazy
= ([(Type
arg_ty, StrictnessMark
NotMarkedStrict)], (Unboxer
unitUnboxer, Boxer
unitBoxer))
dataConArgRep Type
arg_ty HsImplBang
HsStrict
= ([(Type
arg_ty, StrictnessMark
MarkedStrict)], (Unboxer
seqUnboxer, Boxer
unitBoxer))
dataConArgRep Type
arg_ty (HsUnpack Maybe Coercion
Nothing)
| ([(Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
arg_ty
= ([(Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers)
dataConArgRep Type
_ (HsUnpack (Just Coercion
co))
| let co_rep_ty :: Type
co_rep_ty = Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind Coercion
co)
, ([(Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
co_rep_ty
= ([(Type, StrictnessMark)]
rep_tys, Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo Coercion
co Type
co_rep_ty (Unboxer, Boxer)
wrappers)
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo Coercion
co Type
rep_ty (Unboxer
unbox_rep, Boxer
box_rep)
= (Unboxer
unboxer, Boxer
boxer)
where
unboxer :: Unboxer
unboxer Id
arg_id = do { Id
rep_id <- Type -> UniqSM Id
newLocal Type
rep_ty
; ([Id]
rep_ids, CoreExpr -> CoreExpr
rep_fn) <- Unboxer
unbox_rep Id
rep_id
; let co_bind :: CoreBind
co_bind = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
rep_id (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion
co)
; ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
co_bind (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
rep_fn) }
boxer :: Boxer
boxer = (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ TCvSubst
subst ->
do { ([Id]
rep_ids, CoreExpr
rep_expr)
<- case Boxer
box_rep of
Boxer
UnitBox -> do { Id
rep_id <- Type -> UniqSM Id
newLocal (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
TcType.substTy TCvSubst
subst Type
rep_ty)
; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
rep_id], Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rep_id) }
Boxer TCvSubst -> UniqSM ([Id], CoreExpr)
boxer -> TCvSubst -> UniqSM ([Id], CoreExpr)
boxer TCvSubst
subst
; let sco :: Coercion
sco = TCvSubst -> Coercion -> Coercion
substCoUnchecked TCvSubst
subst Coercion
co
; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr
rep_expr CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion -> Coercion
mkSymCo Coercion
sco) }
seqUnboxer :: Unboxer
seqUnboxer :: Unboxer
seqUnboxer Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v) Id
v)
unitUnboxer :: Unboxer
unitUnboxer :: Unboxer
unitUnboxer Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], \CoreExpr
e -> CoreExpr
e)
unitBoxer :: Boxer
unitBoxer :: Boxer
unitBoxer = Boxer
UnitBox
dataConArgUnpack
:: Type
-> ( [(Type, StrictnessMark)]
, (Unboxer, Boxer) )
dataConArgUnpack :: Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
arg_ty
| Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg_ty
, Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, let rep_tys :: [Type]
rep_tys = DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
con [Type]
tc_args
= ASSERT( null (dataConExTyCoVars con) )
( [Type]
rep_tys [Type] -> [StrictnessMark] -> [(Type, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
,( \ Id
arg_id ->
do { [Id]
rep_ids <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> UniqSM Id
newLocal [Type]
rep_tys
; let unbox_fn :: CoreExpr -> CoreExpr
unbox_fn CoreExpr
body
= CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id
(DataCon -> AltCon
DataAlt DataCon
con) [Id]
rep_ids CoreExpr
body
; ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr -> CoreExpr
unbox_fn) }
, (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ TCvSubst
subst ->
do { [Id]
rep_ids <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> UniqSM Id
newLocal (Type -> UniqSM Id) -> (Type -> Type) -> Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCvSubst -> Type -> Type
TcType.substTyUnchecked TCvSubst
subst) [Type]
rep_tys
; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)
CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` (TCvSubst -> [Type] -> [Type]
substTysUnchecked TCvSubst
subst [Type]
tc_args)
CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
rep_ids ) } ) )
| Bool
otherwise
= String -> SDoc -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dataConArgUnpack" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType DynFlags
dflags FamInstEnvs
fam_envs Type
ty
| Just DataCon
data_con <- Type -> Maybe DataCon
unpackable_type Type
ty
= NameSet -> DataCon -> Bool
ok_con_args NameSet
emptyNameSet DataCon
data_con
| Bool
otherwise
= Bool
False
where
ok_con_args :: NameSet -> DataCon -> Bool
ok_con_args NameSet
dcs DataCon
con
| Name
dc_name Name -> NameSet -> Bool
`elemNameSet` NameSet
dcs
= Bool
False
| Bool
otherwise
= ((Type, HsSrcBang) -> Bool) -> [(Type, HsSrcBang)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> (Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs')
(DataCon -> [Type]
dataConOrigArgTys DataCon
con [Type] -> [HsSrcBang] -> [(Type, HsSrcBang)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con)
where
dc_name :: Name
dc_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
con
dcs' :: NameSet
dcs' = NameSet
dcs NameSet -> Name -> NameSet
`extendNameSet` Name
dc_name
ok_arg :: NameSet -> (Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs (Type
ty, HsSrcBang
bang)
= Bool -> Bool
not (HsSrcBang -> Bool
attempt_unpack HsSrcBang
bang) Bool -> Bool -> Bool
|| NameSet -> Type -> Bool
ok_ty NameSet
dcs Type
norm_ty
where
norm_ty :: Type
norm_ty = FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_envs Type
ty
ok_ty :: NameSet -> Type -> Bool
ok_ty NameSet
dcs Type
ty
| Just DataCon
data_con <- Type -> Maybe DataCon
unpackable_type Type
ty
= NameSet -> DataCon -> Bool
ok_con_args NameSet
dcs DataCon
data_con
| Bool
otherwise
= Bool
True
attempt_unpack :: HsSrcBang -> Bool
attempt_unpack (HsSrcBang SourceText
_ SrcUnpackedness
SrcUnpack SrcStrictness
NoSrcStrict)
= Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
attempt_unpack (HsSrcBang SourceText
_ SrcUnpackedness
SrcUnpack SrcStrictness
SrcStrict)
= Bool
True
attempt_unpack (HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
SrcStrict)
= Bool
True
attempt_unpack (HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
NoSrcStrict)
= Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
attempt_unpack HsSrcBang
_ = Bool
False
unpackable_type :: Type -> Maybe DataCon
unpackable_type :: Type -> Maybe DataCon
unpackable_type Type
ty
| Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Just DataCon
data_con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
data_con)
= DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
data_con
| Bool
otherwise
= Maybe DataCon
forall a. Maybe a
Nothing
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody TyCon
tycon [Type]
args CoreExpr
result_expr
= ASSERT( isNewTyCon tycon )
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
result_expr (Coercion -> Coercion
mkSymCo Coercion
co)
where
co :: Coercion
co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tycon) [Type]
args []
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tycon [Type]
args CoreExpr
result_expr
= ASSERT( isNewTyCon tycon )
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
result_expr (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tycon) [Type]
args [])
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody TyCon
tycon [Type]
args CoreExpr
body
| Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
= CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
body (Coercion -> Coercion
mkSymCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
co_con [Type]
args []))
| Bool
otherwise
= CoreExpr
body
mkPrimOpId :: PrimOp -> Id
mkPrimOpId :: PrimOp -> Id
mkPrimOpId PrimOp
prim_op
= Id
id
where
([Id]
tyvars,[Type]
arg_tys,Type
res_ty, Int
arity, StrictSig
strict_sig) = PrimOp -> ([Id], [Type], Type, Int, StrictSig)
primOpSig PrimOp
prim_op
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id]
tyvars ([Type] -> Type -> Type
mkVisFunTys [Type]
arg_tys Type
res_ty)
name :: Name
name = Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
mkWiredInName Module
gHC_PRIM (PrimOp -> OccName
primOpOcc PrimOp
prim_op)
(Int -> Unique
mkPrimOpIdUnique (PrimOp -> Int
primOpTag PrimOp
prim_op))
(Id -> TyThing
AnId Id
id) BuiltInSyntax
UserSyntax
id :: Id
id = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (PrimOp -> IdDetails
PrimOpId PrimOp
prim_op) Name
name Type
ty IdInfo
info
info :: IdInfo
info = IdInfo
noCafIdInfo
IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo (Maybe CoreRule -> [CoreRule]
forall a. Maybe a -> [a]
maybeToList (Maybe CoreRule -> [CoreRule]) -> Maybe CoreRule -> [CoreRule]
forall a b. (a -> b) -> a -> b
$ Name -> PrimOp -> Maybe CoreRule
primOpRules Name
name PrimOp
prim_op)
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
res_ty
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId DynFlags
dflags Unique
uniq ForeignCall
fcall Type
ty
= ASSERT( noFreeVarsOfType ty )
IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (ForeignCall -> IdDetails
FCallId ForeignCall
fcall) Name
name Type
ty IdInfo
info
where
occ_str :: String
occ_str = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> SDoc
braces (ForeignCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignCall
fcall SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
name :: Name
name = Unique -> String -> Name
mkFCallName Unique
uniq String
occ_str
info :: IdInfo
info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
ty
([TyBinder]
bndrs, Type
_) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
ty
arity :: Int
arity = (TyBinder -> Bool) -> [TyBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count TyBinder -> Bool
isAnonTyCoBinder [TyBinder]
bndrs
strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
arity Demand
topDmd) DmdResult
topRes
mkDictFunId :: Name
-> [TyVar]
-> ThetaType
-> Class
-> [Type]
-> Id
mkDictFunId :: Name -> [Id] -> [Type] -> Class -> [Type] -> Id
mkDictFunId Name
dfun_name [Id]
tvs [Type]
theta Class
clas [Type]
tys
= IdDetails -> Name -> Type -> Id
mkExportedLocalId (Bool -> IdDetails
DFunId Bool
is_nt)
Name
dfun_name
Type
dfun_ty
where
is_nt :: Bool
is_nt = TyCon -> Bool
isNewTyCon (Class -> TyCon
classTyCon Class
clas)
dfun_ty :: Type
dfun_ty = [Id] -> [Type] -> Class -> [Type] -> Type
mkDictFunTy [Id]
tvs [Type]
theta Class
clas [Type]
tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy :: [Id] -> [Type] -> Class -> [Type] -> Type
mkDictFunTy [Id]
tvs [Type]
theta Class
clas [Type]
tys
= [Id] -> [Type] -> Type -> Type
mkSpecSigmaTy [Id]
tvs [Type]
theta (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys)
unsafeCoerceName, nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
magicDictName, coerceName, proxyName :: Name
unsafeCoerceName :: Name
unsafeCoerceName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"unsafeCoerce#") Unique
unsafeCoerceIdKey Id
unsafeCoerceId
nullAddrName :: Name
nullAddrName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"nullAddr#") Unique
nullAddrIdKey Id
nullAddrId
seqName :: Name
seqName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"seq") Unique
seqIdKey Id
seqId
realWorldName :: Name
realWorldName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"realWorld#") Unique
realWorldPrimIdKey Id
realWorldPrimId
voidPrimIdName :: Name
voidPrimIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"void#") Unique
voidPrimIdKey Id
voidPrimId
coercionTokenName :: Name
coercionTokenName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"coercionToken#") Unique
coercionTokenIdKey Id
coercionTokenId
magicDictName :: Name
magicDictName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"magicDict") Unique
magicDictKey Id
magicDictId
coerceName :: Name
coerceName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"coerce") Unique
coerceKey Id
coerceId
proxyName :: Name
proxyName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"proxy#") Unique
proxyHashKey Id
proxyHashId
lazyIdName, oneShotName, noinlineIdName :: Name
lazyIdName :: Name
lazyIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"lazy") Unique
lazyIdKey Id
lazyId
oneShotName :: Name
oneShotName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"oneShot") Unique
oneShotKey Id
oneShotId
noinlineIdName :: Name
noinlineIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"noinline") Unique
noinlineIdKey Id
noinlineId
proxyHashId :: Id
proxyHashId :: Id
proxyHashId
= Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
proxyName Type
ty
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty )
where
[Id
kv,Id
tv] = [Type] -> ([Type] -> [Type]) -> [Id]
mkTemplateKiTyVars [Type
liftedTypeKind] [Type] -> [Type]
forall a. a -> a
id
kv_ty :: Type
kv_ty = Id -> Type
mkTyVarTy Id
kv
tv_ty :: Type
tv_ty = Id -> Type
mkTyVarTy Id
tv
ty :: Type
ty = Id -> Type -> Type
mkInvForAllTy Id
kv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Id -> Type -> Type
mkSpecForAllTy Id
tv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkProxyPrimTy Type
kv_ty Type
tv_ty
unsafeCoerceId :: Id
unsafeCoerceId :: Id
unsafeCoerceId
= Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
unsafeCoerceName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
bndrs :: [Id]
bndrs = [Type] -> ([Type] -> [Type]) -> [Id]
mkTemplateKiTyVars [Type
runtimeRepTy, Type
runtimeRepTy]
(\[Type]
ks -> (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
tYPE [Type]
ks)
[Type
_, Type
_, Type
a, Type
b] = [Id] -> [Type]
mkTyVarTys [Id]
bndrs
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id]
bndrs (Type -> Type -> Type
mkVisFunTy Type
a Type
b)
[Id
x] = [Type] -> [Id]
mkTemplateLocals [Type
a]
rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
x]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Role -> Type -> Type -> Coercion
mkUnsafeCo Role
Representational Type
a Type
b)
nullAddrId :: Id
nullAddrId :: Id
nullAddrId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
nullAddrName Type
addrPrimTy IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
nullAddrLit)
HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
addrPrimTy
seqId :: Id
seqId :: Id
seqId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
seqName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
inline_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
inline_prag :: InlinePragma
inline_prag
= InlinePragma
alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` SourceText -> Int -> Activation
ActiveAfter
SourceText
NoSourceText Int
0
ty :: Type
ty =
Id -> Type -> Type
mkInvForAllTy Id
runtimeRep2TyVar
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar, Id
openBetaTyVar]
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkVisFunTy Type
alphaTy (Type -> Type -> Type
mkVisFunTy Type
openBetaTy Type
openBetaTy)
[Id
x,Id
y] = [Type] -> [Id]
mkTemplateLocals [Type
alphaTy, Type
openBetaTy]
rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id
runtimeRep2TyVar, Id
alphaTyVar, Id
openBetaTyVar, Id
x, Id
y]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) Id
x Type
openBetaTy [(AltCon
DEFAULT, [], Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)]
lazyId :: Id
lazyId :: Id
lazyId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
lazyIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTy Type
alphaTy Type
alphaTy)
noinlineId :: Id
noinlineId :: Id
noinlineId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
noinlineIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTy Type
alphaTy Type
alphaTy)
oneShotId :: Id
oneShotId :: Id
oneShotId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
oneShotName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
, Id
openAlphaTyVar, Id
openBetaTyVar ]
(Type -> Type -> Type
mkVisFunTy Type
fun_ty Type
fun_ty)
fun_ty :: Type
fun_ty = Type -> Type -> Type
mkVisFunTy Type
openAlphaTy Type
openBetaTy
[Id
body, Id
x] = [Type] -> [Id]
mkTemplateLocals [Type
fun_ty, Type
openAlphaTy]
x' :: Id
x' = Id -> Id
setOneShotLambda Id
x
rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
, Id
openAlphaTyVar, Id
openBetaTyVar
, Id
body, Id
x'] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Id -> CoreExpr
forall b. Id -> Expr b
Var Id
body CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x
magicDictId :: Id
magicDictId :: Id
magicDictId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
magicDictName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] Type
alphaTy
coerceId :: Id
coerceId :: Id
coerceId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
coerceName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
eqRTy :: Type
eqRTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
coercibleTyCon [ Type -> Type
tYPE Type
r , Type
a, Type
b ]
eqRPrimTy :: Type
eqRPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [ Type -> Type
tYPE Type
r, Type -> Type
tYPE Type
r, Type
a, Type
b ]
ty :: Type
ty = [TyVarBinder] -> Type -> Type
mkForAllTys [ Id -> ArgFlag -> TyVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
rv ArgFlag
Inferred
, Id -> ArgFlag -> TyVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
av ArgFlag
Specified
, Id -> ArgFlag -> TyVarBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
bv ArgFlag
Specified
] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkInvisFunTy Type
eqRTy (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkVisFunTy Type
a Type
b
bndrs :: [Id]
bndrs@[Id
rv,Id
av,Id
bv] = Type -> (Type -> [Type]) -> [Id]
mkTemplateKiTyVar Type
runtimeRepTy
(\Type
r -> [Type -> Type
tYPE Type
r, Type -> Type
tYPE Type
r])
[Type
r, Type
a, Type
b] = [Id] -> [Type]
mkTyVarTys [Id]
bndrs
[Id
eqR,Id
x,Id
eq] = [Type] -> [Id]
mkTemplateLocals [Type
eqRTy, Type
a, Type
eqRPrimTy]
rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
eqR, Id
x]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Type -> Type -> [Alt Id] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqR) Type
eqRTy Type
b ([Alt Id] -> CoreExpr) -> [Alt Id] -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[(DataCon -> AltCon
DataAlt DataCon
coercibleDataCon, [Id
eq], CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Id -> Coercion
mkCoVarCo Id
eq))]
realWorldPrimId :: Id
realWorldPrimId :: Id
realWorldPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
realWorldName Type
realWorldStatePrimTy
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` OneShotInfo
stateHackOneShot
HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
realWorldStatePrimTy)
voidPrimId :: Id
voidPrimId :: Id
voidPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
voidPrimIdName Type
voidPrimTy
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
voidPrimTy)
voidArgId :: Id
voidArgId :: Id
voidArgId = RuleName -> Unique -> Type -> Id
mkSysLocal (String -> RuleName
fsLit String
"void") Unique
voidArgIdKey Type
voidPrimTy
coercionTokenId :: Id
coercionTokenId :: Id
coercionTokenId
= Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
coercionTokenName
(TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
liftedTypeKind, Type
liftedTypeKind, Type
unitTy, Type
unitTy])
IdInfo
noCafIdInfo
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
name Type
ty IdInfo
info
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
ty IdInfo
info