{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE DataKinds #-}
module GHC.Types.Id.Make (
mkDictFunId, mkDictSelId, mkDictSelRhs,
mkFCallId,
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
DataConBangOpts (..), BangOpts (..),
unboxedUnitExpr,
wiredInIds, ghcPrimIds,
realWorldPrimId,
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, coerceId,
proxyHashId,
nospecId, nospecIdName,
noinlineId, noinlineIdName,
noinlineConstraintId, noinlineConstraintIdName,
coerceName, leftSectionName, rightSectionName,
pcRepPolyId,
mkRepPolyIdConcreteTyVars,
) where
import GHC.Prelude
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Core
import GHC.Core.Opt.Arity( typeOneShot )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Make
import GHC.Core.FVs ( mkRuleInfo )
import GHC.Core.Utils ( exprType, mkCast, coreAltsType )
import GHC.Core.Unfold.Make
import GHC.Core.SimpleOpt
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Types.Literal
import GHC.Types.SourceText
import GHC.Types.RepType ( countFunRepArgs, typePrimRep )
import GHC.Types.Name.Set
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.ForeignCall
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.Supply
import GHC.Types.Basic hiding ( SuccessFlag(..) )
import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName)
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.List.SetOps
import Data.List ( zipWith4 )
import GHC.StgToCmm.Types (LambdaFormInfo(..))
import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))
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, Id
noinlineConstraintId, Id
nospecId]
ghcPrimIds :: [Id]
ghcPrimIds :: [Id]
ghcPrimIds
= [ Id
realWorldPrimId
, Id
voidPrimId
, Id
nullAddrId
, Id
seqId
, 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 -> Bool -> IdDetails
ClassOpId Class
clas Bool
terminating) 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 :: [InvisTVBinder]
tyvars = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
data_con
n_ty_args :: Int
n_ty_args = [InvisTVBinder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvisTVBinder]
tyvars
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled 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
pred_ty :: Type
pred_ty = Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys ([InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tyvars))
res_ty :: Type
res_ty = Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> Int -> Scaled Type
forall a. Outputable a => [a] -> Int -> a
getNth [Scaled Type]
arg_tys Int
val_index)
sel_ty :: Type
sel_ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
tyvars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkFunctionType Type
ManyTy Type
pred_ty Type
res_ty
terminating :: Bool
terminating = HasDebugCallStack => Type -> Bool
Type -> Bool
isTerminatingType Type
res_ty Bool -> Bool -> Bool
|| Type -> Bool
definitelyUnliftedType Type
res_ty
base_info :: IdInfo
base_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
topCprSig
info :: IdInfo
info | Bool
new_tycon
= IdInfo
base_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
defaultSimpleOpts
UnfoldingSource
StableSystemSrc 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]
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
defaultSimpleOpts
UnfoldingSource
StableSystemSrc Int
1
(Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index)
rule :: CoreRule
rule = 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 :: DmdSig
strict_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand
arg_dmd] Divergence
topDiv
arg_dmd :: Demand
arg_dmd | Bool
new_tycon = Demand
evalDmd
| Bool
otherwise = Card
C_1N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed [Demand]
dict_field_dmds
where
dict_field_dmds :: [Demand]
dict_field_dmds = [ 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 :: [Scaled Type]
arg_tys = DataCon -> [Scaled 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 ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
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 RuleOpts
_ 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) <- HasDebugCallStack =>
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
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
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
ex_tcvs :: [Id]
ex_tcvs = DataCon -> [Id]
dataConExTyCoVars DataCon
data_con
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConRepArgTys DataCon
data_con
str_marks :: [StrictnessMark]
str_marks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
data_con
alg_wkr_info :: IdInfo
alg_wkr_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
wkr_arity
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
wkr_inline_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
wkr_sig
IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo` LambdaFormInfo
wkr_lf_info
wkr_inline_prag :: InlinePragma
wkr_inline_prag = InlinePragma
defaultInlinePragma { inl_rule = ConLike }
wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
data_con
wkr_sig :: DmdSig
wkr_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
wkr_dmds Divergence
topDiv
wkr_dmds :: [Demand]
wkr_dmds = (StrictnessMark -> Demand) -> [StrictnessMark] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map StrictnessMark -> Demand
mk_dmd [StrictnessMark]
str_marks
mk_dmd :: StrictnessMark -> Demand
mk_dmd StrictnessMark
MarkedStrict = Demand
evalDmd
mk_dmd StrictnessMark
NotMarkedStrict = Demand
topDmd
wkr_lf_info :: LambdaFormInfo
wkr_lf_info
| Int
wkr_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DataCon -> LambdaFormInfo
LFCon DataCon
data_con
| Bool
otherwise = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel (Int -> Type -> Int
countFunRepArgs Int
wkr_arity Type
wkr_ty) Bool
True ArgDescr
ArgUnknown
nt_work_info :: IdInfo
nt_work_info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
dataConWrapperInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
newtype_unf
IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo` (String -> LambdaFormInfo
forall a. HasCallStack => String -> a
panic String
"mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids")
id_arg1 :: Id
id_arg1 = Int -> Scaled Type -> Id
mkScaledTemplateLocal Int
1 ([Scaled Type] -> Scaled Type
forall a. HasCallStack => [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 = Bool -> SDoc -> (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
ex_tcvs Bool -> Bool -> Bool
&& [Scaled Type] -> Bool
forall a. [a] -> Bool
isSingleton [Scaled Type]
arg_tys)
(DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
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)
type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
data Boxer = UnitBox | Boxer (Subst -> 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 -> ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
args, []))
data DataConBangOpts
= FixedBangOpts [HsImplBang]
| SrcBangOpts !BangOpts
data BangOpts = BangOpts
{ BangOpts -> Bool
bang_opt_strict_data :: !Bool
, BangOpts -> Bool
bang_opt_unbox_disable :: !Bool
, BangOpts -> Bool
bang_opt_unbox_strict :: !Bool
, BangOpts -> Bool
bang_opt_unbox_small :: !Bool
}
mkDataConRep :: DataConBangOpts
-> FamInstEnvs
-> Name
-> DataCon
-> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
mkDataConRep :: DataConBangOpts
-> FamInstEnvs
-> Name
-> DataCon
-> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
mkDataConRep DataConBangOpts
dc_bang_opts FamInstEnvs
fam_envs Name
wrap_name DataCon
data_con
| Bool -> Bool
not Bool
wrapper_reqd
= (DataConRep, [HsImplBang], [StrictnessMark])
-> UniqSM (DataConRep, [HsImplBang], [StrictnessMark])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataConRep
NoDataConRep, [HsImplBang]
arg_ibangs, [StrictnessMark]
rep_strs)
| Bool
otherwise
= do { wrap_args <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"conrep")) [Scaled Type]
wrap_arg_tys
; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers)
initial_wrap_app
; let 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
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
wrap_arity
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
wrap_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
wrap_unf
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
wrap_sig
IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo` LambdaFormInfo
wrap_lf_info
wrap_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
wrap_arg_dmds Divergence
topDiv
wrap_lf_info
| Int
wrap_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DataCon -> LambdaFormInfo
LFCon DataCon
data_con
| TyCon -> Bool
isNewTyCon TyCon
tycon = String -> LambdaFormInfo
forall a. HasCallStack => String -> a
panic String
"mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids"
| Bool
otherwise = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel (Int -> Type -> Int
countFunRepArgs Int
wrap_arity Type
wrap_ty) Bool
True ArgDescr
ArgUnknown
wrap_arg_dmds =
Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall a. [a] -> 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
str | HsImplBang -> Bool
isBanged HsImplBang
str = Demand
evalDmd
| Bool
otherwise = Demand
topDmd
wrap_prag = InlinePragma
dataConWrapperInlinePragma
InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` Activation
activateDuringFinal
wrap_unf | TyCon -> Bool
isNewTyCon TyCon
tycon = CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
wrap_rhs
| Bool
otherwise = CoreExpr -> Unfolding
mkDataConUnfolding CoreExpr
wrap_rhs
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
; return (DCR { dcr_wrap_id = wrap_id
, dcr_boxer = mk_boxer boxers
, dcr_arg_tys = rep_tys }
, arg_ibangs, rep_strs) }
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
stupid_theta :: [Type]
stupid_theta = DataCon -> [Type]
dataConStupidTheta DataCon
data_con
wrap_tvs :: [Id]
wrap_tvs = DataCon -> [Id]
dataConUserTyVars DataCon
data_con
res_ty_args :: [Type]
res_ty_args = DataCon -> [Type]
dataConResRepTyArgs DataCon
data_con
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 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta
all_arg_tys :: [Scaled Type]
all_arg_tys = (Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted [Type]
ev_tys [Scaled Type] -> [Scaled Type] -> [Scaled Type]
forall a. [a] -> [a] -> [a]
++ [Scaled 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 :: [Scaled Type]
wrap_arg_tys = ((Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted ([Type] -> [Scaled Type]) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ [Type]
stupid_theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta) [Scaled Type] -> [Scaled Type] -> [Scaled Type]
forall a. [a] -> [a] -> [a]
++ [Scaled 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
+ [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
wrap_arg_tys
new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
arg_ibangs :: [HsImplBang]
arg_ibangs
| Bool
new_tycon
= (Scaled Type -> HsImplBang) -> [Scaled Type] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Scaled Type -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Scaled Type]
orig_arg_tys
| Bool
otherwise
= case DataConBangOpts
dc_bang_opts of
SrcBangOpts BangOpts
bang_opts -> (Scaled Type -> HsSrcBang -> HsImplBang)
-> [Scaled Type] -> [HsSrcBang] -> [HsImplBang]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs)
[Scaled Type]
orig_arg_tys [HsSrcBang]
orig_bangs
FixedBangOpts [HsImplBang]
bangs -> [HsImplBang]
bangs
([[(Scaled Type, StrictnessMark)]]
rep_tys_w_strs, [(Unboxer, Boxer)]
wrappers)
= [([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))]
-> ([[(Scaled Type, StrictnessMark)]], [(Unboxer, Boxer)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Scaled Type
-> HsImplBang
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
-> [Scaled Type]
-> [HsImplBang]
-> [([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))]
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 [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
([Scaled Type]
rep_tys, [StrictnessMark]
rep_strs) = [(Scaled Type, StrictnessMark)]
-> ([Scaled Type], [StrictnessMark])
forall a b. [(a, b)] -> ([a], [b])
unzip ([[(Scaled Type, StrictnessMark)]]
-> [(Scaled Type, StrictnessMark)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Scaled Type, StrictnessMark)]]
rep_tys_w_strs)
wrapper_reqd :: Bool
wrapper_reqd
| TyCon -> Bool
isTypeDataTyCon TyCon
tycon
= Bool
False
| Bool
otherwise
= (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
isUnpacked ([HsImplBang]
ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs)))
Bool -> Bool -> Bool
|| TyCon -> Bool
isFamInstTyCon TyCon
tycon
Bool -> Bool -> Bool
|| DataCon -> Bool
dataConUserTyVarsNeedWrapper DataCon
data_con
Bool -> Bool -> Bool
|| Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
stupid_theta)
initial_wrap_app :: CoreExpr
initial_wrap_app = Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
data_con)
CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
res_ty_args
CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ex_tvs
CoreExpr -> [Coercion] -> CoreExpr
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 :: Subst
subst1 = [Id] -> [Type] -> Subst
HasDebugCallStack => [Id] -> [Type] -> Subst
zipTvSubst [Id]
univ_tvs [Type]
ty_args
subst2 :: Subst
subst2 = (Subst -> Id -> Id -> Subst) -> Subst -> [Id] -> [Id] -> Subst
forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
foldl2 Subst -> Id -> Id -> Subst
extendTvSubstWithClone Subst
subst1 [Id]
ex_tvs [Id]
ex_vars
; (rep_ids, binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
subst2 [Boxer]
boxers [Id]
term_vars
; return (ex_vars ++ rep_ids, binds) } )
go :: Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
_ [] [Id]
src_vars = Bool
-> SDoc -> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
src_vars) (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
data_con) (UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind]))
-> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a b. (a -> b) -> a -> b
$ ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
go Subst
subst (Boxer
UnitBox : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
= do { (rep_ids2, binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
subst [Boxer]
boxers [Id]
src_vars
; return (src_var : rep_ids2, binds) }
go Subst
subst (Boxer Subst -> UniqSM ([Id], CoreExpr)
boxer : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
= do { (rep_ids1, arg) <- Subst -> UniqSM ([Id], CoreExpr)
boxer Subst
subst
; (rep_ids2, binds) <- go subst boxers src_vars
; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
go Subst
_ (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 a. a -> UniqSM a
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 { (rep_ids, unbox_fn) <- Unboxer
unboxer Id
wrap_arg
; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
; return (unbox_fn expr) }
dataConWrapperInlinePragma :: InlinePragma
dataConWrapperInlinePragma :: InlinePragma
dataConWrapperInlinePragma = InlinePragma
alwaysInlineConLikePragma
newLocal :: FastString
-> Scaled Type
-> UniqSM Var
newLocal :: RuleName -> Scaled Type -> UniqSM Id
newLocal RuleName
name_stem (Scaled Type
w Type
ty) =
RuleName -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
RuleName -> Type -> Type -> m Id
mkSysLocalOrCoVarM RuleName
name_stem Type
w Type
ty
dataConSrcToImplBang
:: BangOpts
-> FamInstEnvs
-> Scaled Type
-> HsSrcBang
-> HsImplBang
dataConSrcToImplBang :: BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
(HsSrcBang SourceText
ann (HsBang SrcUnpackedness
unpk SrcStrictness
NoSrcStrict))
| BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts
= BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
(SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
mkHsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
SrcStrict)
| Bool
otherwise
= HsImplBang
HsLazy
dataConSrcToImplBang BangOpts
_ FamInstEnvs
_ Scaled Type
_ (HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcLazy))
= HsImplBang
HsLazy
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
(HsSrcBang SourceText
_ (HsBang SrcUnpackedness
unpk_prag SrcStrictness
SrcStrict))
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
= HsImplBang
HsLazy
| let mb_co :: Maybe Reduction
mb_co = FamInstEnvs -> Type -> Maybe Reduction
topNormaliseType_maybe FamInstEnvs
fam_envs (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
arg_ty' :: Scaled Type
arg_ty' = case Maybe Reduction
mb_co of
{ Just Reduction
redn -> Scaled Type -> Type -> Scaled Type
forall a b. Scaled a -> b -> Scaled b
scaledSet Scaled Type
arg_ty (Reduction -> Type
reductionReducedType Reduction
redn)
; Maybe Reduction
Nothing -> Scaled Type
arg_ty }
, BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
shouldUnpackArgTy BangOpts
bang_opts SrcUnpackedness
unpk_prag FamInstEnvs
fam_envs Scaled Type
arg_ty'
= if BangOpts -> Bool
bang_opt_unbox_disable BangOpts
bang_opts
then Bool -> HsImplBang
HsStrict Bool
True
else case Maybe Reduction
mb_co of
Maybe Reduction
Nothing -> Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing
Just Reduction
redn -> Maybe Coercion -> HsImplBang
HsUnpack (Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Reduction -> Coercion
reductionCoercion Reduction
redn)
| Bool
otherwise
= Bool -> HsImplBang
HsStrict Bool
False
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 (HsStrict Bool
_)
= ([(Scaled Type
arg_ty, StrictnessMark
MarkedStrict)], (Unboxer
unitUnboxer, Boxer
unitBoxer))
dataConArgRep Scaled Type
arg_ty (HsUnpack Maybe Coercion
Nothing)
= Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled Type
arg_ty
dataConArgRep (Scaled Type
w Type
_) (HsUnpack (Just Coercion
co))
| let co_rep_ty :: Type
co_rep_ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind Coercion
co
, ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack (Type -> Type -> Scaled Type
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 { rep_id <- RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"cowrap_unbx") (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled (HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
arg_id) Type
rep_ty)
; (rep_ids, rep_fn) <- unbox_rep rep_id
; let 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)
; return (rep_ids, Let co_bind . rep_fn) }
boxer :: Boxer
boxer = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst ->
do { (rep_ids, rep_expr)
<- case Boxer
box_rep of
Boxer
UnitBox -> do { rep_id <- RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"cowrap_bx") (Type -> Scaled Type
forall a. a -> Scaled a
linear (Type -> Scaled Type) -> Type -> Scaled Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst Type
rep_ty)
; return ([rep_id], Var rep_id) }
Boxer Subst -> UniqSM ([Id], CoreExpr)
boxer -> Subst -> UniqSM ([Id], CoreExpr)
boxer Subst
subst
; let sco = Subst -> Coercion -> Coercion
substCoUnchecked Subst
subst Coercion
co
; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
unitUnboxer :: Unboxer
unitUnboxer :: Unboxer
unitUnboxer Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
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 scaledTy :: Scaled Type
scaledTy@(Scaled Type
_ Type
arg_ty)
| Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg_ty
= Bool
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tc)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a b. (a -> b) -> a -> b
$
case TyCon -> [DataCon]
tyConDataCons TyCon
tc of
[DataCon
con] -> Scaled Type
-> [Type]
-> DataCon
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackProduct Scaled Type
scaledTy [Type]
tc_args DataCon
con
[DataCon]
cons -> Scaled Type
-> [Type]
-> [DataCon]
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackSum Scaled Type
scaledTy [Type]
tc_args [DataCon]
cons
| Bool
otherwise
= String
-> SDoc -> ([(Scaled 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)
dataConArgUnpackProduct
:: Scaled Type
-> [Type]
-> DataCon
-> ( [(Scaled Type, StrictnessMark)]
, (Unboxer, Boxer) )
dataConArgUnpackProduct :: Scaled Type
-> [Type]
-> DataCon
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackProduct (Scaled Type
arg_mult Type
_) [Type]
tc_args DataCon
con =
Bool
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a b. (a -> b) -> a -> b
$
let rep_tys :: [Scaled Type]
rep_tys = (Scaled Type -> Scaled Type) -> [Scaled Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Scaled Type -> Scaled Type
forall a. Type -> Scaled a -> Scaled a
scaleScaled Type
arg_mult) ([Scaled Type] -> [Scaled Type]) -> [Scaled Type] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
con [Type]
tc_args
in ( [Scaled Type]
rep_tys [Scaled Type]
-> [StrictnessMark] -> [(Scaled Type, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
, ( \ Id
arg_id ->
do { rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"unbx")) [Scaled Type]
rep_tys
; let r_mult = HasDebugCallStack => Id -> Type
Id -> Type
idMult Id
arg_id
; let rep_ids' = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Id -> Id
scaleIdBy Type
r_mult) [Id]
rep_ids
; let 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
; return (rep_ids, unbox_fn) }
, (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst ->
do { rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"bx") (Scaled Type -> UniqSM Id)
-> (Scaled Type -> Scaled Type) -> Scaled Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Subst -> Scaled Type -> Scaled Type
Subst -> Scaled Type -> Scaled Type
TcType.substScaledTyUnchecked Subst
subst) [Scaled Type]
rep_tys
; return (rep_ids, Var (dataConWorkId con)
`mkTyApps` (substTysUnchecked subst tc_args)
`mkVarApps` rep_ids ) } ) )
dataConArgUnpackSum
:: Scaled Type
-> [Type]
-> [DataCon]
-> ( [(Scaled Type, StrictnessMark)]
, (Unboxer, Boxer) )
dataConArgUnpackSum :: Scaled Type
-> [Type]
-> [DataCon]
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackSum (Scaled Type
arg_mult Type
arg_ty) [Type]
tc_args [DataCon]
cons =
( [ (Scaled Type
sum_ty, StrictnessMark
MarkedStrict) ]
, ( Unboxer
unboxer, Boxer
boxer ) )
where
!ubx_sum_arity :: Int
ubx_sum_arity = [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
cons
src_tys :: [[Type]]
src_tys = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (\DataCon
con -> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
con [Type]
tc_args) [DataCon]
cons
sum_alt_tys :: [Type]
sum_alt_tys = ([Type] -> Type) -> [[Type]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map [Type] -> Type
mkUbxSumAltTy [[Type]]
src_tys
sum_ty_unscaled :: Type
sum_ty_unscaled = [Type] -> Type
mkSumTy [Type]
sum_alt_tys
sum_ty :: Scaled Type
sum_ty = Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
arg_mult Type
sum_ty_unscaled
newLocal' :: RuleName -> Type -> UniqSM Id
newLocal' RuleName
fs = RuleName -> Scaled Type -> UniqSM Id
newLocal RuleName
fs (Scaled Type -> UniqSM Id)
-> (Type -> Scaled Type) -> Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
arg_mult
unboxer :: Unboxer
unboxer :: Unboxer
unboxer Id
arg_id = do
con_arg_binders <- ([Type] -> UniqSM [Id]) -> [[Type]] -> UniqSM [[Id]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"unbx"))) [[Type]]
src_tys
ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty
let
mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt
mk_ubx_sum_alt Int
alt DataCon
con [Id
bndr] = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id
bndr]
(Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
ubx_sum_arity Int
alt [Type]
sum_alt_tys (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bndr))
mk_ubx_sum_alt Int
alt DataCon
con [Id]
bndrs =
let tuple :: CoreExpr
tuple = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
bndrs)
in AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id]
bndrs (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
ubx_sum_arity Int
alt [Type]
sum_alt_tys CoreExpr
tuple )
ubx_sum :: CoreExpr
ubx_sum =
let alts :: [CoreAlt]
alts = (Int -> DataCon -> [Id] -> CoreAlt)
-> [Int] -> [DataCon] -> [[Id]] -> [CoreAlt]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> DataCon -> [Id] -> CoreAlt
mk_ubx_sum_alt [ Int
1 .. ] [DataCon]
cons [[Id]]
con_arg_binders
in CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id ([CoreAlt] -> Type
coreAltsType [CoreAlt]
alts) [CoreAlt]
alts
unbox_fn :: CoreExpr -> CoreExpr
unbox_fn CoreExpr
body =
CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
ubx_sum Id
ubx_sum_bndr AltCon
DEFAULT [] CoreExpr
body
return ([ubx_sum_bndr], unbox_fn)
boxer :: Boxer
boxer :: Boxer
boxer = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst -> do
unboxed_field_id <- RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"bx") (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst Type
sum_ty_unscaled)
tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys
let tc_args' = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
tc_args
arg_ty' = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
arg_ty
con_arg_binders <-
mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys
let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt
mk_sum_alt Int
alt DataCon
con Id
_ [Id
datacon_bndr] =
( AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Int -> Int -> DataCon
sumDataCon Int
alt Int
ubx_sum_arity)) [Id
datacon_bndr]
(Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
tc_args'
CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id
datacon_bndr] ))
mk_sum_alt Int
alt DataCon
con Id
tuple_bndr [Id]
datacon_bndrs =
( AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Int -> Int -> DataCon
sumDataCon Int
alt Int
ubx_sum_arity)) [Id
tuple_bndr] (
CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tuple_bndr) Id
tuple_bndr Type
arg_ty'
[ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
datacon_bndrs))) [Id]
datacon_bndrs
(Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
tc_args'
CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
datacon_bndrs ) ] ))
return ( [unboxed_field_id],
Case (Var unboxed_field_id) unboxed_field_id arg_ty'
(zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) )
mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy [Type
ty] = Type
ty
mkUbxSumAltTy [Type]
tys = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys
shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
shouldUnpackArgTy BangOpts
bang_opts SrcUnpackedness
prag FamInstEnvs
fam_envs Scaled Type
arg_ty
| Just [DataCon]
data_cons <- Type -> Maybe [DataCon]
unpackable_type_datacons (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
, (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
ok_con [DataCon]
data_cons
, SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
should_unpack SrcUnpackedness
prag Scaled Type
arg_ty [DataCon]
data_cons
= Bool
True
| Bool
otherwise
= Bool
False
where
ok_con :: DataCon -> Bool
ok_con :: DataCon -> Bool
ok_con DataCon
top_con
= NameSet -> DataCon -> Bool
ok_args NameSet
emptyNameSet DataCon
top_con
where
top_con_name :: Name
top_con_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
top_con
ok_args :: NameSet -> DataCon -> Bool
ok_args NameSet
dcs DataCon
con
= ((Scaled Type, HsSrcBang) -> Bool)
-> [(Scaled Type, HsSrcBang)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs) ([(Scaled Type, HsSrcBang)] -> Bool)
-> [(Scaled Type, HsSrcBang)] -> Bool
forall a b. (a -> b) -> a -> b
$
(DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con [Scaled Type] -> [HsSrcBang] -> [(Scaled Type, HsSrcBang)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con)
ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs (Scaled Type
_ Type
ty, HsSrcBang SourceText
_ (HsBang SrcUnpackedness
unpack_prag SrcStrictness
str_prag))
| SrcStrictness -> Bool
strict_field SrcStrictness
str_prag
, Just [DataCon]
data_cons <- Type -> Maybe [DataCon]
unpackable_type_datacons (FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_envs Type
ty)
, SrcUnpackedness -> [DataCon] -> Bool
should_unpack_conservative SrcUnpackedness
unpack_prag [DataCon]
data_cons
= (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> DataCon -> Bool
ok_rec_con NameSet
dcs) [DataCon]
data_cons
| Bool
otherwise
= Bool
True
ok_rec_con :: NameSet -> DataCon -> Bool
ok_rec_con NameSet
dcs DataCon
con
| Name
dc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
top_con_name = Bool
False
| Name
dc_name Name -> NameSet -> Bool
`elemNameSet` NameSet
dcs = Bool
True
| Bool
otherwise = NameSet -> DataCon -> Bool
ok_args (NameSet
dcs NameSet -> Name -> NameSet
`extendNameSet` Name
dc_name) DataCon
con
where
dc_name :: Name
dc_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
con
strict_field :: SrcStrictness -> Bool
strict_field :: SrcStrictness -> Bool
strict_field SrcStrictness
NoSrcStrict = BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts
strict_field SrcStrictness
SrcStrict = Bool
True
strict_field SrcStrictness
SrcLazy = Bool
False
should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
should_unpack_conservative SrcUnpackedness
SrcNoUnpack [DataCon]
_ = Bool
False
should_unpack_conservative SrcUnpackedness
SrcUnpack [DataCon]
_ = Bool
True
should_unpack_conservative SrcUnpackedness
NoSrcUnpack [DataCon]
dcs = Bool -> Bool
not ([DataCon] -> Bool
is_sum [DataCon]
dcs)
should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
should_unpack SrcUnpackedness
prag Scaled Type
arg_ty [DataCon]
data_cons =
case SrcUnpackedness
prag of
SrcUnpackedness
SrcNoUnpack -> Bool
False
SrcUnpackedness
SrcUnpack -> Bool
True
SrcUnpackedness
NoSrcUnpack
| [DataCon] -> Bool
is_sum [DataCon]
data_cons
-> Bool
False
| Bool
otherwise
-> BangOpts -> Bool
bang_opt_unbox_strict BangOpts
bang_opts
Bool -> Bool -> Bool
|| (BangOpts -> Bool
bang_opt_unbox_small BangOpts
bang_opts
Bool -> Bool -> Bool
&& Bool
is_small_rep)
where
([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
_) = Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled Type
arg_ty
is_small_rep :: Bool
is_small_rep =
let
prim_reps :: [PrimRep]
prim_reps = ((Scaled Type, StrictnessMark) -> [PrimRep])
-> [(Scaled Type, StrictnessMark)] -> [PrimRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep])
-> ((Scaled Type, StrictnessMark) -> Type)
-> (Scaled Type, StrictnessMark)
-> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (Scaled Type -> Type)
-> ((Scaled Type, StrictnessMark) -> Scaled Type)
-> (Scaled Type, StrictnessMark)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scaled Type, StrictnessMark) -> Scaled Type
forall a b. (a, b) -> a
fst) ([(Scaled Type, StrictnessMark)] -> [PrimRep])
-> [(Scaled Type, StrictnessMark)] -> [PrimRep]
forall a b. (a -> b) -> a -> b
$ [(Scaled Type, StrictnessMark)]
rep_tys
rep_size :: Int
rep_size = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (PrimRep -> Int) -> [PrimRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Int
primRepSizeW64_B [PrimRep]
prim_reps
in Int
rep_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8
is_sum :: [DataCon] -> Bool
is_sum :: [DataCon] -> Bool
is_sum (DataCon
_:DataCon
_:[DataCon]
_) = Bool
True
is_sum [DataCon]
_ = Bool
False
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons Type
ty
| Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tc)
, Just [DataCon]
cons <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
, Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
cons)
, (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Id] -> Bool) -> (DataCon -> [Id]) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [Id]
dataConExTyCoVars) [DataCon]
cons
= [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
Just [DataCon]
cons
| 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
= Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (TyCon -> Bool
isNewTyCon TyCon
tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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
= Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (TyCon -> Bool
isNewTyCon TyCon
tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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
= HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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
mkFCallId :: Unique -> ForeignCall -> Type -> Id
mkFCallId :: Unique -> ForeignCall -> Type -> Id
mkFCallId Unique
uniq ForeignCall
fcall Type
ty
= Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
noFreeVarsOfType Type
ty) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (ForeignCall -> IdDetails
FCallId ForeignCall
fcall) Name
name Type
ty IdInfo
info
where
occ_str :: String
occ_str = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (ForeignCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignCall
fcall SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
name :: Name
name = Unique -> RuleName -> Name
mkFCallName Unique
uniq (String -> RuleName
mkFastString String
occ_str)
info :: IdInfo
info = IdInfo
noCafIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
topCprSig
([PiTyVarBinder]
bndrs, Type
_) = Type -> ([PiTyVarBinder], Type)
tcSplitPiTys Type
ty
arity :: Int
arity = (PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count PiTyVarBinder -> Bool
isAnonPiTyBinder [PiTyVarBinder]
bndrs
strict_sig :: DmdSig
strict_sig = Int -> Divergence -> DmdSig
mkVanillaDmdSig Int
arity 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] -> Type -> Type
TcType.tcMkDFunSigmaTy [Id]
tvs [Type]
theta (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys)
nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
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
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, nospecIdName :: 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
nospecIdName :: Name
nospecIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"nospec") Unique
nospecIdKey Id
nospecId
proxyHashId :: Id
proxyHashId :: Id
proxyHashId
= Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
proxyName Type
ty
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding)
where
[Id
kv,Id
tv] = Type -> (Type -> [Type]) -> [Id]
mkTemplateKiTyVar Type
liftedTypeKind (\Type
x -> [Type
x])
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 (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
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)
seqId :: Id
seqId :: Id
seqId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
seqName Type
ty Name -> ConcreteTyVars
concs IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
inline_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
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
mkInfForAllTy 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
$ HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany 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 -> [CoreAlt] -> 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 -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)]
concs :: Name -> ConcreteTyVars
concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
[ ((Type
openBetaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
2 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep2TyVar)]
arity :: Int
arity = Int
2
lazyId :: Id
lazyId :: Id
lazyId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
lazyIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy Type
alphaTy)
noinlineIdName, noinlineConstraintIdName :: Name
noinlineIdName :: Name
noinlineIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"noinline")
Unique
noinlineIdKey Id
noinlineId
noinlineConstraintIdName :: Name
noinlineConstraintIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"noinlineConstraint")
Unique
noinlineConstraintIdKey Id
noinlineConstraintId
noinlineId :: Id
noinlineId :: Id
noinlineId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
noinlineIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy Type
alphaTy
noinlineConstraintId :: Id
noinlineConstraintId :: Id
noinlineConstraintId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
noinlineConstraintIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaConstraintTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => FunTyFlag -> Type -> Type -> Type -> Type
FunTyFlag -> Type -> Type -> Type -> Type
mkFunTy FunTyFlag
visArgConstraintLike Type
ManyTy Type
alphaTy Type
alphaConstraintTy
nospecId :: Id
nospecId :: Id
nospecId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
nospecIdName Type
ty IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy Type
alphaTy)
oneShotId :: Id
oneShotId :: Id
oneShotId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
oneShotName Type
ty Name -> ConcreteTyVars
concs IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [ Id
openAlphaTyVar, Id
openBetaTyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
fun_ty Type
fun_ty
fun_ty :: Type
fun_ty = HasDebugCallStack => Type -> Type -> Type
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 = [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'
arity :: Int
arity = Int
2
concs :: Name -> ConcreteTyVars
concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
[((Type
openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
2 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep1TyVar)]
leftSectionId :: Id
leftSectionId :: Id
leftSectionId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
leftSectionName Type
ty Name -> ConcreteTyVars
concs IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar, Id
multiplicityTyVar1] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar, Id
openBetaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
[Id
f,Id
x] = [Type] -> [Id]
mkTemplateLocals [HasDebugCallStack => Type -> Type -> Type -> Type
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 = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar, Id
multiplicityTyVar1
, Id
openAlphaTyVar, Id
openBetaTyVar ] CoreExpr
body
body :: CoreExpr
body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xmult)
arity :: Int
arity = Int
2
concs :: Name -> ConcreteTyVars
concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
[((Type
openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
2 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep1TyVar)]
rightSectionId :: Id
rightSectionId :: Id
rightSectionId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
rightSectionName Type
ty Name -> ConcreteTyVars
concs IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
ty :: Type
ty = [Id] -> Type -> Type
mkInfForAllTys [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar,Id
runtimeRep3TyVar
, Id
multiplicityTyVar1, Id
multiplicityTyVar2 ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar, Id
openBetaTyVar, Id
openGammaTyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => CoreExpr -> Type
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
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [ Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult1 Type
openAlphaTy
, Type -> Type -> Scaled Type
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 = [Id] -> CoreExpr -> CoreExpr
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 = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
ymult,Id
xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f) [Id
xmult,Id
ymult]
arity :: Int
arity = Int
3
concs :: Name -> ConcreteTyVars
concs =
[((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
[ ((Type
openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
3 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep1TyVar)
, ((Type
openBetaTy , Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
2 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep2TyVar)]
coerceId :: Id
coerceId :: Id
coerceId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
coerceName Type
ty Name -> ConcreteTyVars
concs IdInfo
info
where
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
2
eqRTy :: Type
eqRTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
coercibleTyCon [ Type
tYPE_r, Type
a, Type
b ]
eqRPrimTy :: Type
eqRPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [ Type
tYPE_r, Type
tYPE_r, Type
a, Type
b ]
ty :: Type
ty = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [ Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
rv Specificity
InferredSpec
, Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
av Specificity
SpecifiedSpec
, Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
bv Specificity
SpecifiedSpec ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkInvisFunTy Type
eqRTy (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Type -> Type -> Type
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
mkTYPEapp Type
r, Type -> Type
mkTYPEapp Type
r])
[Type
r, Type
a, Type
b] = [Id] -> [Type]
mkTyVarTys [Id]
bndrs
tYPE_r :: Type
tYPE_r = Type -> Type
mkTYPEapp Type
r
[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 -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqR) (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
eqRTy) Type
b ([CoreAlt] -> CoreExpr) -> [CoreAlt] -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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))]
concs :: Name -> ConcreteTyVars
concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
[((Id -> Type
mkTyVarTy Id
av, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
1 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
rv)]
realWorldPrimId :: Id
realWorldPrimId :: Id
realWorldPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
realWorldName Type
id_ty
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding
IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` Type -> OneShotInfo
typeOneShot Type
id_ty)
where
id_ty :: Type
id_ty = Type
realWorldStatePrimTy
voidPrimId :: Id
voidPrimId :: Id
voidPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
voidPrimIdName Type
unboxedUnitTy
(IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
unboxedUnitExpr)
unboxedUnitExpr :: CoreExpr
unboxedUnitExpr :: CoreExpr
unboxedUnitExpr = Id -> CoreExpr
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
ManyTy 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
= HasDebugCallStack => Name -> Type -> IdInfo -> Id
Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
ty IdInfo
info
pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
pcRepPolyId Name
name Type
ty Name -> ConcreteTyVars
conc_tvs IdInfo
info =
IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (ConcreteTyVars -> IdDetails
RepPolyId (ConcreteTyVars -> IdDetails) -> ConcreteTyVars -> IdDetails
forall a b. (a -> b) -> a -> b
$ Name -> ConcreteTyVars
conc_tvs Name
name) Name
name Type
ty IdInfo
info
mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)]
-> Name
-> ConcreteTyVars
mkRepPolyIdConcreteTyVars :: [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars [((Type, Position 'Neg), Id)]
vars Name
nm =
[(Name, ConcreteTvOrigin)] -> ConcreteTyVars
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Id -> Name
tyVarName Id
tv, Type -> Position 'Neg -> ConcreteTvOrigin
mk_conc_frr Type
ty Position 'Neg
pos)
| ((Type
ty,Position 'Neg
pos), Id
tv) <- [((Type, Position 'Neg), Id)]
vars ]
where
mk_conc_frr :: Type -> Position 'Neg -> ConcreteTvOrigin
mk_conc_frr Type
ty Position 'Neg
pos =
FixedRuntimeRepOrigin -> ConcreteTvOrigin
ConcreteFRR (FixedRuntimeRepOrigin -> ConcreteTvOrigin)
-> FixedRuntimeRepOrigin -> ConcreteTvOrigin
forall a b. (a -> b) -> a -> b
$ Type -> FixedRuntimeRepContext -> FixedRuntimeRepOrigin
FixedRuntimeRepOrigin Type
ty
(FixedRuntimeRepContext -> FixedRuntimeRepOrigin)
-> FixedRuntimeRepContext -> FixedRuntimeRepOrigin
forall a b. (a -> b) -> a -> b
$ Name -> RepPolyId -> Position 'Neg -> FixedRuntimeRepContext
FRRRepPolyId Name
nm RepPolyId
RepPolyFunction Position 'Neg
pos