{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.Wasm
( dsWasmJSImport,
dsWasmJSExport,
)
where
import Data.List
( intercalate,
stripPrefix,
)
import Data.Maybe
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core
import GHC.Core.Coercion
import GHC.Core.DataCon
import GHC.Core.Make
import GHC.Core.Multiplicity
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Utils
import GHC.Data.FastString
import GHC.Hs
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Monad
import GHC.HsToCore.Types
import GHC.Iface.Env
import GHC.Prelude
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Types.ForeignCall
import GHC.Types.ForeignStubs
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic
dsWasmJSImport ::
Id ->
Coercion ->
CImportSpec ->
Safety ->
DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSImport :: Id
-> Coercion
-> CImportSpec
-> Safety
-> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSImport Id
id Coercion
co (CFunction (StaticTarget SourceText
_ FastString
js_src Maybe Unit
mUnitId Bool
_)) Safety
safety
| FastString
js_src FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"wrapper" = Id
-> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport Id
id Coercion
co Maybe Unit
mUnitId
| Bool
otherwise = do
(bs, h, c) <- Id
-> Coercion
-> [Char]
-> Maybe Unit
-> Safety
-> DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport Id
id Coercion
co (FastString -> [Char]
unpackFS FastString
js_src) Maybe Unit
mUnitId Safety
safety
pure (bs, h, c, [])
dsWasmJSImport Id
_ Coercion
_ CImportSpec
_ Safety
_ = [Char] -> DsM ([Binding], CHeader, CStub, [Id])
forall a. HasCallStack => [Char] -> a
panic [Char]
"dsWasmJSImport: unreachable"
dsWasmJSDynamicExport ::
Id -> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport :: Id
-> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport Id
fn_id Coercion
co Maybe Unit
mUnitId = do
sp_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
let ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co
(tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty
([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty
sp_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
sp_tycon [Type
arg_ty]
(real_arg_tys, _) = tcSplitFunTys arg_ty
sp_id <- newSysLocalMDs sp_ty
work_uniq <- newUnique
work_export_name <- uniqueCFunName
deRefStablePtr_id <- lookupGhcInternalVarId "GHC.Internal.Stable" "deRefStablePtr"
unsafeDupablePerformIO_id <-
lookupGhcInternalVarId
"GHC.Internal.IO.Unsafe"
"unsafeDupablePerformIO"
let work_id =
Name -> Type -> Id
mkExportedVanillaId
( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
Unique
work_uniq
(HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
([Char] -> OccName
mkVarOcc ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_work")
SrcSpan
generatedSrcSpan
)
Type
work_ty
work_rhs =
[Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs] [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
sp_id])
(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
unsafeDupablePerformIO_id)
[Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
deRefStablePtr_id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sp_id]]
work_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
work_rhs
(work_h, work_c, _, work_ids, work_bs) <-
dsWasmJSExport
work_id
(mkRepReflCo work_ty)
work_export_name
adjustor_uniq <- newUnique
let adjustor_id =
Name -> Type -> Id
mkExportedVanillaId
( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
Unique
adjustor_uniq
(HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
( [Char] -> OccName
mkVarOcc
([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id)
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_adjustor"
)
SrcSpan
generatedSrcSpan
)
Type
adjustor_ty
adjustor_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
mkVisFunTysMany [Type
sp_ty] Type
io_jsval_ty
adjustor_js_src =
[Char]
"("
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"a" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
real_arg_tys]]
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") => __exports."
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FastString -> [Char]
unpackFS FastString
work_export_name
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"($1"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat [[Char]
",a" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
real_arg_tys]]
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
(adjustor_bs, adjustor_h, adjustor_c) <-
dsWasmJSStaticImport
adjustor_id
(mkRepReflCo adjustor_ty)
adjustor_js_src
mUnitId
PlayRisky
mkJSCallback_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "mkJSCallback"
let wrap_rhs =
[Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs]
(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
mkJSCallback_id)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty,
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
(Id -> CoreExpr
forall b. Id -> Expr b
Var Id
adjustor_id)
[Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> Type -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> Type
mkTyVarTy Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs]
]
pure
( [(fn_id, Cast wrap_rhs co), (work_id, work_rhs)] ++ work_bs ++ adjustor_bs,
work_h `mappend` adjustor_h,
work_c `mappend` adjustor_c,
work_ids
)
dsWasmJSStaticImport ::
Id ->
Coercion ->
String ->
Maybe Unit ->
Safety ->
DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport :: Id
-> Coercion
-> [Char]
-> Maybe Unit
-> Safety
-> DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport Id
fn_id Coercion
co [Char]
js_src' Maybe Unit
mUnitId Safety
safety = do
cfun_name <- DsM FastString
uniqueCFunName
let ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co
(tvs, fun_ty) = tcSplitForAllInvisTyVars ty
(arg_tys, orig_res_ty) = tcSplitFunTys fun_ty
(res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of
Just (TyCon
_, Type
res_ty) -> (Type
res_ty, Bool
True)
Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
js_src
| [Char]
js_src' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"dynamic" =
[Char]
"$1("
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
2 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
arg_tys]]
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
| Bool
otherwise =
[Char]
js_src'
case safety of
Safety
PlayRisky -> do
rhs <-
Maybe Unit
-> Safety
-> FastString
-> [Id]
-> [Scaled Type]
-> Type
-> (CoreExpr -> CoreExpr)
-> DsM CoreExpr
importBindingRHS
Maybe Unit
mUnitId
Safety
PlayRisky
FastString
cfun_name
[Id]
tvs
[Scaled Type]
arg_tys
Type
orig_res_ty
CoreExpr -> CoreExpr
forall a. a -> a
id
pure
( [(fn_id, Cast rhs co)],
CHeader commonCDecls,
importCStub
PlayRisky
cfun_name
(map scaledThing arg_tys)
res_ty
js_src
)
Safety
_ -> do
io_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
ioTyConName
jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"
bindIO_id <- dsLookupGlobalId bindIOName
returnIO_id <- dsLookupGlobalId returnIOName
promise_id <- newSysLocalMDs jsval_ty
blockPromise_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" "stg_blockPromise"
msgPromise_id <-
lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty
unsafeDupablePerformIO_id <-
lookupGhcInternalVarId
"GHC.Internal.IO.Unsafe"
"unsafeDupablePerformIO"
rhs <-
importBindingRHS
mUnitId
PlaySafe
cfun_name
tvs
arg_tys
(mkTyConApp io_tycon [jsval_ty])
$ ( if is_io
then id
else \CoreExpr
m_res ->
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unsafeDupablePerformIO_id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
m_res]
)
. ( \CoreExpr
m_promise ->
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
(Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindIO_id)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
jsval_ty,
Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty,
CoreExpr
m_promise,
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
promise_id
(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
returnIO_id)
[ 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
blockPromise_id)
[Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
promise_id, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
msgPromise_id]
]
]
)
pure
( [(fn_id, Cast rhs co)],
CHeader commonCDecls,
importCStub
PlaySafe
cfun_name
(map scaledThing arg_tys)
jsval_ty
js_src
)
uniqueCFunName :: DsM FastString
uniqueCFunName :: DsM FastString
uniqueCFunName = do
cfun_num <- DsGblEnv -> IORef (ModuleEnv Int)
ds_next_wrapper_num (DsGblEnv -> IORef (ModuleEnv Int))
-> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (ModuleEnv Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
mkWrapperName cfun_num "ghc_wasm_jsffi" ""
importBindingRHS ::
Maybe Unit ->
Safety ->
FastString ->
[TyVar] ->
[Scaled Type] ->
Type ->
(CoreExpr -> CoreExpr) ->
DsM CoreExpr
importBindingRHS :: Maybe Unit
-> Safety
-> FastString
-> [Id]
-> [Scaled Type]
-> Type
-> (CoreExpr -> CoreExpr)
-> DsM CoreExpr
importBindingRHS Maybe Unit
mUnitId Safety
safety FastString
cfun_name [Id]
tvs [Scaled Type]
arg_tys Type
orig_res_ty CoreExpr -> CoreExpr
res_trans =
do
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
args_unevaled <- newSysLocalsDs arg_tys
args_evaled <- newSysLocalsDs arg_tys
(ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of
Just (TyCon
io_tycon, Type
res_ty) -> do
s0_id <- Type -> DsM Id
newSysLocalMDs Type
realWorldStatePrimTy
s1_id <- newSysLocalMDs realWorldStatePrimTy
let io_data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
io_tycon
toIOCon = DataCon -> Id
dataConWorkId DataCon
io_data_con
(ccall_res_ty, wrap)
| res_ty `eqType` unitTy =
( mkTupleTy Unboxed [realWorldStatePrimTy],
\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
res_ty,
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
s0_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
s0_id))
(Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
unitTy])
[ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt
(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
1))
[Id
s1_id]
([CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
s1_id, CoreExpr
unitExpr])
]
]
)
| otherwise =
( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],
\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
res_ty, CoreExpr
the_call]
)
pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
Maybe (TyCon, Type)
Nothing -> do
unsafeDupablePerformIO_id <-
FastString -> [Char] -> DsM Id
lookupGhcInternalVarId
FastString
"GHC.Internal.IO.Unsafe"
[Char]
"unsafeDupablePerformIO"
io_data_con <- dsLookupDataCon ioDataConName
let ccall_res_ty =
Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
orig_res_ty]
toIOCon = DataCon -> Id
dataConWorkId 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
unsafeDupablePerformIO_id)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
orig_res_ty,
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
orig_res_ty, CoreExpr
the_call]
]
pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
let cfun_fcall =
CCallSpec -> ForeignCall
CCall
( CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
(SourceText -> FastString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText FastString
cfun_name Maybe Unit
mUnitId Bool
True)
CCallConv
CCallConv
Safety
safety
)
call_app =
Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
cfun_fcall ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args_evaled) Type
ccall_action_ty
rhs =
[Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args_unevaled)
(CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ ((Id, Id) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Id, Id)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\(Id
arg_u, Id
arg_e) CoreExpr
acc -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_u) Id
arg_e CoreExpr
acc)
(CoreExpr -> CoreExpr
res_trans (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
res_wrapper CoreExpr
call_app)
([Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
args_unevaled [Id]
args_evaled)
pure rhs
importCStub :: Safety -> FastString -> [Type] -> Type -> String -> CStub
importCStub :: Safety -> FastString -> [Type] -> Type -> [Char] -> CStub
importCStub Safety
safety FastString
cfun_name [Type]
arg_tys Type
res_ty [Char]
js_src = SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
c_doc [] []
where
import_name :: [Char]
import_name = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"ghczuwasmzujsffi" (FastString -> [Char]
unpackFS FastString
cfun_name)
import_asm :: SDoc
import_asm =
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__asm__"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
l)
| [Char]
l <-
[ [Char]
".section .custom_section.ghc_wasm_jsffi,\"\",@\n",
[Char]
".asciz \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
import_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"\n",
[Char]
".asciz \""
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ( case Safety
safety of
Safety
PlayRisky -> [Char]
"("
Safety
_ -> [Char]
"async ("
)
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
arg_tys]]
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")\"\n",
[Char]
".asciz " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
js_src [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
]
]
)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
import_attr :: SDoc
import_attr =
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__attribute__"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
( SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
SDoc
forall doc. IsLine doc => doc
comma
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
v))
| ([Char]
k, [Char]
v) <-
[([Char]
"import_module", [Char]
"ghc_wasm_jsffi"), ([Char]
"import_name", [Char]
import_name)]
]
)
)
)
import_proto :: SDoc
import_proto =
SDoc
import_res_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
import_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
import_args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
import_res_ty :: SDoc
import_res_ty
| Type
res_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
| Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
res_ty)
import_arg_list :: [SDoc]
import_arg_list =
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
arg_ty) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
| (Int
i, Type
arg_ty) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Type]
arg_tys
]
import_args :: SDoc
import_args = case [SDoc]
import_arg_list of
[] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
[SDoc]
_ -> [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]
import_arg_list
cfun_proto :: SDoc
cfun_proto = SDoc
cfun_res_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
cfun_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
cfun_args
cfun_ret :: SDoc
cfun_ret
| Type
res_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy = SDoc
cfun_call_import SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
| Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"return" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cfun_call_import SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
cfun_make_arg :: Type -> doc -> doc
cfun_make_arg Type
arg_ty doc
arg_val =
[Char] -> doc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_get" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
arg_ty) doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> doc -> doc
forall doc. IsLine doc => doc -> doc
parens doc
arg_val
cfun_make_ret :: SDoc -> SDoc
cfun_make_ret SDoc
ret_val
| Type
res_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy = SDoc
ret_val
| Bool
otherwise =
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
res_ty)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&MainCapability", SDoc
ret_val]))
cfun_call_import :: SDoc
cfun_call_import =
SDoc -> SDoc
cfun_make_ret
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
import_name
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
( SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
SDoc
forall doc. IsLine doc => doc
comma
[ Type -> SDoc -> SDoc
forall {doc}. IsLine doc => Type -> doc -> doc
cfun_make_arg Type
arg_ty (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n)
| (Type
arg_ty, Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_tys [Int
1 ..]
]
)
)
cfun_res_ty :: SDoc
cfun_res_ty
| Type
res_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
| Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj"
cfun_arg_list :: [SDoc]
cfun_arg_list =
[[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n | Int
n <- [Int
1 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
arg_tys]]
cfun_args :: SDoc
cfun_args = case [SDoc]
cfun_arg_list of
[] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
[SDoc]
_ -> [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]
cfun_arg_list
c_doc :: SDoc
c_doc =
SDoc
commonCDecls
SDoc -> SDoc -> SDoc
$+$ SDoc
import_asm
SDoc -> SDoc -> SDoc
$+$ SDoc
import_attr
SDoc -> SDoc -> SDoc
$+$ SDoc
import_proto
SDoc -> SDoc -> SDoc
$+$ SDoc
cfun_proto
SDoc -> SDoc -> SDoc
$+$ SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
cfun_ret
dsWasmJSExport ::
Id ->
Coercion ->
CLabelString ->
DsM (CHeader, CStub, String, [Id], [Binding])
dsWasmJSExport :: Id
-> Coercion
-> FastString
-> DsM (CHeader, CStub, [Char], [Id], [Binding])
dsWasmJSExport Id
fn_id Coercion
co FastString
ext_name = do
work_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
let ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind Coercion
co
(tvs, fun_ty) = tcSplitForAllInvisTyVars ty
(arg_tys, orig_res_ty) = tcSplitFunTys fun_ty
(res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of
Just (TyCon
_, Type
res_ty) -> (Type
res_ty, Bool
True)
Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
(_, res_ty_args) = splitTyConApp res_ty
res_ty_str = Type -> [Char]
ffiType Type
res_ty
args <- newSysLocalsDs arg_tys
promiseRes_id <-
lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" $ "js_promiseResolve" ++ res_ty_str
runIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runIO"
runNonIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runNonIO"
let work_id =
Name -> Type -> Id
mkExportedVanillaId
( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
Unique
work_uniq
(HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
([Char] -> OccName
mkVarOcc ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id))
SrcSpan
generatedSrcSpan
)
(HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
work_rhs)
work_rhs =
[Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args)
(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 -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$ if Bool
is_io then Id
runIO_id else Id
runNonIO_id)
[ 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
promiseRes_id) ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
res_ty_args,
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fn_id) Coercion
co)
([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Id -> Type) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
mkTyVarTy) [Id]
tvs
[CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args
]
work_closure = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
work_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"_closure"
work_closure_decl = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"extern StgClosure" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
work_closure SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
cstub_attr =
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__attribute__"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
(SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"export_name" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name))
cstub_arg_list =
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
| (Int
i, Scaled Type
arg_ty) <- [Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Scaled Type]
arg_tys
]
cstub_args = case [SDoc]
cstub_arg_list of
[] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
[SDoc]
_ -> [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]
cstub_arg_list
cstub_proto = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HsJSVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
cstub_args
cstub_body =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ SDoc
forall doc. IsLine doc => doc
lbrace,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Capability *cap = rts_lock();",
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj ret;",
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_evalLazyIO"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( [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
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&cap",
(SDoc -> (Int, Scaled Type) -> SDoc)
-> SDoc -> [(Int, Scaled Type)] -> 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
acc (Int
i, Scaled Type
arg_ty) ->
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_apply"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
( [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
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap",
SDoc
acc,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty))
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
([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 [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap", Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i])
]
)
)
(Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'&' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
work_closure)
([(Int, Scaled Type)] -> SDoc) -> [(Int, Scaled Type)] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Scaled Type]
arg_tys,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&ret"
]
)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_checkSchedStatus"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name) 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
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap")
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_unlock(cap);",
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"return rts_getJSVal(ret);",
SDoc
forall doc. IsLine doc => doc
rbrace
]
cstub =
SDoc
commonCDecls
SDoc -> SDoc -> SDoc
$+$ SDoc
work_closure_decl
SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_attr
SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_proto
SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_body
pure
( CHeader commonCDecls,
CStub cstub [] [],
"",
[work_id],
[(work_id, work_rhs)]
)
lookupGhcInternalVarId :: FastString -> String -> DsM Id
lookupGhcInternalVarId :: FastString -> [Char] -> DsM Id
lookupGhcInternalVarId FastString
m [Char]
v = do
n <- Module -> OccName -> TcRnIf DsGblEnv DsLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (FastString -> Module
mkGhcInternalModule FastString
m) ([Char] -> OccName
mkVarOcc [Char]
v)
dsLookupGlobalId n
lookupGhcInternalTyCon :: FastString -> String -> DsM TyCon
lookupGhcInternalTyCon :: FastString -> [Char] -> DsM TyCon
lookupGhcInternalTyCon FastString
m [Char]
t = do
n <- Module -> OccName -> TcRnIf DsGblEnv DsLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (FastString -> Module
mkGhcInternalModule FastString
m) ([Char] -> OccName
mkTcOcc [Char]
t)
dsLookupTyCon n
ffiType :: Type -> String
ffiType :: Type -> [Char]
ffiType = OccName -> [Char]
occNameString (OccName -> [Char]) -> (Type -> OccName) -> Type -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (TyCon -> OccName) -> (Type -> TyCon) -> Type -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [Type]) -> TyCon)
-> (Type -> (TyCon, [Type])) -> Type -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (TyCon, [Type])
splitTyConApp
commonCDecls :: SDoc
commonCDecls :: SDoc
commonCDecls =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"typedef __externref_t HsJSVal;",
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HsJSVal rts_getJSVal(HaskellObj);",
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj rts_mkJSVal(Capability*, HsJSVal);"
]