{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Types.Id.Make (
mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
mkPrimOpId, mkFCallId,
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
wiredInIds, ghcPrimIds,
realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, magicDictId, coerceId,
proxyHashId, noinlineId, noinlineIdName,
coerceName, leftSectionName, rightSectionName,
module GHC.Core.Opt.ConstantFold
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Core.Opt.ConstantFold
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Tc.Utils.TcType as TcType
import GHC.Core.Make
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase )
import GHC.Core.Unfold.Make
import GHC.Core.SimpleOpt
import GHC.Types.Literal
import GHC.Types.SourceText
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Types.Name.Set
import GHC.Types.Name
import GHC.Builtin.PrimOps
import GHC.Types.ForeignCall
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.TyThing
import GHC.Core
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Types.Unique.Supply
import GHC.Builtin.Names
import GHC.Types.Basic hiding ( SuccessFlag(..) )
import GHC.Utils.Misc
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Types.Var (VarBndr(Bndr))
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe ( maybeToList )
wiredInIds :: [Id]
wiredInIds :: [Id]
wiredInIds
= [Id]
magicIds
forall a. [a] -> [a] -> [a]
++ [Id]
ghcPrimIds
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
nullAddrId
, Id
seqId
, Id
magicDictId
, Id
coerceId
, Id
proxyHashId
, Id
leftSectionId
, Id
rightSectionId
]
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 = 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 :: [InvisTVBinder]
tyvars = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
data_con
n_ty_args :: Arity
n_ty_args = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [InvisTVBinder]
tyvars
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
data_con
val_index :: Arity
val_index = forall a b. Eq a => String -> Assoc a b -> a -> b
assoc String
"MkId.mkDictSelId" ([Name]
sel_names forall a b. [a] -> [b] -> [(a, b)]
`zip` [Arity
0..]) Name
name
sel_ty :: Type
sel_ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
tyvars forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkInvisFunTyMany (Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tyvars))) forall a b. (a -> b) -> a -> b
$
forall a. Scaled a -> a
scaledThing (forall a. Outputable a => [a] -> Arity -> a
getNth [Scaled Type]
arg_tys Arity
val_index)
base_info :: IdInfo
base_info = IdInfo
noCafIdInfo
IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
1
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` CprSig
topCprSig
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` Arity -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Arity
1
SimpleOpts
defaultSimpleOpts
(Class -> Arity -> CoreExpr
mkDictSelRhs Class
clas Arity
val_index)
| Bool
otherwise
= IdInfo
base_info IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule
rule]
rule :: CoreRule
rule = BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"Class op " RuleName -> RuleName -> RuleName
`appendFS`
OccName -> RuleName
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Name
name)
, ru_fn :: Name
ru_fn = Name
name
, ru_nargs :: Arity
ru_nargs = Arity
n_ty_args forall a. Num a => a -> a -> a
+ Arity
1
, ru_try :: RuleFun
ru_try = Arity -> Arity -> RuleFun
dictSelRule Arity
val_index Arity
n_ty_args }
strict_sig :: StrictSig
strict_sig = [Demand] -> Divergence -> StrictSig
mkClosedStrictSig [Demand
arg_dmd] Divergence
topDiv
arg_dmd :: Demand
arg_dmd | Bool
new_tycon = Demand
evalDmd
| Bool
otherwise = Card
C_1N Card -> SubDemand -> Demand
:*
[Demand] -> SubDemand
Prod [ if Name
name 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 -> Arity -> CoreExpr
mkDictSelRhs Class
clas Arity
val_index
= forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (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 :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
data_con
the_arg_id :: Id
the_arg_id = forall a. Outputable a => [a] -> Arity -> a
getNth [Id]
arg_ids Arity
val_index
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
dict_id :: Id
dict_id = Arity -> Type -> Id
mkTemplateLocal Arity
1 Type
pred
arg_ids :: [Id]
arg_ids = Arity -> [Type] -> [Id]
mkTemplateLocalsNum Arity
2 (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
rhs_body :: CoreExpr
rhs_body | Bool
new_tycon = TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tycon ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
(forall b. Id -> Expr b
Var Id
dict_id)
| Bool
otherwise = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (forall b. Id -> Expr b
Var Id
dict_id) Id
dict_id (DataCon -> AltCon
DataAlt DataCon
data_con)
[Id]
arg_ids (forall b. Id -> Expr b
varToCoreExpr Id
the_arg_id)
dictSelRule :: Int -> Arity -> RuleFun
dictSelRule :: Arity -> Arity -> RuleFun
dictSelRule Arity
val_index Arity
n_ty_args RuleOpts
_ InScopeEnv
id_unf Id
_ [CoreExpr]
args
| (CoreExpr
dict_arg : [CoreExpr]
_) <- forall a. Arity -> [a] -> [a]
drop Arity
n_ty_args [CoreExpr]
args
, Just (InScopeSet
_, [FloatBind]
floats, DataCon
_, [Type]
_, [CoreExpr]
con_args) <- HasDebugCallStack =>
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
id_unf CoreExpr
dict_arg
= forall a. a -> Maybe a
Just ([FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => [a] -> Arity -> a
getNth [CoreExpr]
con_args Arity
val_index)
| Bool
otherwise
= 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 -> Arity -> IdInfo
`setArityInfo` Arity
wkr_arity
IdInfo -> CprSig -> IdInfo
`setCprInfo` Arity -> Cpr -> CprSig
mkCprSig Arity
wkr_arity (DataCon -> Cpr
dataConCPR DataCon
data_con)
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
wkr_inline_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
wkr_inline_prag :: InlinePragma
wkr_inline_prag = InlinePragma
defaultInlinePragma { inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
ConLike }
wkr_arity :: Arity
wkr_arity = DataCon -> Arity
dataConRepArity DataCon
data_con
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
data_con
nt_work_info :: IdInfo
nt_work_info = IdInfo
noCafIdInfo
IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
1
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
dataConWrapperInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
newtype_unf
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
id_arg1 :: Id
id_arg1 = Arity -> Scaled Type -> Id
mkScaledTemplateLocal Arity
1 (forall a. [a] -> a
head [Scaled 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 )
SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts forall a b. (a -> b) -> a -> b
$
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
univ_tvs forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Expr b
Lam Id
id_arg1 forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody TyCon
tycon [Type]
res_ty_args (forall b. Id -> Expr b
Var Id
id_arg1)
dataConCPR :: DataCon -> Cpr
dataConCPR :: DataCon -> Cpr
dataConCPR DataCon
con
| TyCon -> Bool
isDataTyCon TyCon
tycon
, forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con)
, Arity
wkr_arity forall a. Ord a => a -> a -> Bool
> Arity
0
, Arity
wkr_arity forall a. Ord a => a -> a -> Bool
<= Arity
mAX_CPR_SIZE
= Arity -> Cpr
flatConCpr (DataCon -> Arity
dataConTag DataCon
con)
| Bool
otherwise
= Cpr
topCpr
where
tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
con
wkr_arity :: Arity
wkr_arity = DataCon -> Arity
dataConRepArity DataCon
con
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = Arity
10
type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
vanillaDataConBoxer :: DataConBoxer
vanillaDataConBoxer :: DataConBoxer
vanillaDataConBoxer = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
DCB (\[Type]
_tys [Id]
args -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
args, []))
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
= forall (m :: * -> *) a. Monad m => a -> m a
return DataConRep
NoDataConRep
| Bool
otherwise
= do { [Id]
wrap_args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Scaled Type -> UniqSM Id
newLocal [Scaled Type]
wrap_arg_tys
; CoreExpr
wrap_body <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app ([Id]
wrap_args forall a b. [a] -> [b] -> [(a, b)]
`zip` forall b a. [b] -> [a] -> [a]
dropList [EqSpec]
eq_spec [Unboxer]
unboxers)
CoreExpr
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 -> Arity -> IdInfo
`setArityInfo` Arity
wrap_arity
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
wrap_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
wrap_unf
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
wrap_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` Arity -> Cpr -> CprSig
mkCprSig Arity
wrap_arity (DataCon -> Cpr
dataConCPR DataCon
data_con)
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wrap_ty
wrap_sig :: StrictSig
wrap_sig = [Demand] -> Divergence -> StrictSig
mkClosedStrictSig [Demand]
wrap_arg_dmds Divergence
topDiv
wrap_arg_dmds :: [Demand]
wrap_arg_dmds =
forall a. Arity -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
theta) Demand
topDmd forall a. [a] -> [a] -> [a]
++ 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
dataConWrapperInlinePragma
InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` Activation
activateDuringFinal
wrap_unf :: Unfolding
wrap_unf | TyCon -> Bool
isNewTyCon TyCon
tycon = SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
wrap_rhs
| Bool
otherwise = SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
wrap_rhs
wrap_rhs :: CoreExpr
wrap_rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_tvs forall a b. (a -> b) -> a -> b
$
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_args forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody TyCon
tycon [Type]
res_ty_args forall a b. (a -> b) -> a -> b
$
CoreExpr
wrap_body
; forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: [Scaled Type]
dcr_arg_tys = [Scaled 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, [Scaled Type]
orig_arg_tys, Type
_orig_res_ty)
= DataCon -> ([Id], [Id], [EqSpec], [Type], [Scaled 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 (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
dataConWrapperType DataCon
data_con
ev_tys :: [Type]
ev_tys = [EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec forall a. [a] -> [a] -> [a]
++ [Type]
theta
all_arg_tys :: [Scaled Type]
all_arg_tys = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Scaled a
unrestricted [Type]
ev_tys forall a. [a] -> [a] -> [a]
++ [Scaled Type]
orig_arg_tys
ev_ibangs :: [HsImplBang]
ev_ibangs = forall a b. (a -> b) -> [a] -> [b]
map (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 :: [Scaled Type]
wrap_arg_tys = (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Scaled a
unrestricted [Type]
theta) forall a. [a] -> [a] -> [a]
++ [Scaled Type]
orig_arg_tys
wrap_arity :: Arity
wrap_arity = forall a. (a -> Bool) -> [a] -> Arity
count Id -> Bool
isCoVar [Id]
ex_tvs forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Scaled Type]
wrap_arg_tys
new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
arg_ibangs :: [HsImplBang]
arg_ibangs
| Bool
new_tycon
= forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const HsImplBang
HsLazy) [Scaled Type]
orig_arg_tys
| Bool
otherwise
= case Maybe [HsImplBang]
mb_bangs of
Maybe [HsImplBang]
Nothing -> forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DynFlags -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs)
[Scaled Type]
orig_arg_tys [HsSrcBang]
orig_bangs
Just [HsImplBang]
bangs -> [HsImplBang]
bangs
([[(Scaled Type, StrictnessMark)]]
rep_tys_w_strs, [(Unboxer, Boxer)]
wrappers)
= forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Scaled Type
-> HsImplBang
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep [Scaled Type]
all_arg_tys ([HsImplBang]
ev_ibangs forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs))
([Unboxer]
unboxers, [Boxer]
boxers) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Unboxer, Boxer)]
wrappers
([Scaled Type]
rep_tys, [StrictnessMark]
rep_strs) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Scaled Type, StrictnessMark)]]
rep_tys_w_strs)
wrapper_reqd :: Bool
wrapper_reqd =
(Bool -> Bool
not Bool
new_tycon
Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged ([HsImplBang]
ev_ibangs forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs)
Bool -> Bool -> Bool
|| (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 :: CoreExpr
initial_wrap_app = forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
data_con)
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
res_ty_args
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ex_tvs
forall b. Expr b -> [Coercion] -> Expr b
`mkCoApps` forall a b. (a -> b) -> [a] -> [b]
map (Role -> Type -> Coercion
mkReflCo Role
Nominal 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) = forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
ex_tvs [Id]
src_vars
subst1 :: TCvSubst
subst1 = 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
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_vars 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
src_var 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
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids1 forall a. [a] -> [a] -> [a]
++ [Id]
rep_ids2, forall b. b -> Expr b -> Bind b
NonRec Id
src_var CoreExpr
arg forall a. a -> [a] -> [a]
: [CoreBind]
binds) }
go TCvSubst
_ (Boxer
_:[Boxer]
_) [] = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mk_boxer" (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
= 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 (forall b. Expr b -> [Id] -> Expr b
mkVarApps CoreExpr
con_app [Id]
rep_ids)
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
unbox_fn CoreExpr
expr) }
dataConWrapperInlinePragma :: InlinePragma
dataConWrapperInlinePragma :: InlinePragma
dataConWrapperInlinePragma = InlinePragma
alwaysInlinePragma { inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
ConLike
, inl_inline :: InlineSpec
inl_inline = InlineSpec
Inline }
newLocal :: Scaled Type -> UniqSM Var
newLocal :: Scaled Type -> UniqSM Id
newLocal (Scaled Type
w Type
ty) = do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> RuleName
fsLit String
"dt") Unique
uniq Type
w Type
ty) }
dataConSrcToImplBang
:: DynFlags
-> FamInstEnvs
-> Scaled Type
-> HsSrcBang
-> HsImplBang
dataConSrcToImplBang :: DynFlags -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Scaled Type
arg_ty
(HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
= DynFlags -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Scaled Type
arg_ty
(SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
SrcStrict)
| Bool
otherwise
= HsImplBang
HsLazy
dataConSrcToImplBang DynFlags
_ FamInstEnvs
_ Scaled Type
_ (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy)
= HsImplBang
HsLazy
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Scaled Type
arg_ty
(HsSrcBang SourceText
_ SrcUnpackedness
unpk_prag SrcStrictness
SrcStrict)
| HasDebugCallStack => Type -> Bool
isUnliftedType (forall a. Scaled a -> a
scaledThing Scaled 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 (forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
arg_ty' :: Scaled Type
arg_ty' = case Maybe (Coercion, Type)
mb_co of { Just (Coercion
_,Type
ty) -> forall a b. Scaled a -> b -> Scaled b
scaledSet Scaled Type
arg_ty Type
ty; Maybe (Coercion, Type)
Nothing -> Scaled Type
arg_ty }
, DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType DynFlags
dflags FamInstEnvs
fam_envs (forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty')
, ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
_) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled 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
&& [(Scaled Type, StrictnessMark)]
rep_tys forall a. [a] -> Arity -> Bool
`lengthAtMost` Arity
1)
SrcUnpackedness
srcUnpack -> SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
srcUnpack
= case Maybe (Coercion, Type)
mb_co of
Maybe (Coercion, Type)
Nothing -> Maybe Coercion -> HsImplBang
HsUnpack forall a. Maybe a
Nothing
Just (Coercion
co,Type
_) -> Maybe Coercion -> HsImplBang
HsUnpack (forall a. a -> Maybe a
Just Coercion
co)
| Bool
otherwise
= HsImplBang
HsStrict
dataConArgRep
:: Scaled Type
-> HsImplBang
-> ([(Scaled Type,StrictnessMark)]
,(Unboxer,Boxer))
dataConArgRep :: Scaled Type
-> HsImplBang
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep Scaled Type
arg_ty HsImplBang
HsLazy
= ([(Scaled Type
arg_ty, StrictnessMark
NotMarkedStrict)], (Unboxer
unitUnboxer, Boxer
unitBoxer))
dataConArgRep Scaled Type
arg_ty HsImplBang
HsStrict
= ([(Scaled Type
arg_ty, StrictnessMark
MarkedStrict)], (Unboxer
seqUnboxer, Boxer
unitBoxer))
dataConArgRep Scaled Type
arg_ty (HsUnpack Maybe Coercion
Nothing)
| ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled Type
arg_ty
= ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers)
dataConArgRep (Scaled Type
w Type
_) (HsUnpack (Just Coercion
co))
| let co_rep_ty :: Type
co_rep_ty = Coercion -> Type
coercionRKind Coercion
co
, ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack (forall a. Type -> a -> Scaled a
Scaled Type
w Type
co_rep_ty)
= ([(Scaled 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 <- Scaled Type -> UniqSM Id
newLocal (forall a. Type -> a -> Scaled a
Scaled (Id -> Type
idMult Id
arg_id) Type
rep_ty)
; ([Id]
rep_ids, CoreExpr -> CoreExpr
rep_fn) <- Unboxer
unbox_rep Id
rep_id
; let co_bind :: CoreBind
co_bind = forall b. b -> Expr b -> Bind b
NonRec Id
rep_id (forall b. Id -> Expr b
Var Id
arg_id forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion
co)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, forall b. Bind b -> Expr b -> Expr b
Let CoreBind
co_bind forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
rep_fn) }
boxer :: Boxer
boxer = (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
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 <- Scaled Type -> UniqSM Id
newLocal (forall a. a -> Scaled a
linear forall a b. (a -> b) -> a -> b
$ HasCallStack => TCvSubst -> Type -> Type
TcType.substTy TCvSubst
subst Type
rep_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
rep_id], 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
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr
rep_expr forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion -> Coercion
mkSymCo Coercion
sco) }
seqUnboxer :: Unboxer
seqUnboxer :: Unboxer
seqUnboxer Id
v = forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (forall b. Id -> Expr b
Var Id
v) Id
v)
unitUnboxer :: Unboxer
unitUnboxer :: Unboxer
unitUnboxer Id
v = forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], \CoreExpr
e -> CoreExpr
e)
unitBoxer :: Boxer
unitBoxer :: Boxer
unitBoxer = Boxer
UnitBox
dataConArgUnpack
:: Scaled Type
-> ( [(Scaled Type, StrictnessMark)]
, (Unboxer, Boxer) )
dataConArgUnpack :: Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack (Scaled Type
arg_mult Type
arg_ty)
| Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg_ty
, Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, let rep_tys :: [Scaled Type]
rep_tys = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Type -> Scaled a -> Scaled a
scaleScaled Type
arg_mult) forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
con [Type]
tc_args
= ASSERT( null (dataConExTyCoVars con) )
( [Scaled Type]
rep_tys forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
,( \ Id
arg_id ->
do { [Id]
rep_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Scaled Type -> UniqSM Id
newLocal [Scaled Type]
rep_tys
; let r_mult :: Type
r_mult = Id -> Type
idMult Id
arg_id
; let rep_ids' :: [Id]
rep_ids' = forall a b. (a -> b) -> [a] -> [b]
map (Type -> Id -> Id
scaleIdBy Type
r_mult) [Id]
rep_ids
; let unbox_fn :: CoreExpr -> CoreExpr
unbox_fn CoreExpr
body
= CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id
(DataCon -> AltCon
DataAlt DataCon
con) [Id]
rep_ids' CoreExpr
body
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr -> CoreExpr
unbox_fn) }
, (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer forall a b. (a -> b) -> a -> b
$ \ TCvSubst
subst ->
do { [Id]
rep_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Scaled Type -> UniqSM Id
newLocal forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => TCvSubst -> Scaled Type -> Scaled Type
TcType.substScaledTyUnchecked TCvSubst
subst) [Scaled Type]
rep_tys
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` (TCvSubst -> [Type] -> [Type]
substTysUnchecked TCvSubst
subst [Type]
tc_args)
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
rep_ids ) } ) )
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dataConArgUnpack" (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
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs')
(DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con)
where
dc_name :: Name
dc_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 -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs (Scaled Type
_ 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])
splitTyConApp_maybe Type
ty
, Just DataCon
data_con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
data_con)
= forall a. a -> Maybe a
Just DataCon
data_con
| Bool
otherwise
= 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, Arity
arity, StrictSig
strict_sig) = PrimOp -> ([Id], [Type], Type, Arity, StrictSig)
primOpSig PrimOp
prim_op
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id]
tyvars ([Type] -> Type -> Type
mkVisFunTysMany [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)
(Arity -> Unique
mkPrimOpIdUnique (PrimOp -> Arity
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
cpr :: Cpr
cpr
| Divergence -> Bool
isDeadEndDiv (forall a b. (a, b) -> b
snd (StrictSig -> ([Demand], Divergence)
splitStrictSig StrictSig
strict_sig)) = Cpr
botCpr
| Bool
otherwise = Cpr
topCpr
info :: IdInfo
info = IdInfo
noCafIdInfo
IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo (forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Name -> PrimOp -> Maybe CoreRule
primOpRules Name
name PrimOp
prim_op)
IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` Arity -> Cpr -> CprSig
mkCprSig Arity
arity Cpr
cpr
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 (forall a. Outputable a => a -> SDoc
ppr ForeignCall
fcall SDoc -> SDoc -> 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 -> Arity -> IdInfo
`setArityInfo` Arity
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` CprSig
topCprSig
IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
ty
([TyBinder]
bndrs, Type
_) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
ty
arity :: Arity
arity = forall a. (a -> Bool) -> [a] -> Arity
count TyBinder -> Bool
isAnonTyCoBinder [TyBinder]
bndrs
strict_sig :: StrictSig
strict_sig = [Demand] -> Divergence -> StrictSig
mkClosedStrictSig (forall a. Arity -> a -> [a]
replicate Arity
arity Demand
topDmd) Divergence
topDiv
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)
nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
magicDictName, coerceName, proxyName,
leftSectionName, rightSectionName :: Name
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
leftSectionName :: Name
leftSectionName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"leftSection") Unique
leftSectionKey Id
leftSectionId
rightSectionName :: Name
rightSectionName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM (String -> RuleName
fsLit String
"rightSection") Unique
rightSectionKey Id
rightSectionId
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
`setNeverLevPoly` Type
ty)
where
[Id
kv,Id
tv] = [Type] -> ([Type] -> [Type]) -> [Id]
mkTemplateKiTyVars [Type
liftedTypeKind] 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
mkInfForAllTy Id
kv forall a b. (a -> b) -> a -> b
$ Id -> Type -> Type
mkSpecForAllTy Id
tv forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkProxyPrimTy Type
kv_ty Type
tv_ty
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` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts (forall b. Literal -> Expr b
Lit Literal
nullAddrLit)
HasDebugCallStack => 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` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
rhs
inline_prag :: InlinePragma
inline_prag
= InlinePragma
alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` SourceText -> Arity -> Activation
ActiveAfter
SourceText
NoSourceText Arity
0
ty :: Type
ty =
Id -> Type -> Type
mkInfForAllTy Id
runtimeRep2TyVar
forall a b. (a -> b) -> a -> b
$ [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar, Id
openBetaTyVar]
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkVisFunTyMany Type
alphaTy (Type -> Type -> Type
mkVisFunTyMany Type
openBetaTy Type
openBetaTy)
[Id
x,Id
y] = [Type] -> [Id]
mkTemplateLocals [Type
alphaTy, Type
openBetaTy]
rhs :: CoreExpr
rhs = forall b. [b] -> Expr b -> Expr b
mkLams ([Id
runtimeRep2TyVar, Id
alphaTyVar, Id
openBetaTyVar, Id
x, Id
y]) forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (forall b. Id -> Expr b
Var Id
x) Id
x Type
openBetaTy [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (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
`setNeverLevPoly` Type
ty
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTyMany 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
`setNeverLevPoly` Type
ty
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTyMany 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` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
rhs
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar ] forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [ Id
openAlphaTyVar, Id
openBetaTyVar ] forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkVisFunTyMany Type
fun_ty Type
fun_ty
fun_ty :: Type
fun_ty = Type -> Type -> Type
mkVisFunTyMany 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 = forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
, Id
openAlphaTyVar, Id
openBetaTyVar
, Id
body, Id
x'] forall a b. (a -> b) -> a -> b
$
forall b. Id -> Expr b
Var Id
body forall b. Expr b -> Expr b -> Expr b
`App` forall b. Id -> Expr b
Var Id
x'
leftSectionId :: Id
leftSectionId :: Id
leftSectionId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
leftSectionName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
rhs
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar, Id
multiplicityTyVar1] forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar, Id
openBetaTyVar] forall a b. (a -> b) -> a -> b
$
CoreExpr -> Type
exprType CoreExpr
body
[Id
f,Id
x] = [Type] -> [Id]
mkTemplateLocals [Type -> Type -> Type -> Type
mkVisFunTy Type
mult Type
openAlphaTy Type
openBetaTy, Type
openAlphaTy]
mult :: Type
mult = Id -> Type
mkTyVarTy Id
multiplicityTyVar1 :: Mult
xmult :: Id
xmult = Id -> Type -> Id
setIdMult Id
x Type
mult
rhs :: CoreExpr
rhs = forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar, Id
multiplicityTyVar1
, Id
openAlphaTyVar, Id
openBetaTyVar ] CoreExpr
body
body :: CoreExpr
body = forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
xmult] forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
f) (forall b. Id -> Expr b
Var Id
xmult)
rightSectionId :: Id
rightSectionId :: Id
rightSectionId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
rightSectionName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts CoreExpr
rhs
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar,Id
runtimeRep3TyVar
, Id
multiplicityTyVar1, Id
multiplicityTyVar2 ] forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar, Id
openBetaTyVar, Id
openGammaTyVar ] forall a b. (a -> b) -> a -> b
$
CoreExpr -> Type
exprType CoreExpr
body
mult1 :: Type
mult1 = Id -> Type
mkTyVarTy Id
multiplicityTyVar1
mult2 :: Type
mult2 = Id -> Type
mkTyVarTy Id
multiplicityTyVar2
[Id
f,Id
x,Id
y] = [Type] -> [Id]
mkTemplateLocals [ [Scaled Type] -> Type -> Type
mkVisFunTys [ forall a. Type -> a -> Scaled a
Scaled Type
mult1 Type
openAlphaTy
, forall a. Type -> a -> Scaled a
Scaled Type
mult2 Type
openBetaTy ] Type
openGammaTy
, Type
openAlphaTy, Type
openBetaTy ]
xmult :: Id
xmult = Id -> Type -> Id
setIdMult Id
x Type
mult1
ymult :: Id
ymult = Id -> Type -> Id
setIdMult Id
y Type
mult2
rhs :: CoreExpr
rhs = forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar, Id
runtimeRep3TyVar
, Id
multiplicityTyVar1, Id
multiplicityTyVar2
, Id
openAlphaTyVar, Id
openBetaTyVar, Id
openGammaTyVar ] CoreExpr
body
body :: CoreExpr
body = forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
ymult,Id
xmult] forall a b. (a -> b) -> a -> b
$ forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
f) [Id
xmult,Id
ymult]
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
`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` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts 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 = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [ forall var argf. var -> argf -> VarBndr var argf
Bndr Id
rv Specificity
InferredSpec
, forall var argf. var -> argf -> VarBndr var argf
Bndr Id
av Specificity
SpecifiedSpec
, forall var argf. var -> argf -> VarBndr var argf
Bndr Id
bv Specificity
SpecifiedSpec
] forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkInvisFunTyMany Type
eqRTy forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkVisFunTyMany 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 = forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
bndrs forall a. [a] -> [a] -> [a]
++ [Id
eqR, Id
x]) forall a b. (a -> b) -> a -> b
$
CoreExpr -> Scaled Type -> Type -> [Alt Id] -> CoreExpr
mkWildCase (forall b. Id -> Expr b
Var Id
eqR) (forall a. a -> Scaled a
unrestricted Type
eqRTy) Type
b forall a b. (a -> b) -> a -> b
$
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
coercibleDataCon) [Id
eq] (forall b. Expr b -> Coercion -> Expr b
Cast (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
`setNeverLevPoly` Type
realWorldStatePrimTy)
voidPrimId :: Id
voidPrimId :: Id
voidPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
voidPrimIdName Type
unboxedUnitTy
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
defaultSimpleOpts forall {b}. Expr b
rhs
HasDebugCallStack => IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
unboxedUnitTy)
where rhs :: Expr b
rhs = forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
unboxedUnitDataCon)
voidArgId :: Id
voidArgId :: Id
voidArgId = RuleName -> Unique -> Type -> Type -> Id
mkSysLocal (String -> RuleName
fsLit String
"void") Unique
voidArgIdKey Type
Many Type
unboxedUnitTy
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