diff --git a/compiler/GHC/HsToCore/Foreign/Wasm.hs b/compiler/GHC/HsToCore/Foreign/Wasm.hs index 34464557cf9c7e10c8846577d2ef87c88685b574..580a446d866989f5a9d1df1aaab2ccb22fa20831 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 62109a47959c5e945038e4074c750c77b43fa146..8fd6e6875d9dfb653c858612cca0e26d895bc87c 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 39800ee383c3b937a449ea6cfa0e3288f49a6566..b2cc19b9f5e83d9225c7b6acf4c8588e720ce140 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 8e9c6852643948918acf1b4d9573602ad90603f3..f312f8e9ea3b780b06d1a1b314196cda3d4c1611 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 6aa5bcb432da09b52e9bbdb7377009bb78aa38ce..59a7f084e1b413f6d4bd47fc3a4badfa86609b31 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