diff --git a/testsuite/tests/jsffi/README.md b/testsuite/tests/jsffi/README.md new file mode 100644 index 0000000000000000000000000000000000000000..29abcb614479bf1281defee8494520b23dca7593 --- /dev/null +++ b/testsuite/tests/jsffi/README.md @@ -0,0 +1,33 @@ +# Tests for GHC wasm backend's JavaScript FFI + +This directory contains tests for JSFFI as implemented in the GHC wasm +backend. They are skipped if the target platform is not `wasm32`. +Otherwise, a recent version of `node` (at least `v21.2.0`) is required +to be in `PATH` for these tests. + +## How to add a new test case + +Each `testcase` is consisted of the following elements: + +- A `test('testcase', ...)` statement in `all.T`, check existing + examples there. +- A `testcase.hs` Haskell module. Since you define your own entry points and + link with `-no-hs-main` anyway, add a `module Test where` on top to + stop GHC from complaining about the lack of `Main.main`. +- A `testcase.stdout` standard output file. Note that we mark all + tests as `ignore_stderr`, because `node` itself likes to emit a + bunch of warning messages to `stderr` which changes from time to + time and there's little added value in adding workaround for this + issue. +- A `testcase.mjs` JavaScript ESM module. It has a default export + function, which takes the `__exports` object that contains the wasm + module exports as its argument. By the time this function is called + by the test runner, the wasm instance state has been initialized, + and you can call your exported Haskell functions here. + +## How to debug when a test case goes wrong + +Pass `--keep-test-files` to hadrian test to preserve the crime scene. +Go to that temporary directory and run +`/workspace/ghc/utils/jsffi/test-runner.mjs testcase.wasm +RTS ...` to +rerun the test case. diff --git a/testsuite/tests/jsffi/all.T b/testsuite/tests/jsffi/all.T new file mode 100644 index 0000000000000000000000000000000000000000..aa84d3d34230c8e0aac1ef7356f28619a0926bf1 --- /dev/null +++ b/testsuite/tests/jsffi/all.T @@ -0,0 +1,26 @@ +def override_target_wrapper(name, opts): + opts.target_wrapper = str( + config.top.joinpath('..', 'utils', 'jsffi', 'test-runner.mjs').resolve() + ) + +setTestOpts([ + unless(arch('wasm32'), skip), + override_target_wrapper, + ignore_stderr, + extra_hc_opts('-O2 -no-hs-main -optl-mexec-model=reactor'), + extra_ways(['compacting_gc', 'nonmoving', 'sanity']) +]) + +test('gameover', [], compile_and_run, ['-optl-Wl,--export=testJSException,--export=testHSException']) + +test('http', [], compile_and_run, ['-optl-Wl,--export=main']) + +test('jsffigc', [], compile_and_run, ['-optl-Wl,--export=testDynExportFree,--export=testDynExportGC']) + +test('jsffioff', [], compile_and_run, ['-optl-Wl,--export=hs_init,--export=main']) + +test('jsffion', [], compile_and_run, ['-optl-Wl,--export=main']) + +test('jsffisleep', [], compile_and_run, ['-optl-Wl,--export=testWouldBlock,--export=testLazySleep,--export=testThreadDelay,--export=testInterruptingSleep']) + +test('textconv', [], compile_and_run, ['-optl-Wl,--export=main']) diff --git a/testsuite/tests/jsffi/gameover.hs b/testsuite/tests/jsffi/gameover.hs new file mode 100644 index 0000000000000000000000000000000000000000..1aeb49d93f736615930883668b5205cf2c6b4ce6 --- /dev/null +++ b/testsuite/tests/jsffi/gameover.hs @@ -0,0 +1,22 @@ +-- Test that we can catch JavaScript exceptions in Haskell and vice +-- versa. + +module Test where + +import Control.Exception +import GHC.Wasm.Prim + +foreign import javascript safe "Promise.reject('game over')" + js_game_over :: IO () + +foreign export javascript "testJSException" + testJSException :: IO () + +testJSException :: IO () +testJSException = catch (evaluate =<< js_game_over) $ \(e :: JSException) -> print e + +foreign export javascript "testHSException" + testHSException :: IO () + +testHSException :: IO () +testHSException = fail "game over" diff --git a/testsuite/tests/jsffi/gameover.mjs b/testsuite/tests/jsffi/gameover.mjs new file mode 100644 index 0000000000000000000000000000000000000000..8b9ac0d6965acaf9ce759ed874f53dc6b8f60674 --- /dev/null +++ b/testsuite/tests/jsffi/gameover.mjs @@ -0,0 +1,8 @@ +export default async (__exports) => { + await __exports.testJSException(); + try { + await __exports.testHSException(); + } catch (e) { + console.log(e.message); + } +}; diff --git a/testsuite/tests/jsffi/gameover.stdout b/testsuite/tests/jsffi/gameover.stdout new file mode 100644 index 0000000000000000000000000000000000000000..27dcc09ab46be6b0b1a7ecf14f5d7c11eb4db2d6 --- /dev/null +++ b/testsuite/tests/jsffi/gameover.stdout @@ -0,0 +1,2 @@ +JSException "game over" +user error (game over) diff --git a/testsuite/tests/jsffi/http.hs b/testsuite/tests/jsffi/http.hs new file mode 100644 index 0000000000000000000000000000000000000000..e85f77a7bcdaa6c436762fdc3f75d51732af8f0e --- /dev/null +++ b/testsuite/tests/jsffi/http.hs @@ -0,0 +1,63 @@ +-- A nodejs http client/server ping/pong test as a simple integration +-- test for JSFFI. + +{-# LANGUAGE JavaScriptFFI #-} + +import GHC.Wasm.Prim + +newtype JSModule = JSModule JSVal + +newtype JSServer = JSServer JSVal + +newtype JSRequest = JSRequest JSVal + +newtype JSResponse = JSResponse JSVal + +newtype JSFunction = JSFunction JSVal + +foreign import javascript safe "import($1)" + js_import :: JSString -> IO JSModule + +foreign import javascript safe "$1.text($2)" + js_req_to_str :: JSModule -> JSRequest -> IO JSString + +foreign import javascript unsafe "$1.createServer($2)" + js_server_create :: JSModule -> JSFunction -> IO JSServer + +foreign import javascript safe "new Promise(res => { $1.listen(0, () => { res($1.address().port); }); })" + js_server_listen :: JSServer -> IO Int + +foreign import javascript "wrapper" + js_mk_req_handler :: (JSRequest -> JSResponse -> IO ()) -> IO JSFunction + +foreign import javascript unsafe "$1.writeHead(200, { 'Content-Type': 'text/plain' })" + js_resp_write_head :: JSResponse -> IO () + +foreign import javascript unsafe "$1.end($2)" + js_resp_end :: JSResponse -> JSString -> IO () + +foreign import javascript safe "const r = await fetch($1, {method: 'POST', body: $2}); return r.text();" + js_fetch_post :: JSString -> JSString -> IO JSString + +foreign import javascript unsafe "$1.close()" + js_server_close :: JSServer -> IO () + +foreign import javascript unsafe "console.log($1)" + js_print :: JSString -> IO () + +foreign export javascript "main" + main :: IO () + +main :: IO () +main = do + http <- js_import $ toJSString "node:http" + stream_consumers <- js_import $ toJSString "node:stream/consumers" + req_handler <- js_mk_req_handler $ \req resp -> do + req_str <- fromJSString <$> js_req_to_str stream_consumers req + js_resp_write_head resp + js_resp_end resp $ toJSString $ "pong: " <> req_str + server <- js_server_create http req_handler + port <- js_server_listen server + pong <- js_fetch_post (toJSString $ "http://localhost:" <> show port) (toJSString "ping") + js_print pong + js_server_close server diff --git a/testsuite/tests/jsffi/http.mjs b/testsuite/tests/jsffi/http.mjs new file mode 100644 index 0000000000000000000000000000000000000000..56ef3fdeef4cd0c529ccbe7ec12964ab0c794ce7 --- /dev/null +++ b/testsuite/tests/jsffi/http.mjs @@ -0,0 +1,3 @@ +export default async (__exports) => { + await __exports.main(); +} diff --git a/testsuite/tests/jsffi/http.stdout b/testsuite/tests/jsffi/http.stdout new file mode 100644 index 0000000000000000000000000000000000000000..fa64931af9b7d57493f7bb1c19980c43e89af950 --- /dev/null +++ b/testsuite/tests/jsffi/http.stdout @@ -0,0 +1 @@ +pong: ping diff --git a/testsuite/tests/jsffi/jsffigc.hs b/testsuite/tests/jsffi/jsffigc.hs new file mode 100644 index 0000000000000000000000000000000000000000..7b0f89798ae7cd6c6889ad156730651be61a3210 --- /dev/null +++ b/testsuite/tests/jsffi/jsffigc.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE MagicHash #-} + +module Test where + +import Data.Maybe +import GHC.Exts +import GHC.Wasm.Prim +import GHC.Weak +import System.Mem + +type BinOp a = a -> a -> a + +foreign import javascript "wrapper" + js_from_hs :: BinOp Int -> IO JSVal + +-- This must be safe since we intend to call back into Haskell again. +foreign import javascript safe "dynamic" + js_to_hs :: JSVal -> BinOp Int + +foreign import javascript "wrapper" + js_mk_cont :: IO () -> IO JSVal + +foreign export javascript "testDynExportFree" + testDynExportFree :: Int -> Int -> Int -> IO () + +-- JSVal uses Weak# under the hood for garbage collection support, +-- this exposes the internal Weak# to observe the liveliness of +-- JSVal#. Do not use this in your own codebase since this is purely +-- an implementation detail of JSVal and subject to change! +jsvalWeak :: JSVal -> Weak JSVal +jsvalWeak (JSVal _ w _) = Weak $ unsafeCoerce# Weak w + +probeWeak :: Weak v -> IO () +probeWeak wk = print =<< isJust <$> deRefWeak wk + +testDynExportFree :: Int -> Int -> Int -> IO () +testDynExportFree x y z = do + -- fn must be a dynamically created Haskell function closure. + let fn a b = a * b + z + -- wk_fn observe the liveliness of fn + wk_fn <- mkWeak fn () Nothing + cb <- js_from_hs fn + -- wk_js observe the liveliness of the JavaScript callback on the + -- Haskell heap. Make sure it's eagerly evaluated and isn't a thunk + -- that retains cb. + let !wk_js = jsvalWeak cb + print $ js_to_hs cb x y + -- Eagerly drop references to both the JavaScript callback and the + -- Haskell function closure. + freeJSVal cb + performGC + -- Now both should be dead. + probeWeak wk_js + probeWeak wk_fn + +foreign export javascript "testDynExportGC" + testDynExportGC :: Int -> Int -> Int -> IO JSVal + +testDynExportGC :: Int -> Int -> Int -> IO JSVal +testDynExportGC x y z = do + let fn a b = a * b + z + wk_fn <- mkWeak fn () Nothing + cb <- js_from_hs fn + let !wk_js = jsvalWeak cb + print $ js_to_hs cb x y + -- Why performGC twice? The first run gathers some C finalizers + -- which will be invoked in the second run to free the JSVal + -- references. It's an implementation detail of the GHC RTS. + performGC + performGC + -- Should be dead now, cb is recycled at this point. + probeWeak wk_js + -- Should be alive, despite cb is gone in the Haskell heap, it may + -- still be alive in the JavaScript side so we can't drop fn! + probeWeak wk_fn + -- Return a continuation to be called after the JavaScript side + -- finishes garbage collection. + js_mk_cont $ do + -- The JavaScript FinalizerRegistry logic only frees the stable + -- pointer that pins fn. So we need to invoke Haskell garbage + -- collection again. + performGC + -- Dead, finally. + probeWeak wk_fn diff --git a/testsuite/tests/jsffi/jsffigc.mjs b/testsuite/tests/jsffi/jsffigc.mjs new file mode 100644 index 0000000000000000000000000000000000000000..3178a8a83a050fd6257c0846e6a363a48cc30ab0 --- /dev/null +++ b/testsuite/tests/jsffi/jsffigc.mjs @@ -0,0 +1,16 @@ +function sleep(t) { + return new Promise(res => setTimeout(res, t)); +} + +async function reallyGC() { + gc(); // Only exposed by the --expose-gc V8 option + await sleep(1024); // For some reason, this is needed for the FinalizationRegistry logic to actually work +} + +export default async (__exports) => { + await __exports.testDynExportFree(114, 514, 1919810); + + const cont = await __exports.testDynExportGC(114, 514, 1919810); + await reallyGC(); + await cont(); +}; diff --git a/testsuite/tests/jsffi/jsffigc.stdout b/testsuite/tests/jsffi/jsffigc.stdout new file mode 100644 index 0000000000000000000000000000000000000000..374bce0895bf89e3c43770ddedbe41d18a8584e3 --- /dev/null +++ b/testsuite/tests/jsffi/jsffigc.stdout @@ -0,0 +1,7 @@ +1978406 +False +False +1978406 +False +True +False diff --git a/testsuite/tests/jsffi/jsffioff.hs b/testsuite/tests/jsffi/jsffioff.hs new file mode 100644 index 0000000000000000000000000000000000000000..ebef5a552b46262c2b69126232ac7fa705e9b9f7 --- /dev/null +++ b/testsuite/tests/jsffi/jsffioff.hs @@ -0,0 +1,10 @@ +import GHC.TopHandler +import GHC.Wasm.Prim + +foreign export ccall "main" + main :: IO () + +main :: IO () +main = do + print isJSFFIUsed + flushStdHandles diff --git a/testsuite/tests/jsffi/jsffioff.mjs b/testsuite/tests/jsffi/jsffioff.mjs new file mode 100644 index 0000000000000000000000000000000000000000..4da7c2309f0bfc884ff816801586b15d68833bef --- /dev/null +++ b/testsuite/tests/jsffi/jsffioff.mjs @@ -0,0 +1,4 @@ +export default (__exports) => { + __exports.hs_init(0, 0); + __exports.main(); +} diff --git a/testsuite/tests/jsffi/jsffioff.stdout b/testsuite/tests/jsffi/jsffioff.stdout new file mode 100644 index 0000000000000000000000000000000000000000..bc59c12aa16bda1942655872af699a2d418c472b --- /dev/null +++ b/testsuite/tests/jsffi/jsffioff.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/jsffi/jsffion.hs b/testsuite/tests/jsffi/jsffion.hs new file mode 100644 index 0000000000000000000000000000000000000000..4b99a0e2ae324993dd704942010206dee3487fe6 --- /dev/null +++ b/testsuite/tests/jsffi/jsffion.hs @@ -0,0 +1,7 @@ +import GHC.Wasm.Prim + +foreign export javascript "main" + main :: IO () + +main :: IO () +main = print isJSFFIUsed diff --git a/testsuite/tests/jsffi/jsffion.mjs b/testsuite/tests/jsffi/jsffion.mjs new file mode 100644 index 0000000000000000000000000000000000000000..56ef3fdeef4cd0c529ccbe7ec12964ab0c794ce7 --- /dev/null +++ b/testsuite/tests/jsffi/jsffion.mjs @@ -0,0 +1,3 @@ +export default async (__exports) => { + await __exports.main(); +} diff --git a/testsuite/tests/jsffi/jsffion.stdout b/testsuite/tests/jsffi/jsffion.stdout new file mode 100644 index 0000000000000000000000000000000000000000..0ca95142bb715442d0c2c82a7c573a08c4593845 --- /dev/null +++ b/testsuite/tests/jsffi/jsffion.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/jsffi/jsffisleep.hs b/testsuite/tests/jsffi/jsffisleep.hs new file mode 100644 index 0000000000000000000000000000000000000000..8e9c6852643948918acf1b4d9573602ad90603f3 --- /dev/null +++ b/testsuite/tests/jsffi/jsffisleep.hs @@ -0,0 +1,78 @@ +module Test where + +import Control.Concurrent +import Control.Exception +import Data.Foldable +import Data.Traversable +import GHC.TopHandler +import GHC.Wasm.Prim + +-- Same thing used internally by threadDelay when JSFFI is used +foreign import javascript safe "new Promise(res => setTimeout(res, $1 / 1000))" + js_lazy_sleep :: Int -> IO () + +foreign export ccall "testWouldBlock" + testWouldBlock :: IO () + +-- When a Haskell function exported via C FFI attempts to block on an +-- async JSFFI import, a WouldBlockException will be thrown. Also note +-- that we need to explicitly flushStdHandles, which is required for +-- 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 + flushStdHandles + +foreign export javascript "testLazySleep" + testLazySleep :: Int -> Int -> IO () + +-- If async JSFFI import blocks the caller eagerly, then this would +-- sleep for t*n milliseconds, causing a noticable delay when running +-- this test case. +testLazySleep :: Int -> Int -> IO () +testLazySleep t n = do + thunks <- for [1..n] $ \_ -> js_lazy_sleep t + for_ thunks evaluate + putStrLn "zzzzzzz" + +foreign export javascript "testThreadDelay" + testThreadDelay :: Int -> Int -> IO () + +-- Some folks may still prefer to wrap their async JSFFI imports to +-- always block on waiting for the result and only expose the wrapper +-- functions. So doing concurrent requests would require forking a +-- thread per request. Which is also fine. +testThreadDelay :: Int -> Int -> IO () +testThreadDelay t n = do + mvars <- for [1..n] $ \_ -> newEmptyMVar + for_ mvars $ \mv -> forkFinally (threadDelay t) $ putMVar mv + for_ mvars takeMVar + putStrLn "i sleep" + +foreign export javascript "testInterruptingSleep" + testInterruptingSleep :: IO () + +-- When a thread is blocked waiting for an async JSFFI import call to +-- return, it can be interrupted by a Haskell async exception. The +-- async exception will not magically cancel the pending JavaScript +-- Promise, nor will it enqueue the target thread for execution. Only +-- when that Promise actually resolves or rejects, the thread will be +-- waken up again. +-- +-- The current way JSFFI handles async exception is not completely +-- satisfactory, but it's a good enough balance between implementation +-- difficulty and ease of usage. +testInterruptingSleep :: IO () +testInterruptingSleep = do + mv <- newEmptyMVar + tid <- forkIO $ catch (threadDelay 1000000 *> putMVar mv (Right ())) $ \(e :: SomeException) -> putMVar mv $ Left e + -- Without this, the thread we forked earlier likely have not even + -- performed the call yet. It will be interrupted and silently + -- dropped without a chance to be waken up, so the MVar will remain + -- empty and this thread will also be suspended without waking up, + -- eventually propagating as a "never fulfilled top-level await" + -- error to the JavaScript host. + threadDelay 1000 + killThread tid + print =<< takeMVar mv diff --git a/testsuite/tests/jsffi/jsffisleep.mjs b/testsuite/tests/jsffi/jsffisleep.mjs new file mode 100644 index 0000000000000000000000000000000000000000..687e483ae4de9e9e40557eef0c15515ed479b4d9 --- /dev/null +++ b/testsuite/tests/jsffi/jsffisleep.mjs @@ -0,0 +1,6 @@ +export default async (__exports) => { + __exports.testWouldBlock(); + await __exports.testLazySleep(1000000, 1024); + await __exports.testThreadDelay(1000000, 1024); + await __exports.testInterruptingSleep(); +} diff --git a/testsuite/tests/jsffi/jsffisleep.stdout b/testsuite/tests/jsffi/jsffisleep.stdout new file mode 100644 index 0000000000000000000000000000000000000000..6aa5bcb432da09b52e9bbdb7377009bb78aa38ce --- /dev/null +++ b/testsuite/tests/jsffi/jsffisleep.stdout @@ -0,0 +1,4 @@ +WouldBlockException +zzzzzzz +i sleep +Left thread killed diff --git a/testsuite/tests/jsffi/textconv.hs b/testsuite/tests/jsffi/textconv.hs new file mode 100644 index 0000000000000000000000000000000000000000..d7ca3581cc32738d555f9d203fe706c1adbb5163 --- /dev/null +++ b/testsuite/tests/jsffi/textconv.hs @@ -0,0 +1,52 @@ +-- This test demonstrates how to convert between Text and JSString. +-- Ideally this would be a part of GHC.Wasm.Prim, but that module +-- can't use anything from text. Hopefully the code here can be +-- properly adopted somewhere else. + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnboxedTuples #-} + +import Data.Array.Byte +import Data.Coerce +import Data.Text.Internal +import qualified Data.Text.IO.Utf8 as T +import GHC.Exts +import GHC.IO +import GHC.Wasm.Prim + +newtype JSUint8Array = JSUint8Array JSVal + +foreign import javascript unsafe "(new TextEncoder()).encode($1)" + js_str_encode :: JSString -> IO JSUint8Array + +foreign import javascript unsafe "$1.byteLength" + js_buf_len :: JSUint8Array -> IO Int + +foreign import javascript unsafe "(new Uint8Array(__exports.memory.buffer, $2, $1.byteLength)).set($1)" + js_from_buf :: JSUint8Array -> Ptr a -> IO () + +foreign import javascript unsafe "(new TextDecoder('utf-8', {fatal: true})).decode(new Uint8Array(__exports.memory.buffer, $1, $2))" + js_to_str :: Ptr a -> Int -> IO JSString + +textFromJSString :: JSString -> Text +textFromJSString str = unsafeDupablePerformIO $ do + buf <- js_str_encode str + I# len# <- js_buf_len buf + IO $ \s0 -> case newByteArray# len# s0 of + (# s1, mba# #) -> case unIO (js_from_buf buf (Ptr (mutableByteArrayContents# mba#))) s1 of + (# s2, _ #) -> case unIO (freeJSVal (coerce buf)) s2 of + (# s3, _ #) -> case unsafeFreezeByteArray# mba# s3 of + (# s4, ba# #) -> (# s4, Text (ByteArray ba#) 0 (I# len#) #) + +textToJSString :: Text -> JSString +textToJSString (Text (ByteArray ba#) (I# off#) (I# len#)) = unsafeDupablePerformIO $ + IO $ \s0 -> case newPinnedByteArray# len# s0 of + (# s1, mba# #) -> case copyByteArray# ba# off# mba# 0# len# s1 of + s2 -> keepAlive# mba# s2 $ unIO $ js_to_str (Ptr (mutableByteArrayContents# mba#)) $ I# len# + +foreign export javascript "main" + main :: IO () + +main :: IO () +main = T.putStrLn $ textFromJSString $ textToJSString "lorem ipsum" diff --git a/testsuite/tests/jsffi/textconv.mjs b/testsuite/tests/jsffi/textconv.mjs new file mode 100644 index 0000000000000000000000000000000000000000..56ef3fdeef4cd0c529ccbe7ec12964ab0c794ce7 --- /dev/null +++ b/testsuite/tests/jsffi/textconv.mjs @@ -0,0 +1,3 @@ +export default async (__exports) => { + await __exports.main(); +} diff --git a/testsuite/tests/jsffi/textconv.stdout b/testsuite/tests/jsffi/textconv.stdout new file mode 100644 index 0000000000000000000000000000000000000000..01a59b011a48660bb3828ec72b2b08990b8cf56b --- /dev/null +++ b/testsuite/tests/jsffi/textconv.stdout @@ -0,0 +1 @@ +lorem ipsum