{-# 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.DynFlags
import GHC.Driver.Config
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Data.FastString
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
)
dsJsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String)
dsJsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
let
ty :: Type
ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind 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 = [Scaled Type] -> [Scaled Type]
forall a. HasCallStack => [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 <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
return $
mkFExportJSBits platform ext_name
(if isDyn then Nothing else Just fn_id)
(map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv
mkFExportJSBits
:: Platform
-> FastString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader,
CStub,
String
)
mkFExportJSBits :: Platform
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String)
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)
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
(Arity -> SDoc -> SDoc
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) <- [Type] -> [Arity] -> [(Type, Arity)]
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 = String -> doc
forall doc. IsLine doc => String -> doc
text (Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
n)
type_string :: String
type_string = Platform -> Type -> Char
primTyDescChar Platform
platform Type
res_hty Char -> String -> String
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 HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy
unboxResType :: SDoc
unboxResType | Bool
res_hty_is_unit = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_getUnit"
| Bool
otherwise = Type -> SDoc
unpackHObj Type
res_hty
header_bits :: CHeader
header_bits = CHeader -> (Id -> CHeader) -> Maybe Id -> CHeader
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CHeader
forall a. Monoid a => a
mempty Id -> CHeader
forall {a}. Uniquable a => a -> CHeader
idTag Maybe Id
maybe_target
idTag :: a -> CHeader
idTag a
i = let (Char
tag, Word64
u) = Unique -> (Char, Word64)
unpkUnique (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
i)
in SDoc -> CHeader
CHeader (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
tag SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Word64 -> SDoc
forall doc. IsLine doc => Word64 -> doc
word64 Word64
u)
normal_args :: [SDoc]
normal_args = ((SDoc, SDoc, Type, CmmType) -> SDoc)
-> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
_ty,Type
_,CmmType
_) -> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
arg_info
all_args :: [SDoc]
all_args
| Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stableptr_offset" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
normal_args
| Bool
otherwise = [SDoc]
normal_args
fun_args :: SDoc
fun_args
| [(SDoc, SDoc, Type, CmmType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
arg_info = SDoc
forall doc. IsOutput doc => doc
empty
| Bool
otherwise = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
all_args
fun_proto :: SDoc
fun_proto
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"function" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(if Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm
else CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
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 (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
hs_fn) ->
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$foreignExport" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (
CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (UnitId -> CLabelString
unitIdFS (Module -> UnitId
moduleUnitId Module
m)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (ModuleName -> CLabelString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit CLabelString
c_nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (String -> CLabelString
mkFastString String
type_string)
) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
Maybe Id
_ -> SDoc
forall doc. IsOutput doc => doc
empty
strlit :: CLabelString -> doc
strlit CLabelString
xs = CLabelString -> doc
forall doc. IsLine doc => CLabelString -> doc
pprStringLit CLabelString
xs
the_cfun :: SDoc
the_cfun
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$deRefStablePtr(stableptr_offset)"
Just Id
hs_fn -> Id -> SDoc
idClosureText Id
hs_fn
expr_to_run :: SDoc
expr_to_run :: SDoc
expr_to_run
= (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
-> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
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
_)
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_apply"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
acc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
mkHObj Type
arg_hty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
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 = [CLabel]
forall a. Monoid a => a
mempty
, getFinalizers :: [CLabel]
getFinalizers = [CLabel]
forall a. Monoid a => a
mempty
}
where js_sdoc :: SDoc
js_sdoc = SDoc
forall doc. IsLine doc => doc
space
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_proto
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ SDoc
forall doc. IsLine doc => doc
lbrace
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"return"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_eval_sync"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ((if Bool
is_IO_res_ty
then SDoc
expr_to_run
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_toIO" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
expr_to_run)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
unboxResType)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
, SDoc
forall doc. IsLine doc => doc
rbrace
]
SDoc -> SDoc -> SDoc
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 <- Id -> 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 String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> String
zEncodeString String
str)
| Bool
otherwise
= String -> SDoc
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
_ Safety
_ Maybe Header
_ = do
let ty :: Type
ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind 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 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
FunctionOrData
IsFunction
Maybe TyCon
_ -> FunctionOrData
IsData
(_resTy, foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
ty
let rhs = CoreExpr -> CoreExpr
foRhs (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> FunctionOrData -> Literal
LitLabel CLabelString
cid FunctionOrData
fod))
rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
return ([(id, rhs')], mempty, 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 = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co0
([Id]
tvs,Type
sans_foralls) = Type -> ([Id], Type)
tcSplitForAllTyVars Type
ty
([Scaled Type
scaled_arg_ty], Type
fn_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
arg_ty :: Type
arg_ty = Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
scaled_arg_ty
(TyCon
io_tc, Type
res_ty) = String -> Maybe (TyCon, Type) -> (TyCon, Type)
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"dsJsFExportDynamic: IO type expected"
(Maybe (TyCon, Type) -> (TyCon, Type))
-> Maybe (TyCon, Type) -> (TyCon, Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
let fe_nm = String -> CLabelString
mkFastString (String -> CLabelString) -> String -> CLabelString
forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
(String
"h$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
moduleStableString Module
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
toJsName Id
id)
cback <- newSysLocalDs scaled_arg_ty
newStablePtrId <- dsLookupGlobalId newStablePtrName
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
export_ty = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
(h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
adj_args = [ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
stbl_value
, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm FunctionOrData
IsFunction)
, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
]
adjustor = String -> CLabelString
fsLit String
"createAdjustor"
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
let io_app = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
cback (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindIOId)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
stable_ptr_ty
, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty
, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
newStablePtrId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cback ]
, Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
stbl_value CoreExpr
ccall_adj
]
fed = (Id
id Id -> Activation -> Id
`setInlineActivation` Activation
NeverActive, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
return ([fed], h_code, c_code)
toJsName :: Id -> String
toJsName :: Id -> String
toJsName Id
i = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
pprCode (Name -> SDoc
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 = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind 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
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys
(val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args)
let
work_arg_ids = [Id
v | Var Id
v <- [CoreExpr]
val_args]
(ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty
ccall_uniq <- newUnique
work_uniq <- newUnique
simpl_opts <- initSimpleOpts <$> getDynFlags
let
fcall = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)
worker_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTysMany ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
tvs = (TyVarBinder -> Id) -> [TyVarBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
the_ccall_app = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
fcall [CoreExpr]
val_args Type
ccall_result_ty
work_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_arg_ids CoreExpr
the_ccall_app)
work_id = CLabelString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
ManyTy Type
worker_ty
work_app = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
wrapper_body = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
wrap_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
wrap_rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
fn_id_w_inl = Id
fn_id
Id -> Unfolding -> Id
`setIdUnfolding`
SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
simpl_opts UnfoldingSource
VanillaSrc
([Id] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
args) CoreExpr
wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty)
mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_mk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_get" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
showFFIType :: Type -> SDoc
showFFIType :: Type -> SDoc
showFFIType Type
t = CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext (OccName -> CLabelString
occNameFS (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Type -> TyCon
typeTyCon Type
t)))
typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
| Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
= TyCon
tc
| Bool
otherwise
= String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeTyCon" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
unboxJsArg :: CoreExpr
-> DsM (CoreExpr,
CoreExpr -> CoreExpr
)
unboxJsArg :: CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg CoreExpr
arg
| Type -> Bool
isPrimitiveType Type
arg_ty
= (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
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
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
arg Coercion
co)
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
= (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
\ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
boolTy) (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
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 TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
= (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
\ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
arg_ty) (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
| Bool
is_product_type Bool -> Bool -> Bool
&& Arity
data_con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
= do case_bndr <- Type -> DsM Id
newSysLocalMDs Type
arg_ty
prim_arg <- newSysLocalMDs (scaledThing data_con_arg_ty1)
return (Var prim_arg,
\ CoreExpr
body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
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 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
3,
Just TyCon
arg3_tycon <- Maybe TyCon
maybe_arg3_tycon,
(TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon)
= do case_bndr <- Type -> DsM Id
newSysLocalMDs Type
arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ CoreExpr
body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Id]
vars CoreExpr
body]
)
| Bool
otherwise
= do l <- DsM SrcSpan
getSrcSpanDs
pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty)
where
arg_ty :: Type
arg_ty = HasDebugCallStack => CoreExpr -> Type
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 = Maybe (TyCon, [Type], DataCon, [Scaled Type]) -> Bool
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 (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty3)
boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult Type
result_ty
| Just (TyCon
io_tycon, Type
io_res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
result_ty
= do { res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
io_res_ty
; let return_result CoreExpr
state CoreExpr
ans
= [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
state, CoreExpr
ans]
; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalMDs realWorldStatePrimTy
; let io_data_con = [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
io_tycon)
toIOCon = DataCon -> Id
dataConWrapId DataCon
io_data_con
wrap CoreExpr
the_call =
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
toIOCon)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
io_res_ty,
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
state_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id))
(Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(CoreAlt -> Type
coreAltType CoreAlt
the_alt)
[CoreAlt
the_alt]
]
; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
boxJsResult Type
result_ty
= do
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result res
let
wrap = \ CoreExpr
the_call -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
realWorldPrimId))
(Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(CoreAlt -> Type
coreAltType CoreAlt
the_alt)
[CoreAlt
the_alt]
return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, 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
state_id <- Type -> DsM Id
newSysLocalMDs Type
realWorldStatePrimTy
let
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"jsBoxResult")
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
the_alt = AltCon -> [Id] -> CoreExpr -> CoreAlt
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
return (ccall_res_ty, 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
ls :: [Type]
ls = [Type] -> [Type]
dropRuntimeRepArgs (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
prim_res_ty)
arity :: Arity
arity = Arity
1 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
ls
args_ids <- [Type] -> DsM [Id]
newSysLocalsMDs [Type]
ls
state_id <- newSysLocalMDs realWorldStatePrimTy
let
result_tup = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args_ids)
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result CoreExpr
result_tup)
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed (Type
realWorldStatePrimTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ls)
the_alt = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
arity))
(Id
state_id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
args_ids)
CoreExpr
the_rhs
return (ccall_res_ty, the_alt)
| Bool
otherwise = do
result_id <- Type -> DsM Id
newSysLocalMDs Type
prim_res_ty
state_id <- newSysLocalMDs realWorldStatePrimTy
let
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
(CoreExpr -> CoreExpr
wrap_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
result_id))
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
the_alt = AltCon -> [Id] -> CoreExpr -> CoreAlt
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
return (ccall_res_ty, the_alt)
jsResultWrapper
:: Type
-> DsM ( Maybe Type
, CoreExpr -> CoreExpr
)
jsResultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
| Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc = do
let args' :: [Type]
args' = [Type] -> [Type]
dropRuntimeRepArgs [Type]
args
(tys, wrappers) <- [(Maybe Type, CoreExpr -> CoreExpr)]
-> ([Maybe Type], [CoreExpr -> CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, CoreExpr -> CoreExpr)]
-> ([Maybe Type], [CoreExpr -> CoreExpr]))
-> IOEnv
(Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
-> IOEnv
(Env DsGblEnv DsLclEnv) ([Maybe Type], [CoreExpr -> CoreExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> DsM (Maybe Type, CoreExpr -> CoreExpr))
-> [Type]
-> IOEnv
(Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
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 -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper [Type]
args'
matched <- mapM (mapM newSysLocalMDs) tys
let tys' = [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
tys
err = String -> a
forall a. HasCallStack => String -> a
panic String
"jsResultWrapper: used Id with result type Nothing"
resWrap :: CoreExpr
resWrap = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple (((CoreExpr -> CoreExpr) -> Maybe Id -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> [Maybe Id] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\CoreExpr -> CoreExpr
w -> CoreExpr -> CoreExpr
w (CoreExpr -> CoreExpr)
-> (Maybe Id -> CoreExpr) -> Maybe Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> (Maybe Id -> Id) -> Maybe Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
forall {a}. a
err) [CoreExpr -> CoreExpr]
wrappers [Maybe Id]
matched)
return $
if null tys'
then (Nothing, \CoreExpr
_ -> CoreExpr
resWrap)
else let innerArity = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys'
innerTy = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys'
innerCon = Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
innerArity
inner :: CoreExpr -> CoreExpr
inner CoreExpr
e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
e (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
[AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
innerCon)
([Maybe Id] -> [Id]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Id]
matched)
CoreExpr
resWrap
]
in (Just innerTy, inner)
| Type -> Bool
isPrimitiveType Type
result_ty
= (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)
| Just (TyCon
tc, [Type]
args) <- Maybe (TyCon, [Type])
maybe_tc_app
, TyCon -> Bool
isBoxedTupleTyCon TyCon
tc = do
let innerTy :: Type
innerTy = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
args
(inner_res, w) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
innerTy
matched <- newSysLocalsMDs args
let inner CoreExpr
e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr
w CoreExpr
e) (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
[ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed ([Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args)))
[Id]
matched
([CoreExpr] -> CoreExpr
mkCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
matched))
]
return (inner_res, inner)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
= (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
forall a. Maybe a
Nothing, \CoreExpr
_ -> Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unitDataConId)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey = do
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
let forceBool CoreExpr
e = Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
ccall_uniq (String -> CLabelString
fsLit String
"((x) => { return !(!x); })") [CoreExpr
e] Type
boolTy
return
(Just intPrimTy, \CoreExpr
e -> CoreExpr -> CoreExpr
forceBool CoreExpr
e)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
= (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rep_ty
return (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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rest
return (maybe_ty, \CoreExpr
e -> Id -> CoreExpr -> CoreExpr
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 Arity -> Arity -> Bool
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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
unwrapped_res_ty)
return
(maybe_ty, \CoreExpr
e -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
data_con))
((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
tycon_arg_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr -> CoreExpr
wrapper CoreExpr
e]))
| Bool
otherwise
= String -> SDoc -> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"jsResultWrapper" (Type -> SDoc
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])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall :: Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
u CLabelString
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 (CCallSpec -> ForeignCall) -> CCallSpec -> ForeignCall
forall a b. (a -> b) -> a -> b
$ CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
(SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText CLabelString
tgt (Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
primUnit) Bool
True)
CCallConv
JavaScriptCallConv
Safety
PlayRisky