[Git][ghc/ghc][wip/wasm-jsffi-sync-export] 8 commits: Cmm/Parser: Add surface syntax for Mul2 MachOps
Cheng Shao (@TerrorJack)
gitlab at gitlab.haskell.org
Fri Feb 21 01:17:53 UTC 2025
Cheng Shao pushed to branch wip/wasm-jsffi-sync-export at Glasgow Haskell Compiler / GHC
Commits:
ef5470a2 by Ben Gamari at 2025-02-19T16:30:53+00:00
Cmm/Parser: Add surface syntax for Mul2 MachOps
These are otherwise very hard to test in isolation.
- - - - -
59b9307b by Cheng Shao at 2025-02-19T20:24:40-05:00
testsuite: fix InternalCounters test with +debug_ghc
The `InternalCounters` test case fails when ghc is built with
`+debug_ghc`. This patch skips it in that case and allows the
testsuite to pass for the `+debug_ghc` flavour transformer.
- - - - -
aa69187d by M Farkas-Dyck at 2025-02-19T20:25:31-05:00
Scrub a use of `head` in `GHC.Driver.Make.downsweep_imports.checkDuplicates`.
- - - - -
0d32eb88 by Cheng Shao at 2025-02-20T23:44:59+00:00
rts: correct top handler closure signatures
- - - - -
f4703e89 by Cheng Shao at 2025-02-20T23:48:17+00:00
compiler: allow arbitrary label string for JSFFI exports
- - - - -
a06907f3 by Cheng Shao at 2025-02-21T00:13:27+00:00
compiler: wasm backend JSFFI sync exports
- - - - -
9ea3aa2f by Cheng Shao at 2025-02-21T00:37:20+00:00
testsuite: test wasm backend JSFFI sync exports
- - - - -
2ce6ecb0 by Cheng Shao at 2025-02-21T01:17:19+00:00
docs: document wasm backend JSFFI sync exports
- - - - -
12 changed files:
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Driver/Make.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- docs/users_guide/wasm.rst
- rts/include/RtsAPI.h
- testsuite/tests/jsffi/jsffigc.hs
- testsuite/tests/jsffi/jsffigc.mjs
- testsuite/tests/jsffi/textconv.hs
- testsuite/tests/jsffi/textconv.mjs
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1194,6 +1194,8 @@ callishMachOps platform = listToUFM $
, allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand)
, allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or)
, allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor)
+ , allWidths "mul2_" (\w -> MO_S_Mul2 w)
+ , allWidths "mul2u_" (\w -> MO_U_Mul2 w)
]
where
allWidths
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1682,9 +1682,9 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
:: DownsweepCache
-> IO ()
checkDuplicates root_map
- | allow_dup_roots = return ()
- | null dup_roots = return ()
- | otherwise = liftIO $ multiRootsErr (head dup_roots)
+ | not allow_dup_roots
+ , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root
+ | otherwise = pure ()
where
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -515,8 +515,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
, text "rts_inCall" <> parens (
char '&' <> cap <>
text "rts_apply" <> parens (
- cap <>
- text "(HaskellObj)"
+ cap
<> (if is_IO_res_ty
then text "runIO_closure"
else text "runNonIO_closure")
=====================================
compiler/GHC/HsToCore/Foreign/Wasm.hs
=====================================
@@ -11,6 +11,7 @@ import Data.List
( intercalate,
stripPrefix,
)
+import Data.List qualified
import Data.Maybe
import GHC.Builtin.Names
import GHC.Builtin.Types
@@ -46,6 +47,9 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic
+data Synchronicity = Sync | Async
+ deriving (Eq)
+
dsWasmJSImport ::
Id ->
Coercion ->
@@ -53,10 +57,15 @@ dsWasmJSImport ::
Safety ->
DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSImport id co (CFunction (StaticTarget _ js_src mUnitId _)) safety
- | js_src == "wrapper" = dsWasmJSDynamicExport id co mUnitId
+ | js_src == "wrapper" = dsWasmJSDynamicExport Async id co mUnitId
+ | js_src == "wrapper sync" = dsWasmJSDynamicExport Sync id co mUnitId
| otherwise = do
- (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId safety
+ (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId sync
pure (bs, h, c, [])
+ where
+ sync = case safety of
+ PlayRisky -> Sync
+ _ -> Async
dsWasmJSImport _ _ _ _ = panic "dsWasmJSImport: unreachable"
{-
@@ -77,17 +86,18 @@ We desugar it to three bindings under the hood:
mk_wrapper_worker :: StablePtr HsFuncType -> HsFuncType
mk_wrapper_worker sp = unsafeDupablePerformIO (deRefStablePtr sp)
-No need to bother with eta-expansion here. Also, the worker function
-is marked as a JSFFI static export.
+The worker function is marked as a JSFFI static export. It turns a
+dynamic export to a static one by prepending a StablePtr to the
+argument list.
2. The adjustor function
foreign import javascript unsafe "(...args) => __exports.mk_wrapper_worker($1, ...args)"
mk_wrapper_adjustor :: StablePtr HsFuncType -> IO JSVal
-It generates a JavaScript callback that captures the stable pointer.
-When the callback is invoked later, it calls our worker function and
-passes the stable pointer as well as the rest of the arguments.
+Now that mk_wrapper_worker is exported in __exports, we need to make a
+JavaScript callback that invokes mk_wrapper_worker with the right
+StablePtr as well as the rest of the arguments.
3. The wrapper function
@@ -102,21 +112,34 @@ a StablePtr# field which is NULL by default, but for JSFFI dynamic
exports, it's set to the Haskell function's stable pointer. This way,
when we call freeJSVal, the Haskell function can be freed as well.
+By default, JSFFI exports are async JavaScript functions. One can use
+"wrapper sync" instead of "wrapper" to indicate the Haskell function
+is meant to be exported as a sync JavaScript function. All the
+comments above still hold, with only only difference:
+mk_wrapper_worker is exported as a sync function. See
+Note [Desugaring JSFFI static export] for further details.
+
-}
dsWasmJSDynamicExport ::
- Id -> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
-dsWasmJSDynamicExport fn_id co mUnitId = do
+ Synchronicity ->
+ Id ->
+ Coercion ->
+ Maybe Unit ->
+ DsM ([Binding], CHeader, CStub, [Id])
+dsWasmJSDynamicExport sync fn_id co mUnitId = do
sp_tycon <- dsLookupTyCon stablePtrTyConName
let ty = coercionLKind co
(tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty
([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty
sp_ty = mkTyConApp sp_tycon [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"
+ work_export_name <- unpackFS <$> uniqueCFunName
+ deRefStablePtr_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.Stable"
+ "deRefStablePtr"
unsafeDupablePerformIO_id <-
lookupGhcInternalVarId
"GHC.Internal.IO.Unsafe"
@@ -137,7 +160,8 @@ dsWasmJSDynamicExport fn_id co mUnitId = do
[Type arg_ty, mkApps (Var deRefStablePtr_id) [Type arg_ty, Var sp_id]]
work_ty = exprType work_rhs
(work_h, work_c, _, work_ids, work_bs) <-
- dsWasmJSExport
+ dsWasmJSExport'
+ sync
work_id
(mkRepReflCo work_ty)
work_export_name
@@ -157,21 +181,18 @@ dsWasmJSDynamicExport fn_id co mUnitId = do
adjustor_ty
adjustor_ty = mkForAllTys tv_bndrs $ mkVisFunTysMany [sp_ty] io_jsval_ty
adjustor_js_src =
- "("
- ++ intercalate "," ["a" ++ show i | i <- [1 .. length real_arg_tys]]
- ++ ") => __exports."
- ++ unpackFS work_export_name
- ++ "($1"
- ++ mconcat [",a" ++ show i | i <- [1 .. length real_arg_tys]]
- ++ ")"
+ "(...args) => __exports." ++ work_export_name ++ "($1, ...args)"
(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"
+ Sync
+ mkJSCallback_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.Wasm.Prim.Exports"
+ "mkJSCallback"
let wrap_rhs =
mkCoreLams [tv | Bndr tv _ <- tv_bndrs]
$ mkApps
@@ -194,7 +215,7 @@ Note [Desugaring JSFFI import]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The simplest case is JSFFI sync import, those marked as unsafe. It is
-implemented on top of C FFI unsafe import.
+implemented on top of C FFI safe import.
Unlike C FFI which generates a worker/wrapper pair that unboxes the
arguments and boxes the result in Haskell, we only desugar to a single
@@ -202,10 +223,11 @@ Haskell binding that case-binds the arguments to ensure they're
evaluated, then passes the boxed arguments directly to C and receive
the boxed result from C as well.
-This is of course less efficient than how C FFI does it, and unboxed
-FFI types aren't supported, but it's the easiest way to implement it,
+This is slightly less efficient than how C FFI does it, and unboxed
+FFI types aren't supported, but it's the simplest way to implement it,
especially since leaving all the boxing/unboxing business to C unifies
-the implementation of JSFFI imports and exports.
+the implementation of JSFFI imports and exports
+(rts_mkJSVal/rts_getJSVal).
Now, each sync import calls a generated C function with a unique
symbol. The C function uses rts_get* to unbox the arguments, call into
@@ -240,6 +262,14 @@ module. Note that above is assembly source file, but we're only
generating a C stub, so we need to smuggle the assembly code into C
via __asm__.
+The C FFI import that calls the generated C function is always marked
+as safe. There is some extra overhead, but this allows re-entrance by
+Haskell -> JavaScript -> Haskell function calls with each call being a
+synchronous one. It's possible to steal the "interruptible" keyword to
+indicate async imports, "safe" for sync imports and "unsafe" for sync
+imports sans the safe C FFI overhead, but it's simply not worth the
+extra complexity.
+
JSFFI async import is implemented on top of JSFFI sync import. We
still desugar it to a single Haskell binding that calls C, with some
subtle differences:
@@ -250,12 +280,6 @@ subtle differences:
"($1, $2)". As you can see, it is the arrow function binder, and the
post-linker will respect the async binder and allow await in the
function body.
-- The C import is also marked as safe. This is required since the
- JavaScript code may re-enter Haskell. If re-entrance only happens in
- future event loop tasks, it's fine to mark the C import as unsafe
- since the current Haskell execution context has already been freed
- at that point, but there's no such guarantee, so better safe than
- sorry here.
Now we have the Promise JSVal, we apply stg_blockPromise to it to get
a thunk with the desired return type. When the thunk is forced, it
@@ -270,9 +294,9 @@ dsWasmJSStaticImport ::
Coercion ->
String ->
Maybe Unit ->
- Safety ->
+ Synchronicity ->
DsM ([Binding], CHeader, CStub)
-dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do
+dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do
cfun_name <- uniqueCFunName
let ty = coercionLKind co
(tvs, fun_ty) = tcSplitForAllInvisTyVars ty
@@ -289,36 +313,30 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do
++ ")"
| otherwise =
js_src'
- case safety of
- PlayRisky -> do
- rhs <-
- importBindingRHS
- mUnitId
- PlayRisky
- cfun_name
- tvs
- arg_tys
- orig_res_ty
- id
+ case sync of
+ Sync -> do
+ rhs <- importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty id
pure
( [(fn_id, Cast rhs co)],
CHeader commonCDecls,
- importCStub
- PlayRisky
- cfun_name
- (map scaledThing arg_tys)
- res_ty
- js_src
+ importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src
)
- _ -> do
+ Async -> do
io_tycon <- dsLookupTyCon ioTyConName
- jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"
+ 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"
+ blockPromise_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.Wasm.Prim.Imports"
+ "stg_blockPromise"
msgPromise_id <-
- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty
+ lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports"
+ $ "stg_messagePromise"
+ ++ ffiType res_ty
unsafeDupablePerformIO_id <-
lookupGhcInternalVarId
"GHC.Internal.IO.Unsafe"
@@ -326,7 +344,6 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do
rhs <-
importBindingRHS
mUnitId
- PlaySafe
cfun_name
tvs
arg_tys
@@ -357,12 +374,7 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId safety = do
pure
( [(fn_id, Cast rhs co)],
CHeader commonCDecls,
- importCStub
- PlaySafe
- cfun_name
- (map scaledThing arg_tys)
- jsval_ty
- js_src
+ importCStub Async cfun_name (map scaledThing arg_tys) jsval_ty js_src
)
uniqueCFunName :: DsM FastString
@@ -372,92 +384,91 @@ uniqueCFunName = do
importBindingRHS ::
Maybe Unit ->
- Safety ->
FastString ->
[TyVar] ->
[Scaled Type] ->
Type ->
(CoreExpr -> CoreExpr) ->
DsM CoreExpr
-importBindingRHS mUnitId safety cfun_name tvs arg_tys orig_res_ty res_trans =
- do
- ccall_uniq <- newUnique
- args_unevaled <- newSysLocalsDs arg_tys
- args_evaled <- newSysLocalsDs arg_tys
- -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #)
- -- res_wrapper: turn the_call to (IO a) or a
- (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of
- Just (io_tycon, res_ty) -> do
- s0_id <- newSysLocalMDs realWorldStatePrimTy
- s1_id <- newSysLocalMDs realWorldStatePrimTy
- let io_data_con = tyConSingleDataCon io_tycon
- toIOCon = dataConWorkId io_data_con
- (ccall_res_ty, wrap)
- | res_ty `eqType` unitTy =
- ( mkTupleTy Unboxed [realWorldStatePrimTy],
- \the_call ->
- mkApps
- (Var toIOCon)
- [ Type res_ty,
- Lam s0_id
- $ mkWildCase
- (App the_call (Var s0_id))
- (unrestricted ccall_res_ty)
- (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy])
- [ Alt
- (DataAlt (tupleDataCon Unboxed 1))
- [s1_id]
- (mkCoreUnboxedTuple [Var s1_id, unitExpr])
- ]
- ]
- )
- | otherwise =
- ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],
- \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call]
- )
- pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
- Nothing -> do
- unsafeDupablePerformIO_id <-
- lookupGhcInternalVarId
- "GHC.Internal.IO.Unsafe"
- "unsafeDupablePerformIO"
- io_data_con <- dsLookupDataCon ioDataConName
- let ccall_res_ty =
- mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty]
- toIOCon = dataConWorkId io_data_con
- wrap the_call =
- mkApps
- (Var unsafeDupablePerformIO_id)
- [ Type orig_res_ty,
- mkApps (Var toIOCon) [Type orig_res_ty, the_call]
- ]
- pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
- let cfun_fcall =
- CCall
- ( CCallSpec
- (StaticTarget NoSourceText cfun_name mUnitId True)
- CCallConv
- safety
- )
- call_app =
- mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty
- rhs =
- mkCoreLams (tvs ++ args_unevaled)
- $ foldr
- (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc)
- -- res_trans transforms the result. When desugaring
- -- JSFFI sync imports, the result is just (IO a) or a,
- -- and res_trans is id; for async cases, the result is
- -- always (IO JSVal), and res_trans will wrap it in a
- -- thunk that has the original return type. This way, we
- -- can reuse most of the RHS generation logic for both
- -- sync/async imports.
- (res_trans $ res_wrapper call_app)
- (zip args_unevaled args_evaled)
- pure rhs
-
-importCStub :: Safety -> FastString -> [Type] -> Type -> String -> CStub
-importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []
+importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty res_trans = do
+ ccall_uniq <- newUnique
+ args_unevaled <- newSysLocalsDs arg_tys
+ args_evaled <- newSysLocalsDs arg_tys
+ -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #)
+ -- res_wrapper: turn the_call to (IO a) or a
+ (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of
+ Just (io_tycon, res_ty) -> do
+ s0_id <- newSysLocalMDs realWorldStatePrimTy
+ s1_id <- newSysLocalMDs realWorldStatePrimTy
+ let io_data_con = tyConSingleDataCon io_tycon
+ toIOCon = dataConWorkId io_data_con
+ (ccall_res_ty, wrap)
+ | res_ty `eqType` unitTy =
+ ( mkTupleTy Unboxed [realWorldStatePrimTy],
+ \the_call ->
+ mkApps
+ (Var toIOCon)
+ [ Type res_ty,
+ Lam s0_id
+ $ mkWildCase
+ (App the_call (Var s0_id))
+ (unrestricted ccall_res_ty)
+ (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy])
+ [ Alt
+ (DataAlt (tupleDataCon Unboxed 1))
+ [s1_id]
+ (mkCoreUnboxedTuple [Var s1_id, unitExpr])
+ ]
+ ]
+ )
+ | otherwise =
+ ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],
+ \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call]
+ )
+ pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
+ Nothing -> do
+ unsafeDupablePerformIO_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.IO.Unsafe"
+ "unsafeDupablePerformIO"
+ io_data_con <- dsLookupDataCon ioDataConName
+ let ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty]
+ toIOCon = dataConWorkId io_data_con
+ wrap the_call =
+ mkApps
+ (Var unsafeDupablePerformIO_id)
+ [ Type orig_res_ty,
+ mkApps (Var toIOCon) [Type orig_res_ty, the_call]
+ ]
+ pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
+ let cfun_fcall =
+ CCall
+ ( CCallSpec
+ (StaticTarget NoSourceText cfun_name mUnitId True)
+ CCallConv
+ -- Same even for foreign import javascript unsafe, for
+ -- the sake of re-entrancy.
+ PlaySafe
+ )
+ call_app =
+ mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty
+ rhs =
+ mkCoreLams (tvs ++ args_unevaled)
+ $ foldr
+ (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc)
+ -- res_trans transforms the result. When desugaring
+ -- JSFFI sync imports, the result is just (IO a) or a,
+ -- and res_trans is id; for async cases, the result is
+ -- always (IO JSVal), and res_trans will wrap it in a
+ -- thunk that has the original return type. This way, we
+ -- can reuse most of the RHS generation logic for both
+ -- sync/async imports.
+ (res_trans $ res_wrapper call_app)
+ (zip args_unevaled args_evaled)
+ pure rhs
+
+importCStub :: Synchronicity -> FastString -> [Type] -> Type -> String -> CStub
+importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] []
where
import_name = fromJust $ stripPrefix "ghczuwasmzujsffi" (unpackFS cfun_name)
import_asm =
@@ -465,18 +476,18 @@ importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []
<> parens
( vcat
[ text (show l)
- | l <-
- [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n",
- ".asciz \"" ++ import_name ++ "\"\n",
- ".asciz \""
- ++ ( case safety of
- PlayRisky -> "("
- _ -> "async ("
- )
- ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]]
- ++ ")\"\n",
- ".asciz " ++ show js_src ++ "\n"
- ]
+ | l <-
+ [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n",
+ ".asciz \"" ++ import_name ++ "\"\n",
+ ".asciz \""
+ ++ ( case sync of
+ Sync -> "("
+ Async -> "async ("
+ )
+ ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]]
+ ++ ")\"\n",
+ ".asciz " ++ show js_src ++ "\n"
+ ]
]
)
<> semi
@@ -488,8 +499,8 @@ importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []
( punctuate
comma
[ text k <> parens (doubleQuotes (text v))
- | (k, v) <-
- [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)]
+ | (k, v) <-
+ [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)]
]
)
)
@@ -501,7 +512,7 @@ importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []
| otherwise = text ("Hs" ++ ffiType res_ty)
import_arg_list =
[ text ("Hs" ++ ffiType arg_ty) <+> char 'a' <> int i
- | (i, arg_ty) <- zip [1 ..] arg_tys
+ | (i, arg_ty) <- zip [1 ..] arg_tys
]
import_args = case import_arg_list of
[] -> text "void"
@@ -528,7 +539,7 @@ importCStub safety cfun_name arg_tys res_ty js_src = CStub c_doc [] []
( punctuate
comma
[ cfun_make_arg arg_ty (char 'a' <> int n)
- | (arg_ty, n) <- zip arg_tys [1 ..]
+ | (arg_ty, n) <- zip arg_tys [1 ..]
]
)
)
@@ -554,7 +565,8 @@ Note [Desugaring JSFFI static export]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A JSFFI static export wraps a top-level Haskell binding as a wasm
-module export that can be called in JavaScript as an async function:
+module export that can be called in JavaScript as an async/sync
+function:
foreign export javascript "plus"
(+) :: Int -> Int -> Int
@@ -565,32 +577,27 @@ stub for a JSFFI export as well:
__attribute__((export_name("plus")))
HsJSVal plus(HsInt a1, HsInt a2) { ... }
+The generated C stub function would be exported as __exports.plus and
+can be called in JavaScript. By default, it's exported as an async
+function, so the C stub would always return an HsJSVal which
+represents the result Promise; in case of a sync export (using "plus
+sync" instead of "plus"), it returns the original result type.
+
+The C stub function body applies the function closure to arguments,
+wrap it with a runIO/runNonIO top handler function, then schedules
+Haskell computation to happen, then fetches the result. In case of an
+async export, the top handler creates a JavaScript Promise that stands
+for Haskell evaluation result, and the Promise will eventually be
+resolved with the result or rejected with an exception. That Promise
+is what we return in the C stub function. See
+Note [Async JSFFI scheduler] for detailed explanation.
+
At link time, you need to pass -optl-Wl,--export=plus,--export=... to
specify your entrypoint function symbols as roots of wasm-ld link-time
garbage collection. As for the auto-generated exports when desugaring
the JSFFI dynamic exports, they will be transitively included as well
due to the export_name attribute.
-For each JSFFI static export, we create an internal worker function
-which takes the same arguments as the exported Haskell binding, but
-always returns (IO JSVal). Its RHS simply applies the arguments to the
-original binding, then applies a runIO/runNonIO top handler function
-to the result. The top handler creates a JavaScript Promise that
-stands for Haskell evaluation result, schedules Haskell computation to
-happen, and the Promise will eventually be resolved with the result or
-rejected with an exception. That Promise is what we return in the C
-stub function. See Note [Async JSFFI scheduler] for detailed
-explanation.
-
-There's nothing else to explain about the C stub function body; just
-like C FFI exports, it calls rts_mk* to box the arguments, rts_apply
-to apply them to the worker function, evaluates the result, then
-unboxes the resulting Promise using rts_getJSVal and returns it.
-
-Now, in JavaScript, once the wasm instance is initialized, you can
-directly call these exports and await them, as if they're real
-JavaScript async functions.
-
-}
dsWasmJSExport ::
@@ -598,108 +605,137 @@ dsWasmJSExport ::
Coercion ->
CLabelString ->
DsM (CHeader, CStub, String, [Id], [Binding])
-dsWasmJSExport fn_id co ext_name = do
- work_uniq <- newUnique
+dsWasmJSExport fn_id co str = dsWasmJSExport' sync fn_id co ext_name
+ where
+ (sync, ext_name) = case words $ unpackFS str of
+ [ext_name] -> (Async, ext_name)
+ [ext_name, "sync"] -> (Sync, ext_name)
+ _ -> panic "dsWasmJSExport: unrecognized label string"
+
+dsWasmJSExport' ::
+ Synchronicity ->
+ Id ->
+ Coercion ->
+ String ->
+ DsM (CHeader, CStub, String, [Id], [Binding])
+dsWasmJSExport' sync fn_id co ext_name = do
let ty = coercionRKind co
- (tvs, fun_ty) = tcSplitForAllInvisTyVars ty
+ (_, fun_ty) = tcSplitForAllInvisTyVars ty
(arg_tys, orig_res_ty) = tcSplitFunTys fun_ty
(res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of
Just (_, res_ty) -> (res_ty, True)
Nothing -> (orig_res_ty, False)
- (_, res_ty_args) = splitTyConApp res_ty
res_ty_str = ffiType res_ty
- args <- newSysLocalsDs arg_tys
+ top_handler_mod = case sync of
+ Sync -> "GHC.Internal.TopHandler"
+ Async -> "GHC.Internal.Wasm.Prim.Exports"
+ top_handler_name
+ | is_io = "runIO"
+ | otherwise = "runNonIO"
+ -- In case of sync export, we use the normal C FFI tophandler
+ -- functions. They would call flushStdHandles in case of uncaught
+ -- exception but not in normal cases, but we want flushStdHandles to
+ -- be called so that there are less run-time surprises for users,
+ -- and that's what our tophandler functions already do.
+ --
+ -- So for each sync export, we first wrap the computation with a C
+ -- FFI tophandler, and then sequence it with flushStdHandles using
+ -- (<*) :: IO a -> IO b -> IO a. But it's trickier to call (<*)
+ -- using RTS API given type class dictionary is involved, so we'll
+ -- just use finally.
+ finally_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.Control.Exception.Base"
+ "finally"
+ flushStdHandles_id <-
+ lookupGhcInternalVarId
+ "GHC.Internal.TopHandler"
+ "flushStdHandles"
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 =
- mkExportedVanillaId
- ( mkExternalName
- work_uniq
- (nameModule $ getName fn_id)
- (mkVarOcc $ "jsffi_" ++ occNameString (getOccName fn_id))
- generatedSrcSpan
- )
- (exprType work_rhs)
- work_rhs =
- mkCoreLams (tvs ++ args)
- $ mkApps
- (Var $ if is_io then runIO_id else runNonIO_id)
- [ Type res_ty,
- mkApps (Var promiseRes_id) $ map Type res_ty_args,
- mkApps (Cast (Var fn_id) co)
- $ map (Type . mkTyVarTy) tvs
- ++ map Var args
- ]
- work_closure = ppr work_id <> text "_closure"
- work_closure_decl = text "extern StgClosure" <+> work_closure <> semi
+ lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports"
+ $ "js_promiseResolve"
+ ++ res_ty_str
+ top_handler_id <- lookupGhcInternalVarId top_handler_mod top_handler_name
+ let ppr_closure c = ppr c <> text "_closure"
+ mk_extern_closure_decl c =
+ text "extern StgClosure" <+> ppr_closure c <> semi
+ gc_root_closures = case sync of
+ -- In case of C FFI top handlers, they are already declared in
+ -- RtsAPI.h and registered as GC roots in initBuiltinGcRoots.
+ -- flushStdHandles is already registered but somehow the C
+ -- stub can't access its declaration, won't hurt to declare it
+ -- again here.
+ Sync -> [finally_id, flushStdHandles_id, fn_id]
+ Async -> [top_handler_id, promiseRes_id, fn_id]
+ extern_closure_decls = vcat $ map mk_extern_closure_decl gc_root_closures
cstub_attr =
text "__attribute__"
<> parens
- (parens $ text "export_name" <> parens (doubleQuotes $ ftext ext_name))
+ (parens $ text "export_name" <> parens (doubleQuotes $ text ext_name))
cstub_arg_list =
[ text ("Hs" ++ ffiType (scaledThing arg_ty)) <+> char 'a' <> int i
- | (i, arg_ty) <- zip [1 ..] arg_tys
+ | (i, arg_ty) <- zip [1 ..] arg_tys
]
cstub_args = case cstub_arg_list of
[] -> text "void"
_ -> hsep $ punctuate comma cstub_arg_list
- cstub_proto = text "HsJSVal" <+> ftext ext_name <> parens cstub_args
+ cstub_proto
+ | Sync <- sync,
+ res_ty `eqType` unitTy =
+ text "void" <+> text ext_name <> parens cstub_args
+ | Sync <- sync =
+ text ("Hs" ++ res_ty_str) <+> text ext_name <> parens cstub_args
+ | Async <- sync =
+ text "HsJSVal" <+> text ext_name <> parens cstub_args
+ c_closure c = char '&' <> ppr_closure c
+ c_call fn args = text fn <> parens (hsep $ punctuate comma args)
+ c_rts_apply =
+ Data.List.foldl1' $ \fn arg -> c_call "rts_apply" [text "cap", fn, arg]
+ apply_top_handler expr = case sync of
+ Sync ->
+ c_rts_apply
+ [ c_closure finally_id,
+ c_rts_apply [c_closure top_handler_id, expr],
+ c_closure flushStdHandles_id
+ ]
+ Async ->
+ c_rts_apply [c_closure top_handler_id, c_closure promiseRes_id, expr]
+ cstub_ret
+ | Sync <- sync, res_ty `eqType` unitTy = empty
+ | Sync <- sync = text $ "return rts_get" ++ res_ty_str ++ "(ret);"
+ | Async <- sync = text "return rts_getJSVal(ret);"
cstub_body =
vcat
[ lbrace,
text "Capability *cap = rts_lock();",
text "HaskellObj ret;",
- -- rts_evalLazyIO is fine, the top handler always returns
- -- an evaluated result
- text "rts_evalLazyIO"
- <> parens
- ( hsep
- $ punctuate
- comma
- [ text "&cap",
- foldl'
- ( \acc (i, arg_ty) ->
- text "rts_apply"
- <> parens
- ( hsep
- $ punctuate
- comma
- [ text "cap",
- acc,
- text ("rts_mk" ++ ffiType (scaledThing arg_ty))
- <> parens
- (hsep $ punctuate comma [text "cap", char 'a' <> int i])
- ]
- )
- )
- (char '&' <> work_closure)
- $ zip [1 ..] arg_tys,
- text "&ret"
- ]
- )
+ c_call
+ "rts_inCall"
+ [ text "&cap",
+ apply_top_handler
+ $ c_rts_apply
+ $ c_closure fn_id
+ : [ c_call
+ ("rts_mk" ++ ffiType (scaledThing arg_ty))
+ [text "cap", char 'a' <> int i]
+ | (i, arg_ty) <- zip [1 ..] arg_tys
+ ],
+ text "&ret"
+ ]
<> semi,
- text "rts_checkSchedStatus"
- <> parens (doubleQuotes (ftext ext_name) <> comma <> text "cap")
+ c_call "rts_checkSchedStatus" [doubleQuotes (text ext_name), text "cap"]
<> semi,
text "rts_unlock(cap);",
- text "return rts_getJSVal(ret);",
+ cstub_ret,
rbrace
]
cstub =
commonCDecls
- $+$ work_closure_decl
+ $+$ extern_closure_decls
$+$ cstub_attr
$+$ cstub_proto
$+$ cstub_body
- pure
- ( CHeader commonCDecls,
- CStub cstub [] [],
- "",
- [work_id],
- [(work_id, work_rhs)]
- )
+ pure (CHeader commonCDecls, CStub cstub [] [], "", gc_root_closures, [])
lookupGhcInternalVarId :: FastString -> String -> DsM Id
lookupGhcInternalVarId m v = do
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -78,7 +78,7 @@ import GHC.Data.Bag
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad ( zipWithM )
+import Control.Monad ( when, zipWithM )
import Control.Monad.Trans.Writer.CPS
( WriterT, runWriterT, tell )
import Control.Monad.Trans.Class
@@ -444,7 +444,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do
checkCg (Left edecl) backendValidityOfCExport
- checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
+ when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
cconv' <- checkCConv (Left edecl) cconv
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
=====================================
docs/users_guide/wasm.rst
=====================================
@@ -231,15 +231,15 @@ There are two kinds of JSFFI imports: synchronous/asynchronous imports.
``unsafe`` indicates synchronous imports, which has the following
caveats:
-- The calling thread as well as the entire runtime blocks on waiting
- for the import result.
-- If the JavaScript code throws, the runtime crashes with the same
- error. A JavaScript exception cannot be handled as a Haskell
- exception here, so you need to use a JavaScript ``catch`` explicitly
- shall the need arise.
-- Like ``unsafe`` C imports, re-entrance is not supported, the imported
- foreign code must not call into Haskell again. Doing so would result
- in a runtime panic.
+- The calling thread as well as the entire runtime blocks on waiting for
+ the import result.
+- If the JavaScript code throws, the runtime crashes with the same
+ error. A JavaScript exception cannot be handled as a Haskell exception
+ here, so you need to use a JavaScript ``catch`` explicitly shall the
+ need arise.
+- Unlike ``unsafe`` C imports, re-entrance is actually supported, the
+ imported JavaScript code can call into Haskell again, provided that
+ Haskell function is exported as a synchronous one.
When a JSFFI import is marked as ``safe`` / ``interruptible`` or lacks
safety annotation, then it’s treated as an asynchronous import. The
@@ -274,14 +274,12 @@ runtime, and resumed when the ``Promise`` actually resolves or rejects.
Compared to synchronous JSFFI imports, asynchronous JSFFI imports have
the following notable pros/cons:
-- Waiting for the result only blocks a single Haskell thread, other
- threads can still make progress and garbage collection may still
- happen.
-- If the ``Promise`` rejects, Haskell code can catch JavaScript errors
- as ``JSException``\ s.
-- Re-entrance is supported. The JavaScript code may call into Haskell
- again and vice versa.
-- Of course, it has higher overhead than synchronous JSFFI imports.
+- Waiting for the result only blocks a single Haskell thread, other
+ threads can still make progress and garbage collection may still
+ happen.
+- If the ``Promise`` rejects, Haskell code can catch JavaScript errors
+ as ``JSException``\ s.
+- It has higher overhead than synchronous JSFFI imports.
Using thunks to encapsulate ``Promise`` result allows cheaper
concurrency without even needing to fork Haskell threads just for
@@ -345,12 +343,17 @@ wrapper, and as long as the wasm instance is properly initialized, you
can call ``await instance.exports.my_fib(10)`` to invoke the exported
Haskell function and get the result.
-Unlike JSFFI imports which have synchronous/asynchronous flavors, JSFFI
-exports are always asynchronous. Calling them always return a
-``Promise`` in JavaScript that needs to be ``await``\ ed for the real
-result. If the Haskell function throws, the ``Promise`` is rejected with
-a ``WebAssembly.RuntimeError``, and the ``message`` field contains a
-JavaScript string of the Haskell exception.
+JSFFI exports are asynchronous by default. Calling an async export
+return a ``Promise`` in JavaScript that needs to be ``await``\ ed for
+the real result. If the Haskell function throws, the ``Promise`` is
+rejected with a ``WebAssembly.RuntimeError``, and the ``message`` field
+contains a JavaScript string of the Haskell exception.
+
+Additionally, sync exports are also supported by using ``"my_fib sync"``
+instead of ``"my_fib"``. With ``sync`` added alongside export function
+name, the JavaScript function would return the result synchronously. For
+the time being, sync exports don’t support propagating uncaught Haskell
+exception to a JavaScript exception at the call site yet.
Above is the static flavor of JSFFI exports. It’s also possible to
export a dynamically created Haskell function closure as a JavaScript
@@ -366,8 +369,9 @@ function and obtain its ``JSVal``:
This is also much like ``foreign import ccall "wrapper"``, which wraps a
Haskell function closure as a C function pointer. Note that ``unsafe`` /
``safe`` annotation is ignored here, since the ``JSVal`` that represent
-the exported function is always returned synchronously, but it is always
-an asynchronous JavaScript function, just like static JSFFI exports.
+the exported function is always returned synchronously. Likewise, you
+can use ``"wrapper sync"`` instead of ``"wrapper"`` to indicate the
+returned JavaScript function is sync instead of async.
The ``JSVal`` callbacks created by dynamic JSFFI exports can be passed
to the rest of JavaScript world to be invoked later. But wait, didn’t we
=====================================
rts/include/RtsAPI.h
=====================================
@@ -587,15 +587,15 @@ void rts_done (void);
// the base package itself.
//
#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_GHC_INTERNAL_PACKAGE)
-__declspec(dllimport) extern StgWord ghczminternal_GHCziInternalziTopHandler_runIO_closure[];
-__declspec(dllimport) extern StgWord ghczminternal_GHCziInternalziTopHandler_runNonIO_closure[];
+__declspec(dllimport) extern StgClosure ghczminternal_GHCziInternalziTopHandler_runIO_closure;
+__declspec(dllimport) extern StgClosure ghczminternal_GHCziInternalziTopHandler_runNonIO_closure;
#else
-extern StgWord ghczminternal_GHCziInternalziTopHandler_runIO_closure[];
-extern StgWord ghczminternal_GHCziInternalziTopHandler_runNonIO_closure[];
+extern StgClosure ghczminternal_GHCziInternalziTopHandler_runIO_closure;
+extern StgClosure ghczminternal_GHCziInternalziTopHandler_runNonIO_closure;
#endif
-#define runIO_closure ghczminternal_GHCziInternalziTopHandler_runIO_closure
-#define runNonIO_closure ghczminternal_GHCziInternalziTopHandler_runNonIO_closure
+#define runIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runIO_closure)
+#define runNonIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runNonIO_closure)
/* ------------------------------------------------------------------------ */
=====================================
testsuite/tests/jsffi/jsffigc.hs
=====================================
@@ -10,17 +10,16 @@ import System.Mem
type BinOp a = a -> a -> a
-foreign import javascript "wrapper"
+foreign import javascript "wrapper sync"
js_from_hs :: BinOp Int -> IO JSVal
--- This must be safe since we intend to call back into Haskell again.
-foreign import javascript safe "dynamic"
+foreign import javascript unsafe "dynamic"
js_to_hs :: JSVal -> BinOp Int
foreign import javascript "wrapper"
js_mk_cont :: IO () -> IO JSVal
-foreign export javascript "testDynExportFree"
+foreign export javascript "testDynExportFree sync"
testDynExportFree :: Int -> Int -> Int -> IO ()
-- JSVal uses Weak# under the hood for garbage collection support,
=====================================
testsuite/tests/jsffi/jsffigc.mjs
=====================================
@@ -8,7 +8,7 @@ async function reallyGC() {
}
export default async (__exports) => {
- await __exports.testDynExportFree(114, 514, 1919810);
+ __exports.testDynExportFree(114, 514, 1919810);
const cont = await __exports.testDynExportGC(114, 514, 1919810);
await reallyGC();
=====================================
testsuite/tests/jsffi/textconv.hs
=====================================
@@ -45,7 +45,7 @@ textToJSString (Text (ByteArray ba#) (I# off#) (I# len#)) = unsafeDupablePerform
(# s1, mba# #) -> case copyByteArray# ba# off# mba# 0# len# s1 of
s2 -> keepAlive# mba# s2 $ unIO $ js_to_str (Ptr (mutableByteArrayContents# mba#)) $ I# len#
-foreign export javascript "main"
+foreign export javascript "main sync"
main :: IO ()
main :: IO ()
=====================================
testsuite/tests/jsffi/textconv.mjs
=====================================
@@ -1,3 +1,3 @@
-export default async (__exports) => {
- await __exports.main();
+export default (__exports) => {
+ __exports.main();
}
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -470,6 +470,8 @@ test('InternalCounters',
# The ways which build against the debug RTS are built with PROF_SPIN and
# therefore differ in output
, omit_ways(['nonmoving_thr_sanity', 'threaded2_sanity', 'sanity'])
+ # Likewise when ghc is linked with debug RTS using +debug_ghc
+ , when(debug_rts(), skip)
], makefile_test, ['InternalCounters'])
test('alloccounter1', js_broken(22261), compile_and_run,
[
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a2f4a197b6b5fc2c181603e52e02a5a40856da2a...2ce6ecb09f9172d51786ad3251554063e336689f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a2f4a197b6b5fc2c181603e52e02a5a40856da2a...2ce6ecb09f9172d51786ad3251554063e336689f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250220/7685f839/attachment-0001.html>
More information about the ghc-commits
mailing list