From 9b54eecbee7329543e5016cec1574831bfb788c2 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.
---
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 34464557cf9..580a446d866 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