{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.JavaScript
( dsJsImport
, dsJsFExport
, dsJsFExportDynamic
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Hs
import GHC.HsToCore.Monad
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Foreign.Prim
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Utils
import GHC.Core
import GHC.Core.Make
import GHC.Core.Utils
import GHC.Core.DataCon
import GHC.Core.Unfold.Make
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Multiplicity
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Literal
import GHC.Types.ForeignStubs
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Unit.Module
import GHC.Tc.Utils.TcType
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.JS.Ppr
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
dsJsFExport
:: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM ( CHeader
, CStub
, String
, Int
)
dsJsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsJsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
let
ty :: Type
ty = forall a. Pair a -> a
pSnd forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
([Id]
_tvs,Type
sans_foralls) = Type -> ([Id], Type)
tcSplitForAllTyVars Type
ty
([Scaled Type]
fe_arg_tys', Type
orig_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
fe_arg_tys :: [Scaled Type]
fe_arg_tys | Bool
isDyn = forall a. [a] -> [a]
tail [Scaled Type]
fe_arg_tys'
| Bool
otherwise = [Scaled Type]
fe_arg_tys'
(Type
res_ty, Bool
is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
orig_res_ty of
Just (TyCon
_ioTyCon, Type
res_ty) -> (Type
res_ty, Bool
True)
Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Platform
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportJSBits Platform
platform CLabelString
ext_name
(if Bool
isDyn then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Id
fn_id)
(forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
fe_arg_tys) Type
res_ty Bool
is_IO_res_ty CCallConv
cconv
mkFExportJSBits
:: Platform
-> FastString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader,
CStub,
String,
Int
)
mkFExportJSBits :: Platform
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportJSBits Platform
platform CLabelString
c_nm Maybe Id
maybe_target [Type]
arg_htys Type
res_hty Bool
is_IO_res_ty CCallConv
_cconv
= (CHeader
header_bits, CStub
js_bits, String
type_string,
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Width -> Arity
widthInBytes (CmmType -> Width
typeWidth CmmType
rep) | (SDoc
_,SDoc
_,Type
_,CmmType
rep) <- [(SDoc, SDoc, Type, CmmType)]
arg_info]
)
where
arg_info :: [(SDoc,
SDoc,
Type,
CmmType)]
arg_info :: [(SDoc, SDoc, Type, CmmType)]
arg_info = [ let stg_type :: SDoc
stg_type = Type -> SDoc
showStgType Type
ty in
(forall {doc} {a} {p}. (IsLine doc, Show a) => a -> p -> doc
arg_cname Arity
n SDoc
stg_type,
SDoc
stg_type,
Type
ty,
Platform -> Type -> CmmType
typeCmmType Platform
platform (Type -> Type
getPrimTyOf Type
ty))
| (Type
ty,Arity
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_htys [Arity
1::Int ..] ]
arg_cname :: a -> p -> doc
arg_cname a
n p
_stg_ty = forall doc. IsLine doc => String -> doc
text (Char
'a'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show a
n)
type_string :: String
type_string = Platform -> Type -> Char
primTyDescChar Platform
platform Type
res_hty forall a. a -> [a] -> [a]
: String
arg_type_string
arg_type_string :: String
arg_type_string = [Platform -> Type -> Char
primTyDescChar Platform
platform Type
ty | (SDoc
_,SDoc
_,Type
ty,CmmType
_) <- [(SDoc, SDoc, Type, CmmType)]
arg_info]
res_hty_is_unit :: Bool
res_hty_is_unit = Type
res_hty Type -> Type -> Bool
`eqType` Type
unitTy
unboxResType :: SDoc
unboxResType | Bool
res_hty_is_unit = forall doc. IsLine doc => String -> doc
text String
"h$rts_getUnit"
| Bool
otherwise = Type -> SDoc
unpackHObj Type
res_hty
header_bits :: CHeader
header_bits = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall {a}. Uniquable a => a -> CHeader
idTag Maybe Id
maybe_target
idTag :: a -> CHeader
idTag a
i = let (Char
tag, Arity
u) = Unique -> (Char, Arity)
unpkUnique (forall a. Uniquable a => a -> Unique
getUnique a
i)
in SDoc -> CHeader
CHeader (forall doc. IsLine doc => Char -> doc
char Char
tag forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Arity -> doc
int Arity
u)
fun_args :: SDoc
fun_args
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
arg_info = forall doc. IsOutput doc => doc
empty
| Bool
otherwise = forall doc. IsLine doc => [doc] -> doc
hsep forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate forall doc. IsLine doc => doc
comma
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
_ty,Type
_,CmmType
_) -> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
arg_info
fun_proto :: SDoc
fun_proto
= forall doc. IsLine doc => String -> doc
text String
"async" forall doc. IsLine doc => doc -> doc -> doc
<+>
forall doc. IsLine doc => String -> doc
text String
"function" forall doc. IsLine doc => doc -> doc -> doc
<+>
(if forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target
then forall doc. IsLine doc => String -> doc
text String
"h$" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm
else forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm) forall doc. IsLine doc => doc -> doc -> doc
<>
forall doc. IsLine doc => doc -> doc
parens SDoc
fun_args
fun_export :: SDoc
fun_export
= case Maybe Id
maybe_target of
Just Id
hs_fn | Just Module
m <- Name -> Maybe Module
nameModule_maybe (forall a. NamedThing a => a -> Name
getName Id
hs_fn) ->
forall doc. IsLine doc => String -> doc
text String
"h$foreignExport" forall doc. IsLine doc => doc -> doc -> doc
<>
forall doc. IsLine doc => doc -> doc
parens (
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
strlit (UnitId -> String
unitIdString (Module -> UnitId
moduleUnitId Module
m)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
strlit (ModuleName -> String
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
m)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
strlit (CLabelString -> String
unpackFS CLabelString
c_nm) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
strlit String
type_string
) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
Maybe Id
_ -> forall doc. IsOutput doc => doc
empty
strlit :: String -> SDoc
strlit String
xs = Doc -> SDoc
docToSDoc (CLabelString -> Doc
pprStringLit (String -> CLabelString
mkFastString String
xs))
the_cfun :: SDoc
the_cfun
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> forall doc. IsLine doc => String -> doc
text String
"h$deRefStablePtr(the_stableptr)"
Just Id
hs_fn -> Id -> SDoc
idClosureText Id
hs_fn
expr_to_run :: SDoc
expr_to_run :: SDoc
expr_to_run
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {b} {d}. SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
the_cfun [(SDoc, SDoc, Type, CmmType)]
arg_info
where
appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
acc (SDoc
arg_cname, b
_, Type
arg_hty, d
_)
= forall doc. IsLine doc => String -> doc
text String
"h$rts_apply"
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (SDoc
acc forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
mkHObj Type
arg_hty forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens SDoc
arg_cname)
js_bits :: CStub
js_bits = CStub { getCStub :: SDoc
getCStub = SDoc
js_sdoc
, getInitializers :: [CLabel]
getInitializers = forall a. Monoid a => a
mempty
, getFinalizers :: [CLabel]
getFinalizers = forall a. Monoid a => a
mempty
}
where js_sdoc :: SDoc
js_sdoc = forall doc. IsLine doc => doc
space
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_proto
forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => doc
lbrace
, forall doc. IsLine doc => String -> doc
text String
"return"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"await"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"h$rts_eval"
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens ((if Bool
is_IO_res_ty
then SDoc
expr_to_run
else forall doc. IsLine doc => String -> doc
text String
"h$rts_toIO" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens SDoc
expr_to_run)
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
unboxResType)
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
, forall doc. IsLine doc => doc
rbrace
]
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_export
idClosureText :: Id -> SDoc
idClosureText :: Id -> SDoc
idClosureText Id
i
| Id -> Bool
isExportedId Id
i
, Name
name <- forall a. NamedThing a => a -> Name
getName Id
i
, Just Module
m <- Name -> Maybe Module
nameModule_maybe Name
name
= let str :: String
str = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Module -> Name -> SDoc
pprFullName Module
m (Name -> Name
localiseName Name
name))
in forall doc. IsLine doc => String -> doc
text String
"h$" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (String -> String
zEncodeString String
str)
| Bool
otherwise
= forall a. HasCallStack => String -> a
panic String
"idClosureText: unknown module"
dsJsImport
:: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsImport :: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsImport Id
id Coercion
co (CLabel CLabelString
cid) CCallConv
cconv Safety
_ Maybe Header
_ = do
let ty :: Type
ty = forall a. Pair a -> a
pFst forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
fod :: FunctionOrData
fod = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
dropForAlls Type
ty) of
Just TyCon
tycon
| TyCon -> Unique
tyConUnique TyCon
tycon forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
FunctionOrData
IsFunction
Maybe TyCon
_ -> FunctionOrData
IsData
(Maybe Type
_resTy, CoreExpr -> CoreExpr
foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
ty
let rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
foRhs (forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
cid Maybe Arity
stdcall_info FunctionOrData
fod))
rhs' :: CoreExpr
rhs' = forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
stdcall_info :: Maybe Arity
stdcall_info = CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info CCallConv
cconv Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
id, CoreExpr
rhs')], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
dsJsImport Id
id Coercion
co (CFunction CCallTarget
target) cconv :: CCallConv
cconv@CCallConv
PrimCallConv Safety
safety Maybe Header
_
= Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
dsPrimCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety))
dsJsImport Id
id Coercion
co (CFunction CCallTarget
target) CCallConv
cconv Safety
safety Maybe Header
mHeader
= Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
mHeader
dsJsImport Id
id Coercion
co CImportSpec
CWrapper CCallConv
cconv Safety
_ Maybe Header
_
= Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic Id
id Coercion
co CCallConv
cconv
dsJsFExportDynamic :: Id
-> Coercion
-> CCallConv
-> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic Id
id Coercion
co0 CCallConv
cconv = do
let
ty :: Type
ty = forall a. Pair a -> a
pFst (Coercion -> Pair Type
coercionKind Coercion
co0)
([Id]
tvs,Type
sans_foralls) = Type -> ([Id], Type)
tcSplitForAllTyVars Type
ty
([Scaled Type
arg_mult Type
arg_ty], Type
fn_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
(TyCon
io_tc, Type
res_ty) = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"dsJsFExportDynamic: IO type expected"
forall a b. (a -> b) -> a -> b
$ Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let fe_nm :: CLabelString
fe_nm = String -> CLabelString
mkFastString forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
(String
"h$" forall a. [a] -> [a] -> [a]
++ Module -> String
moduleStableString Module
mod forall a. [a] -> [a] -> [a]
++ String
"$" forall a. [a] -> [a] -> [a]
++ Id -> String
toJsName Id
id)
Id
cback <- Type -> Type -> DsM Id
newSysLocalDs Type
arg_mult Type
arg_ty
Id
newStablePtrId <- Name -> DsM Id
dsLookupGlobalId Name
newStablePtrName
TyCon
stable_ptr_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
let
stable_ptr_ty :: Type
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
export_ty :: Type
export_ty = HasDebugCallStack => Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
Id
bindIOId <- Name -> DsM Id
dsLookupGlobalId Name
bindIOName
Id
stbl_value <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
stable_ptr_ty
(CHeader
h_code, CStub
c_code, String
typestring, Arity
args_size) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsJsFExport Id
id (Type -> Coercion
mkRepReflCo Type
export_ty) CLabelString
fe_nm CCallConv
cconv Bool
True
let
adj_args :: [CoreExpr]
adj_args = [ forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (forall a. Integral a => a -> Integer
toInteger (CCallConv -> Arity
ccallConvToInt CCallConv
cconv))
, forall b. Id -> Expr b
Var Id
stbl_value
, forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm Maybe Arity
mb_sz_args FunctionOrData
IsFunction)
, forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
]
adjustor :: CLabelString
adjustor = String -> CLabelString
fsLit String
"createAdjustor"
mb_sz_args :: Maybe Arity
mb_sz_args = case CCallConv
cconv of
CCallConv
StdCallConv -> forall a. a -> Maybe a
Just Arity
args_size
CCallConv
_ -> forall a. Maybe a
Nothing
CoreExpr
ccall_adj <- CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall CLabelString
adjustor [CoreExpr]
adj_args Safety
PlayRisky (TyCon -> [Type] -> Type
mkTyConApp TyCon
io_tc [Type
res_ty])
let io_app :: CoreExpr
io_app = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs forall a b. (a -> b) -> a -> b
$
forall b. b -> Expr b -> Expr b
Lam Id
cback forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
bindIOId)
[ forall b. Type -> Expr b
Type Type
stable_ptr_ty
, forall b. Type -> Expr b
Type Type
res_ty
, forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
newStablePtrId) [ forall b. Type -> Expr b
Type Type
arg_ty, forall b. Id -> Expr b
Var Id
cback ]
, forall b. b -> Expr b -> Expr b
Lam Id
stbl_value CoreExpr
ccall_adj
]
fed :: Binding
fed = (Id
id Id -> Activation -> Id
`setInlineActivation` Activation
NeverActive, forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding
fed], CHeader
h_code, CStub
c_code)
toJsName :: Id -> String
toJsName :: Id -> String
toJsName Id
i = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
pprCode (forall a. Outputable a => a -> SDoc
ppr (Id -> Name
idName Id
i)))
dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsJsCall :: Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsCall Id
fn_id Coercion
co (CCall (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
_mDeclHeader = do
let
ty :: Type
ty = forall a. Pair a -> a
pFst forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
([TyVarBinder]
tv_bndrs, Type
rho) = Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders Type
ty
([Scaled Type]
arg_tys, Type
io_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
rho
[Id]
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys
([CoreExpr]
val_args, [CoreExpr -> CoreExpr]
arg_wrappers) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
args)
let
work_arg_ids :: [Id]
work_arg_ids = [Id
v | Var Id
v <- [CoreExpr]
val_args]
(Type
ccall_result_ty, CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult Type
io_res_ty
Unique
ccall_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
Unique
work_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
SimpleOpts
simpl_opts <- DynFlags -> SimpleOpts
initSimpleOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
fcall :: ForeignCall
fcall = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)
worker_ty :: Type
worker_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTysMany (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
tvs :: [Id]
tvs = forall a b. (a -> b) -> [a] -> [b]
map forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
the_ccall_app :: CoreExpr
the_ccall_app = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
fcall [CoreExpr]
val_args Type
ccall_result_ty
work_rhs :: CoreExpr
work_rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_arg_ids CoreExpr
the_ccall_app)
work_id :: Id
work_id = CLabelString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
ManyTy Type
worker_ty
work_app :: CoreExpr
work_app = forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
wrapper_body :: CoreExpr
wrapper_body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
wrap_rhs :: CoreExpr
wrap_rhs = forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
wrap_rhs' :: CoreExpr
wrap_rhs' = forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
fn_id_w_inl :: Id
fn_id_w_inl = Id
fn_id
Id -> Unfolding -> Id
`setIdUnfolding`
SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
simpl_opts UnfoldingSource
VanillaSrc
(forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
args) CoreExpr
wrap_rhs'
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
work_id, CoreExpr
work_rhs), (Id
fn_id_w_inl, CoreExpr
wrap_rhs')], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = forall doc. IsLine doc => String -> doc
text String
"h$rts_mk" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)
unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = forall doc. IsLine doc => String -> doc
text String
"h$rts_get" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)
showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = forall doc. IsLine doc => String -> doc
text String
"Hs" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)
showFFIType :: Type -> String
showFFIType :: Type -> String
showFFIType Type
t = forall a. NamedThing a => a -> String
getOccString (forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
t))
typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
| Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
= TyCon
tc
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeTyCon" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
unboxJsArg :: CoreExpr
-> DsM (CoreExpr,
CoreExpr -> CoreExpr
)
unboxJsArg :: CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg CoreExpr
arg
| Type -> Bool
isPrimitiveType Type
arg_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg, \CoreExpr
body -> CoreExpr
body)
| Just (Coercion
co, Type
_rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
arg_ty
= CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
arg Coercion
co)
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
= forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
\ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (forall a. a -> Scaled a
unrestricted Type
boolTy) (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
= forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
\ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (forall a. a -> Scaled a
unrestricted Type
arg_ty) (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
| Bool
is_product_type Bool -> Bool -> Bool
&& Arity
data_con_arity forall a. Eq a => a -> a -> Bool
== Arity
1
= do Id
case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
Id
prim_arg <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy (forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty1)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
prim_arg,
\ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Id
prim_arg] CoreExpr
body]
)
| Bool
is_product_type Bool -> Bool -> Bool
&&
Arity
data_con_arity forall a. Eq a => a -> a -> Bool
== Arity
3 Bool -> Bool -> Bool
&&
forall a. Maybe a -> Bool
isJust Maybe TyCon
maybe_arg3_tycon Bool -> Bool -> Bool
&&
(TyCon
arg3_tycon forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
TyCon
arg3_tycon forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon)
= do Id
case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
vars :: [Id]
vars@[Id
_l_var, Id
_r_var, Id
arr_cts_var] <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
data_con_arg_tys
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
arr_cts_var,
\ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Id]
vars CoreExpr
body]
)
| Bool
otherwise
= do SrcSpan
l <- DsM SrcSpan
getSrcSpanDs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unboxJsArg: " (forall a. Outputable a => a -> SDoc
ppr SrcSpan
l forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
where
arg_ty :: Type
arg_ty = HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
arg
maybe_product_type :: Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type = Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
arg_ty
is_product_type :: Bool
is_product_type = forall a. Maybe a -> Bool
isJust Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type]
data_con_arg_tys) = Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
data_con_arity :: Arity
data_con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
(Scaled Type
data_con_arg_ty1 : [Scaled Type]
_) = [Scaled Type]
data_con_arg_tys
(Scaled Type
_ : Scaled Type
_ : Scaled Type
data_con_arg_ty3 : [Scaled Type]
_) = [Scaled Type]
data_con_arg_tys
maybe_arg3_tycon :: Maybe TyCon
maybe_arg3_tycon = Type -> Maybe TyCon
tyConAppTyCon_maybe (forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty3)
Just TyCon
arg3_tycon = Maybe TyCon
maybe_arg3_tycon
boxJsResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult Type
result_ty
| Type -> Bool
isRuntimeRepKindedTy Type
result_ty = forall a. HasCallStack => String -> a
panic String
"boxJsResult: runtime rep ty"
boxJsResult Type
result_ty
| Just (TyCon
io_tycon, Type
io_res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
result_ty
= do { (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
io_res_ty
; let return_result :: CoreExpr -> CoreExpr -> CoreExpr
return_result CoreExpr
state CoreExpr
ans
= [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
state, CoreExpr
ans]
; (Type
ccall_res_ty, CoreAlt
the_alt) <- (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
; Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
; let io_data_con :: DataCon
io_data_con = forall a. [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
io_tycon)
toIOCon :: Id
toIOCon = DataCon -> Id
dataConWrapId DataCon
io_data_con
wrap :: CoreExpr -> CoreExpr
wrap CoreExpr
the_call =
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
toIOCon)
[ forall b. Type -> Expr b
Type Type
io_res_ty,
forall b. b -> Expr b -> Expr b
Lam Id
state_id forall a b. (a -> b) -> a -> b
$
CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Id -> Expr b
Var Id
state_id))
(forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(CoreAlt -> Type
coreAltType CoreAlt
the_alt)
[CoreAlt
the_alt]
]
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy HasDebugCallStack => Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap) }
boxJsResult Type
result_ty
= do
(Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
(Type
ccall_res_ty, CoreAlt
the_alt) <- (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt forall {p} {p}. p -> p -> p
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
let
wrap :: CoreExpr -> CoreExpr
wrap = \ CoreExpr
the_call -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Id -> Expr b
Var Id
realWorldPrimId))
(forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(CoreAlt -> Type
coreAltType CoreAlt
the_alt)
[CoreAlt
the_alt]
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy HasDebugCallStack => Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
where
return_result :: p -> p -> p
return_result p
_ p
ans = p
ans
mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-> (Maybe Type, Expr Var -> Expr Var)
-> DsM (Type, CoreAlt)
mk_alt :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Maybe Type
Nothing, CoreExpr -> CoreExpr
wrap_result)
= do
Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
let
the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
panic String
"jsBoxResult")
ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
the_alt :: CoreAlt
the_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
1)) [Id
state_id] CoreExpr
the_rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Just Type
prim_res_ty, CoreExpr -> CoreExpr
wrap_result)
| Type -> Bool
isUnboxedTupleType Type
prim_res_ty = do
let
Just [Type]
ls = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> [Type]
dropRuntimeRepArgs (Type -> Maybe [Type]
tyConAppArgs_maybe Type
prim_res_ty)
arity :: Arity
arity = Arity
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
ls
[Id]
args_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy) [Type]
ls
Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
let
result_tup :: CoreExpr
result_tup = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
args_ids)
the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result CoreExpr
result_tup)
ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed (Type
realWorldStatePrimTy forall a. a -> [a] -> [a]
: [Type]
ls)
the_alt :: CoreAlt
the_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
arity))
(Id
state_id forall a. a -> [a] -> [a]
: [Id]
args_ids)
CoreExpr
the_rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)
| Bool
otherwise = do
Id
result_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
prim_res_ty
Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
let
the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result (forall b. Id -> Expr b
Var Id
result_id))
ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
the_alt :: CoreAlt
the_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
2)) [Id
state_id, Id
result_id] CoreExpr
the_rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)
fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info CCallConv
_other_conv Type
_ = forall a. Maybe a
Nothing
jsResultWrapper
:: Type
-> DsM ( Maybe Type
, CoreExpr -> CoreExpr
)
jsResultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
| Type -> Bool
isRuntimeRepKindedTy Type
result_ty = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. a -> a
id)
| Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc = do
let args' :: [Type]
args' = [Type] -> [Type]
dropRuntimeRepArgs [Type]
args
([Maybe Type]
tys, [CoreExpr -> CoreExpr]
wrappers) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper [Type]
args'
[Maybe Id]
matched <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy)) [Maybe Type]
tys
let tys' :: [Type]
tys' = forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
tys
err :: a
err = forall a. HasCallStack => String -> a
panic String
"jsResultWrapper: used Id with result type Nothing"
resWrap :: CoreExpr
resWrap :: CoreExpr
resWrap = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\CoreExpr -> CoreExpr
w -> CoreExpr -> CoreExpr
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Id -> Expr b
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err) [CoreExpr -> CoreExpr]
wrappers [Maybe Id]
matched)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys'
then (forall a. Maybe a
Nothing, \CoreExpr
_ -> CoreExpr
resWrap)
else let innerArity :: Arity
innerArity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys'
innerTy :: Type
innerTy = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys'
innerCon :: DataCon
innerCon = Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
innerArity
inner :: CoreExpr -> CoreExpr
inner :: CoreExpr -> CoreExpr
inner CoreExpr
e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
e (forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
innerCon)
(forall a. [Maybe a] -> [a]
catMaybes [Maybe Id]
matched)
CoreExpr
resWrap
]
in (forall a. a -> Maybe a
Just Type
innerTy, CoreExpr -> CoreExpr
inner)
| Type -> Bool
isPrimitiveType Type
result_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)
| Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
, TyCon -> Bool
isBoxedTupleTyCon TyCon
tc = do
let args' :: [Type]
args' = [Type] -> [Type]
dropRuntimeRepArgs [Type]
args
innerTy :: Type
innerTy = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
args'
(Maybe Type
inner_res, CoreExpr -> CoreExpr
w) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
innerTy
[Id]
matched <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy) [Type]
args'
let inner :: CoreExpr -> CoreExpr
inner CoreExpr
e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr
w CoreExpr
e) (forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
[ forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args')))
[Id]
matched
([CoreExpr] -> CoreExpr
mkCoreTup (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
matched))
]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
inner_res, CoreExpr -> CoreExpr
inner)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, \CoreExpr
_ -> forall b. Id -> Expr b
Var Id
unitDataConId)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey = do
Unique
ccall_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
let forceBool :: CoreExpr -> CoreExpr
forceBool CoreExpr
e = Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
ccall_uniq String
"((x) => { return !(!x); })" [CoreExpr
e] Type
boolTy
forall (m :: * -> *) a. Monad m => a -> m a
return
(forall a. a -> Maybe a
Just Type
intPrimTy, \CoreExpr
e -> CoreExpr -> CoreExpr
forceBool CoreExpr
e)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)
| Just (Coercion
co, Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
result_ty
= do (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rep_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
mkCastDs (CoreExpr -> CoreExpr
wrapper CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co))
| Just (Id
tyvar, Type
rest) <- Type -> Maybe (Id, Type)
splitForAllTyCoVar_maybe Type
result_ty
= do (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rest
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> forall b. b -> Expr b -> Expr b
Lam Id
tyvar (CoreExpr -> CoreExpr
wrapper CoreExpr
e))
| Just (TyCon
_tycon, [Type]
tycon_arg_tys, DataCon
data_con, [Scaled Type]
data_con_arg_tys) <- Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
result_ty,
DataCon -> Arity
dataConSourceArity DataCon
data_con forall a. Eq a => a -> a -> Bool
== Arity
1
= do let (Scaled Type
unwrapped_res_ty : [Scaled Type]
_) = [Scaled Type]
data_con_arg_tys
(Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper (forall a. Scaled a -> a
scaledThing Scaled Type
unwrapped_res_ty)
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe Type
maybe_ty, \CoreExpr
e -> forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
data_con))
(forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type [Type]
tycon_arg_tys forall a. [a] -> [a] -> [a]
++ [CoreExpr -> CoreExpr
wrapper CoreExpr
e]))
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"jsResultWrapper" (forall a. Outputable a => a -> SDoc
ppr Type
result_ty)
where
maybe_tc_app :: Maybe (TyCon, [Type])
maybe_tc_app = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
u String
tgt [CoreExpr]
args Type
t = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
u ForeignCall
ccall [CoreExpr]
args Type
t
where
ccall :: ForeignCall
ccall = CCallSpec -> ForeignCall
CCall forall a b. (a -> b) -> a -> b
$ CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
(SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText (String -> CLabelString
mkFastString String
tgt) (forall a. a -> Maybe a
Just Unit
primUnit) Bool
True)
CCallConv
JavaScriptCallConv
Safety
PlayRisky