[Git][ghc/ghc][master] JS: fix FFI "wrapper" and "dynamic"
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Nov 1 13:20:43 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
575d7690 by Sylvain Henry at 2023-11-01T09:19:53-04:00
JS: fix FFI "wrapper" and "dynamic"
Fix codegen and helper functions for "wrapper" and "dynamic" foreign
imports.
Fix tests:
- ffi006
- ffi011
- T2469
- T4038
Related to #22363
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- libraries/base/src/GHC/JS/Prim.hs
- rts/js/mem.js
- rts/js/rts.js
- testsuite/tests/ffi/should_run/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -157,14 +157,17 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
idTag i = let (tag, u) = unpkUnique (getUnique i)
in CHeader (char tag <> word64 u)
+ normal_args = map (\(nm,_ty,_,_) -> nm) arg_info
+ all_args
+ | isNothing maybe_target = text "stableptr_offset" : normal_args
+ | otherwise = normal_args
+
fun_args
| null arg_info = empty -- text "void"
- | otherwise = hsep $ punctuate comma
- $ map (\(nm,_ty,_,_) -> nm) arg_info
+ | otherwise = hsep $ punctuate comma all_args
fun_proto
- = text "async" <+>
- text "function" <+>
+ = text "function" <+>
(if isNothing maybe_target
then text "h$" <> ftext c_nm
else ftext c_nm) <>
@@ -188,7 +191,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
-- the target which will form the root of what we ask rts_evalIO to run
the_cfun
= case maybe_target of
- Nothing -> text "h$deRefStablePtr(the_stableptr)"
+ Nothing -> text "h$deRefStablePtr(stableptr_offset)"
Just hs_fn -> idClosureText hs_fn
-- the expression we give to rts_eval
@@ -210,8 +213,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
$$ vcat
[ lbrace
, text "return"
- <+> text "await"
- <+> text "h$rts_eval"
+ <+> text "h$rts_eval_sync"
<> parens ((if is_IO_res_ty
then expr_to_run
else text "h$rts_toIO" <> parens expr_to_run)
=====================================
libraries/base/src/GHC/JS/Prim.hs
=====================================
@@ -85,7 +85,7 @@ toIO x = pure x
resolve :: JSVal# -> JSVal# -> Exts.Any -> IO ()
resolve accept reject x = resolveIO accept reject (pure x)
-{-# NOINLINE resolveIO #-}
+{-# NOINLINE resolveIO #-} -- used by the rts
resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO ()
resolveIO accept reject x =
(x >>= evaluate >>= js_callback_any accept) `catch`
=====================================
rts/js/mem.js
=====================================
@@ -519,8 +519,14 @@ function h$initPtrLbl(isFun, lbl) {
return lbl;
}
-function h$callDynamic(f) {
- return f.apply(f, Array.prototype.slice.call(arguments, 2));
+function h$callDynamic(f_d,f_o) {
+ // make sure that we got a StablePtr
+ if (f_d !== h$stablePtrBuf) {
+ throw ("callDynamic: expecting a StablePtr and got: " + f_d)
+ }
+ var f = h$deRefStablePtr(f_o);
+ var args = Array.prototype.slice.call(arguments, 2);
+ return f.apply(f, args);
}
// slice an array of heap objects
=====================================
rts/js/rts.js
=====================================
@@ -16,8 +16,8 @@ function h$rts_eval_sync(closure, unbox) {
var res, status = 0;
try {
h$runSync(MK_AP3( h$baseZCGHCziJSziPrimziresolveIO
- , MK_JSVAL(x => { status = 1; res = unbox(x); })
- , MK_JSVAL(e => { status = 2; res = new h$HaskellException(e); })
+ , x => { status = 1; res = unbox(x); }
+ , e => { status = 2; res = new h$HaskellException(e); }
, closure), false);
} catch(e) { status = 2; res = e; }
switch(status) {
@@ -27,7 +27,6 @@ function h$rts_eval_sync(closure, unbox) {
}
}
-
function h$rts_apply(f, x) {
return MK_AP1(f, x);
}
@@ -51,7 +50,7 @@ function h$rts_apply(f, x) {
function h$rts_mkChar(x) { return x|0; }
function h$rts_getChar(x) { return UNWRAP_NUMBER(x); }
-function h$rts_mkWord(x) { return x|0; }
+function h$rts_mkWord(x) { return x>>>0; }
function h$rts_getWord(x) { return UNWRAP_NUMBER(x); }
function h$rts_mkInt(x) { return x|0; }
@@ -60,7 +59,7 @@ function h$rts_getInt(x) { return UNWRAP_NUMBER(x); }
function h$rts_mkInt32(x) { return x|0; }
function h$rts_getInt32(x) { return UNWRAP_NUMBER(x); }
-function h$rts_mkWord32(x) { return x|0; }
+function h$rts_mkWord32(x) { return x>>>0; }
function h$rts_getWord32(x) { return UNWRAP_NUMBER(x); }
function h$rts_mkInt16(x) { return (x<<16)>>16; }
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -38,7 +38,7 @@ test('ffi005', [ omit_ways(prof_ways),
req_c ],
compile_and_run, ['ffi005_c.c'])
-test('ffi006', [normal, js_broken(22363)], compile_and_run, [''])
+test('ffi006', normal, compile_and_run, [''])
# Skip ffi00{7,8} for GHCi. These tests both try to exit or raise an
# error from a foreign export, which shuts down the runtime. When
@@ -59,7 +59,7 @@ else:
opts = ''
test('ffi010', normal, compile_and_run, [''])
-test('ffi011', [normal, js_broken(22363)], compile_and_run, [''])
+test('ffi011', normal, compile_and_run, [''])
# The stdcall calling convention works on Windows, and sometimes on
# Linux, and fails everywhhere else. For now, we test only on Windows,
@@ -115,7 +115,7 @@ test('T2276_ghci', [ only_ghci,
pre_cmd('$MAKE -s --no-print-directory T2276_ghci_setup') ],
compile_and_run, ['-fobject-code T2276_ghci_c.o'])
-test('T2469', js_broken(22261), compile_and_run, ['-optc-std=gnu99'])
+test('T2469', normal, compile_and_run, ['-optc-std=gnu99'])
test('T2594', [req_c], compile_and_run, ['T2594_c.c'])
@@ -143,7 +143,7 @@ if config.os == 'mingw32':
flagsForT4038 = ['-optl-Wl,--stack,10485760']
else:
flagsForT4038 = ['']
-test('T4038', [js_broken(22261), when(arch('wasm32'), fragile(22606))], compile_and_run, flagsForT4038)
+test('T4038', [when(arch('wasm32'), fragile(22606))], compile_and_run, flagsForT4038)
test('T4221', [req_c, when(arch('wasm32'), fragile(22606))], compile_and_run, ['T4221_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/575d769096d60f4a7561b2b9625b8d75e0a3879c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/575d769096d60f4a7561b2b9625b8d75e0a3879c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231101/16d4bdc5/attachment-0001.html>
More information about the ghc-commits
mailing list