From dc904bfdd17ed1108580367b34bbe7204ed4ea95 Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Sat, 15 Mar 2025 06:29:17 +0000
Subject: [PATCH] wasm: implement promise.throwTo() for async JSFFI exports
This commit implements promise.throwTo() for wasm backend JSFFI
exports. This allows the JavaScript side to interrupt Haskell
computation by raising an async exception. See subsequent docs/test
commits for more details.
---
.../src/GHC/Internal/Wasm/Prim/Exports.hs | 18 ++++++++++++---
rts/wasm/JSFFI.c | 23 +++++++++++++++++++
2 files changed, 38 insertions(+), 3 deletions(-)
diff --git a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
index 1c02795b92d..c25c9f8fc7c 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Exports.hs
@@ -34,6 +34,7 @@ import GHC.Internal.Base
import GHC.Internal.Exception.Type
import GHC.Internal.Exts
import GHC.Internal.IO
+import GHC.Internal.IORef
import GHC.Internal.Int
import GHC.Internal.Stable
import GHC.Internal.TopHandler (flushStdHandles)
@@ -65,9 +66,14 @@ runIO res m = do
let tmp@(JSString tmp_v) = toJSString $ displayException err
js_promiseReject p tmp
freeJSVal tmp_v
- IO $ \s0 -> case fork# (unIO $ catch (res p =<< m) topHandler *> flushStdHandles) s0 of
- (# s1, _ #) -> case stg_scheduler_loop# s1 of
- (# s2, _ #) -> (# s2, p #)
+ post_action_ref <- newIORef $ pure ()
+ IO $ \s0 -> case fork# (unIO $ catch (res p =<< m) topHandler *> flushStdHandles *> join (readIORef post_action_ref)) s0 of
+ (# s1, tso# #) -> case mkWeakNoFinalizer# tso# () s1 of
+ (# s2, w# #) -> case makeStablePtr# w# s2 of
+ (# s3, sp# #) -> case unIO (writeIORef post_action_ref $ js_promiseDelThrowTo p *> freeStablePtr (StablePtr $ unsafeCoerce# sp#)) s3 of
+ (# s4, _ #) -> case unIO (js_promiseAddThrowTo p $ StablePtr $ unsafeCoerce# sp#) s4 of
+ (# s5, _ #) -> case stg_scheduler_loop# s5 of
+ (# s6, _ #) -> (# s6, p #)
runNonIO :: (JSVal -> a -> IO ()) -> a -> IO JSVal
runNonIO res a = runIO res $ pure a
@@ -75,6 +81,12 @@ runNonIO res a = runIO res $ pure a
foreign import javascript unsafe "let res, rej; const p = new Promise((resolve, reject) => { res = resolve; rej = reject; }); p.resolve = res; p.reject = rej; return p;"
js_promiseWithResolvers :: IO JSVal
+foreign import javascript unsafe "$1.throwTo = (err) => __exports.rts_promiseThrowTo($2, err);"
+ js_promiseAddThrowTo :: JSVal -> StablePtr Any -> IO ()
+
+foreign import javascript unsafe "$1.throwTo = () => {};"
+ js_promiseDelThrowTo :: JSVal -> IO ()
+
foreign import prim "stg_scheduler_loopzh"
stg_scheduler_loop# :: State# RealWorld -> (# State# RealWorld, () #)
diff --git a/rts/wasm/JSFFI.c b/rts/wasm/JSFFI.c
index 0c298b064a1..a1a52d676f4 100644
--- a/rts/wasm/JSFFI.c
+++ b/rts/wasm/JSFFI.c
@@ -1,6 +1,8 @@
#include "Rts.h"
#include "Prelude.h"
+#include "RaiseAsync.h"
#include "Schedule.h"
+#include "Threads.h"
#include "sm/Sanity.h"
#if defined(__wasm_reference_types__)
@@ -212,6 +214,27 @@ void rts_promiseReject(HsStablePtr, HsJSVal);
void rts_promiseReject(HsStablePtr sp, HsJSVal js_err)
mk_rtsPromiseCallback(rts_apply(cap, &ghczminternal_GHCziInternalziWasmziPrimziImports_raiseJSException_closure, rts_mkJSVal(cap, js_err)))
+__attribute__((export_name("rts_promiseThrowTo")))
+void rts_promiseThrowTo(HsStablePtr, HsJSVal);
+void rts_promiseThrowTo(HsStablePtr sp, HsJSVal js_err) {
+ Capability *cap = &MainCapability;
+ StgWeak *w = (StgWeak *)deRefStablePtr(sp);
+ if (w->header.info == &stg_DEAD_WEAK_info) {
+ return;
+ }
+ ASSERT(w->header.info == &stg_WEAK_info);
+ StgTSO *tso = (StgTSO *)w->key;
+ ASSERT(tso->header.info == &stg_TSO_info);
+ throwToSelf(
+ cap, tso,
+ rts_apply(
+ cap,
+ &ghczminternal_GHCziInternalziWasmziPrimziImports_raiseJSException_closure,
+ rts_mkJSVal(cap, js_err)));
+ tryWakeupThread(cap, tso);
+ rts_schedulerLoop();
+}
+
__attribute__((export_name("rts_freeStablePtr")))
void rts_freeStablePtr(HsStablePtr);
void rts_freeStablePtr(HsStablePtr sp) {
--
GitLab