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.

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, () #)
 

rts/wasm/JSFFI.c

 #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) {