From 45f73281e271519528eea935bd3967add95373dd Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Mon, 3 Mar 2025 10:47:05 +0000
Subject: [PATCH] wasm: add error message to WouldBlockException
This commit attaches an error message to WouldBlockException, for now
the error message consists of the JS async import code snippet that
thunk is trying to block for. This is useful for debugging synchronous
callbacks that accidentally call an async JS function.
(cherry picked from commit 9b54eecbee7329543e5016cec1574831bfb788c2)
(cherry picked from commit a0995a9d9151345322a9172e547af95b7b5e5def)
---
compiler/GHC/HsToCore/Foreign/Wasm.hs | 3 ++-
.../ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs | 6 +++---
libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs | 4 ++--
testsuite/tests/jsffi/jsffisleep.hs | 4 ++--
testsuite/tests/jsffi/jsffisleep.stdout | 2 +-
5 files changed, 10 insertions(+), 9 deletions(-)
diff --git a/compiler/GHC/HsToCore/Foreign/Wasm.hs b/compiler/GHC/HsToCore/Foreign/Wasm.hs
index 37db4f548a7..781611c41ad 100644
--- a/compiler/GHC/HsToCore/Foreign/Wasm.hs
+++ b/compiler/GHC/HsToCore/Foreign/Wasm.hs
@@ -318,6 +318,7 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do
importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src
)
Async -> do
+ err_msg <- mkStringExpr $ js_src
io_tycon <- dsLookupTyCon ioTyConName
jsval_ty <-
mkTyConTy
@@ -363,7 +364,7 @@ dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do
[ Type res_ty,
mkApps
(Var blockPromise_id)
- [Type res_ty, Var promise_id, Var msgPromise_id]
+ [Type res_ty, err_msg, Var promise_id, Var msgPromise_id]
]
]
)
diff --git a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
index 62109a47959..8fd6e6875d9 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Imports.hs
@@ -79,9 +79,9 @@ filled is generated via raiseJSException.
-}
-stg_blockPromise :: JSVal -> (JSVal -> StablePtr Any -> IO ()) -> r
-stg_blockPromise p msg_p = unsafeDupablePerformIO $ IO $ \s0 ->
- case stg_jsffi_check (unsafeCoerce# $ toException WouldBlockException) s0 of
+stg_blockPromise :: String -> JSVal -> (JSVal -> StablePtr Any -> IO ()) -> r
+stg_blockPromise err_msg p msg_p = unsafeDupablePerformIO $ IO $ \s0 ->
+ case stg_jsffi_check (unsafeCoerce# $ toException $ WouldBlockException err_msg) s0 of
(# s1 #) -> case myThreadId# s1 of
(# s2, tso #) -> case makeStablePtr# tso s2 of
(# s3, sp #) ->
diff --git a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
index 39800ee383c..b2cc19b9f5e 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Wasm/Prim/Types.hs
@@ -139,8 +139,8 @@ foreign import javascript unsafe "`${$1.stack ? $1.stack : $1}`"
instance Exception JSException
-data WouldBlockException
- = WouldBlockException
+newtype WouldBlockException
+ = WouldBlockException String
deriving (Show)
instance Exception WouldBlockException
diff --git a/testsuite/tests/jsffi/jsffisleep.hs b/testsuite/tests/jsffi/jsffisleep.hs
index 8e9c6852643..f312f8e9ea3 100644
--- a/testsuite/tests/jsffi/jsffisleep.hs
+++ b/testsuite/tests/jsffi/jsffisleep.hs
@@ -20,8 +20,8 @@ foreign export ccall "testWouldBlock"
-- non-main exports in C FFI. In JSFFI, it's always done automatically
-- for every export though.
testWouldBlock :: IO ()
-testWouldBlock = catch (threadDelay 1000000) $ \WouldBlockException -> do
- print WouldBlockException
+testWouldBlock = catch (threadDelay 1000000) $ \(WouldBlockException err) -> do
+ print $ WouldBlockException err
flushStdHandles
foreign export javascript "testLazySleep"
diff --git a/testsuite/tests/jsffi/jsffisleep.stdout b/testsuite/tests/jsffi/jsffisleep.stdout
index 6aa5bcb432d..59a7f084e1b 100644
--- a/testsuite/tests/jsffi/jsffisleep.stdout
+++ b/testsuite/tests/jsffi/jsffisleep.stdout
@@ -1,4 +1,4 @@
-WouldBlockException
+WouldBlockException "new Promise(res => setTimeout(res, $1 / 1000))"
zzzzzzz
i sleep
Left thread killed
--
GitLab